re PR fortran/22146 (ICE when calling ELEMENTAL subroutines)
2006-01-07 Paul Thomas <pault@gcc.gnu.org> PR fortran/22146 * trans-array.c (gfc_reverse_ss): Remove static attribute. (gfc_walk_elemental_function_args): Replace gfc_expr * argument for the function call with the corresponding gfc_actual_arglist*. Change code accordingly. (gfc_walk_function_expr): Call to gfc_walk_elemental_function_args now requires the actual argument list instead of the expression for the function call. * trans-array.h: Modify the prototype for gfc_walk_elemental_function_args and provide a prototype for gfc_reverse_ss. * trans-stmt.h (gfc_trans_call): Add the scalarization code for the case where an elemental subroutine has array valued actual arguments. PR fortran/25029 PR fortran/21256 PR fortran/20868 PR fortran/20870 * resolve.c (check_assumed_size_reference): New function to check for upper bound in assumed size array references. (resolve_assumed_size_actual): New function to do a very restricted scan of actual argument expressions of those procedures for which incomplete assumed size array references are not allowed. (resolve_function, resolve_call): Switch off assumed size checking of actual arguments, except for elemental procedures and intrinsic inquiry functions, in some circumstances. (resolve_variable): Call check_assumed_size_reference. 2006-01-07 Paul Thomas <pault@gcc.gnu.org> PR fortran/22146 * gfortran.dg/elemental_subroutine_1.f90: New test. * gfortran.dg/elemental_subroutine_2.f90: New test. PR fortran/25029 PR fortran/21256 * gfortran.dg/assumed_size_refs_1.f90: New test. PR fortran/20868 PR fortran/20870 * gfortran.dg/assumed_size_refs_2.f90: New test. * gfortran.dg/initialization_1.f90: Change warning message. From-SVN: r109449
This commit is contained in:
Paul Thomas
parent
2784076858
commit
48474141e5
13 changed files with 505 additions and 29 deletions
|
|
@ -331,6 +331,7 @@ Richard Stallman rms@gnu.org
|
|||
Graham Stott graham.stott@btinternet.com
|
||||
Mike Stump mrs@apple.com
|
||||
Jeff Sturm jsturm@gcc.gnu.org
|
||||
Paul Thomas pault@gcc.gnu.org
|
||||
Kresten Krab Thorup krab@gcc.gnu.org
|
||||
Caroline Tice ctice@apple.com
|
||||
Michael Tiemann tiemann@redhat.com
|
||||
|
|
|
|||
|
|
@ -1,3 +1,32 @@
|
|||
2006-01-07 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/22146
|
||||
* trans-array.c (gfc_reverse_ss): Remove static attribute.
|
||||
(gfc_walk_elemental_function_args): Replace gfc_expr * argument for
|
||||
the function call with the corresponding gfc_actual_arglist*. Change
|
||||
code accordingly.
|
||||
(gfc_walk_function_expr): Call to gfc_walk_elemental_function_args
|
||||
now requires the actual argument list instead of the expression for
|
||||
the function call.
|
||||
* trans-array.h: Modify the prototype for gfc_walk_elemental_function_args
|
||||
and provide a prototype for gfc_reverse_ss.
|
||||
* trans-stmt.h (gfc_trans_call): Add the scalarization code for the case
|
||||
where an elemental subroutine has array valued actual arguments.
|
||||
|
||||
PR fortran/25029
|
||||
PR fortran/21256
|
||||
PR fortran/20868
|
||||
PR fortran/20870
|
||||
* resolve.c (check_assumed_size_reference): New function to check for upper
|
||||
bound in assumed size array references.
|
||||
(resolve_assumed_size_actual): New function to do a very restricted scan
|
||||
of actual argument expressions of those procedures for which incomplete
|
||||
assumed size array references are not allowed.
|
||||
(resolve_function, resolve_call): Switch off assumed size checking of
|
||||
actual arguments, except for elemental procedures and intrinsic
|
||||
inquiry functions, in some circumstances.
|
||||
(resolve_variable): Call check_assumed_size_reference.
|
||||
|
||||
2006-01-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
|
||||
|
||||
PR libgfortran/25598
|
||||
|
|
|
|||
|
|
@ -696,6 +696,69 @@ procedure_kind (gfc_symbol * sym)
|
|||
return PTYPE_UNKNOWN;
|
||||
}
|
||||
|
||||
/* Check references to assumed size arrays. The flag need_full_assumed_size
|
||||
is non-zero when matching actual arguments. */
|
||||
|
||||
static int need_full_assumed_size = 0;
|
||||
|
||||
static bool
|
||||
check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
|
||||
{
|
||||
gfc_ref * ref;
|
||||
int dim;
|
||||
int last = 1;
|
||||
|
||||
if (need_full_assumed_size
|
||||
|| !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
|
||||
return false;
|
||||
|
||||
for (ref = e->ref; ref; ref = ref->next)
|
||||
if (ref->type == REF_ARRAY)
|
||||
for (dim = 0; dim < ref->u.ar.as->rank; dim++)
|
||||
last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
|
||||
|
||||
if (last)
|
||||
{
|
||||
gfc_error ("The upper bound in the last dimension must "
|
||||
"appear in the reference to the assumed size "
|
||||
"array '%s' at %L.", sym->name, &e->where);
|
||||
return true;
|
||||
}
|
||||
return false;
|
||||
}
|
||||
|
||||
|
||||
/* Look for bad assumed size array references in argument expressions
|
||||
of elemental and array valued intrinsic procedures. Since this is
|
||||
called from procedure resolution functions, it only recurses at
|
||||
operators. */
|
||||
|
||||
static bool
|
||||
resolve_assumed_size_actual (gfc_expr *e)
|
||||
{
|
||||
if (e == NULL)
|
||||
return false;
|
||||
|
||||
switch (e->expr_type)
|
||||
{
|
||||
case EXPR_VARIABLE:
|
||||
if (e->symtree
|
||||
&& check_assumed_size_reference (e->symtree->n.sym, e))
|
||||
return true;
|
||||
break;
|
||||
|
||||
case EXPR_OP:
|
||||
if (resolve_assumed_size_actual (e->value.op.op1)
|
||||
|| resolve_assumed_size_actual (e->value.op.op2))
|
||||
return true;
|
||||
break;
|
||||
|
||||
default:
|
||||
break;
|
||||
}
|
||||
return false;
|
||||
}
|
||||
|
||||
|
||||
/* Resolve an actual argument list. Most of the time, this is just
|
||||
resolving the expressions in the list.
|
||||
|
|
@ -1092,10 +1155,18 @@ resolve_function (gfc_expr * expr)
|
|||
gfc_actual_arglist *arg;
|
||||
const char *name;
|
||||
try t;
|
||||
int temp;
|
||||
|
||||
/* Switch off assumed size checking and do this again for certain kinds
|
||||
of procedure, once the procedure itself is resolved. */
|
||||
need_full_assumed_size++;
|
||||
|
||||
if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
/* Resume assumed_size checking. */
|
||||
need_full_assumed_size--;
|
||||
|
||||
/* See if function is already resolved. */
|
||||
|
||||
if (expr->value.function.name != NULL)
|
||||
|
|
@ -1133,6 +1204,9 @@ resolve_function (gfc_expr * expr)
|
|||
if (expr->expr_type != EXPR_FUNCTION)
|
||||
return t;
|
||||
|
||||
temp = need_full_assumed_size;
|
||||
need_full_assumed_size = 0;
|
||||
|
||||
if (expr->value.function.actual != NULL
|
||||
&& ((expr->value.function.esym != NULL
|
||||
&& expr->value.function.esym->attr.elemental)
|
||||
|
|
@ -1140,7 +1214,6 @@ resolve_function (gfc_expr * expr)
|
|||
&& expr->value.function.isym->elemental)))
|
||||
{
|
||||
/* The rank of an elemental is the rank of its array argument(s). */
|
||||
|
||||
for (arg = expr->value.function.actual; arg; arg = arg->next)
|
||||
{
|
||||
if (arg->expr != NULL && arg->expr->rank > 0)
|
||||
|
|
@ -1149,8 +1222,45 @@ resolve_function (gfc_expr * expr)
|
|||
break;
|
||||
}
|
||||
}
|
||||
|
||||
/* Being elemental, the last upper bound of an assumed size array
|
||||
argument must be present. */
|
||||
for (arg = expr->value.function.actual; arg; arg = arg->next)
|
||||
{
|
||||
if (arg->expr != NULL
|
||||
&& arg->expr->rank > 0
|
||||
&& resolve_assumed_size_actual (arg->expr))
|
||||
return FAILURE;
|
||||
}
|
||||
}
|
||||
|
||||
else if (expr->value.function.actual != NULL
|
||||
&& expr->value.function.isym != NULL
|
||||
&& strcmp (expr->value.function.isym->name, "lbound"))
|
||||
{
|
||||
/* Array instrinsics must also have the last upper bound of an
|
||||
asumed size array argument. UBOUND and SIZE have to be
|
||||
excluded from the check if the second argument is anything
|
||||
than a constant. */
|
||||
int inquiry;
|
||||
inquiry = strcmp (expr->value.function.isym->name, "ubound") == 0
|
||||
|| strcmp (expr->value.function.isym->name, "size") == 0;
|
||||
|
||||
for (arg = expr->value.function.actual; arg; arg = arg->next)
|
||||
{
|
||||
if (inquiry && arg->next != NULL && arg->next->expr
|
||||
&& arg->next->expr->expr_type != EXPR_CONSTANT)
|
||||
break;
|
||||
|
||||
if (arg->expr != NULL
|
||||
&& arg->expr->rank > 0
|
||||
&& resolve_assumed_size_actual (arg->expr))
|
||||
return FAILURE;
|
||||
}
|
||||
}
|
||||
|
||||
need_full_assumed_size = temp;
|
||||
|
||||
if (!pure_function (expr, &name))
|
||||
{
|
||||
if (forall_flag)
|
||||
|
|
@ -1400,9 +1510,17 @@ resolve_call (gfc_code * c)
|
|||
{
|
||||
try t;
|
||||
|
||||
/* Switch off assumed size checking and do this again for certain kinds
|
||||
of procedure, once the procedure itself is resolved. */
|
||||
need_full_assumed_size++;
|
||||
|
||||
if (resolve_actual_arglist (c->ext.actual) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
/* Resume assumed_size checking. */
|
||||
need_full_assumed_size--;
|
||||
|
||||
|
||||
t = SUCCESS;
|
||||
if (c->resolved_sym == NULL)
|
||||
switch (procedure_kind (c->symtree->n.sym))
|
||||
|
|
@ -1423,6 +1541,21 @@ resolve_call (gfc_code * c)
|
|||
gfc_internal_error ("resolve_subroutine(): bad function type");
|
||||
}
|
||||
|
||||
if (c->ext.actual != NULL
|
||||
&& c->symtree->n.sym->attr.elemental)
|
||||
{
|
||||
gfc_actual_arglist * a;
|
||||
/* Being elemental, the last upper bound of an assumed size array
|
||||
argument must be present. */
|
||||
for (a = c->ext.actual; a; a = a->next)
|
||||
{
|
||||
if (a->expr != NULL
|
||||
&& a->expr->rank > 0
|
||||
&& resolve_assumed_size_actual (a->expr))
|
||||
return FAILURE;
|
||||
}
|
||||
}
|
||||
|
||||
if (t == SUCCESS)
|
||||
find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
|
||||
return t;
|
||||
|
|
@ -2349,6 +2482,9 @@ resolve_variable (gfc_expr * e)
|
|||
e->ts = sym->ts;
|
||||
}
|
||||
|
||||
if (check_assumed_size_reference (sym, e))
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -4529,7 +4529,7 @@ gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
|
|||
|
||||
/* Reverse a SS chain. */
|
||||
|
||||
static gfc_ss *
|
||||
gfc_ss *
|
||||
gfc_reverse_ss (gfc_ss * ss)
|
||||
{
|
||||
gfc_ss *next;
|
||||
|
|
@ -4555,10 +4555,9 @@ gfc_reverse_ss (gfc_ss * ss)
|
|||
/* Walk the arguments of an elemental function. */
|
||||
|
||||
gfc_ss *
|
||||
gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr,
|
||||
gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
|
||||
gfc_ss_type type)
|
||||
{
|
||||
gfc_actual_arglist *arg;
|
||||
int scalar;
|
||||
gfc_ss *head;
|
||||
gfc_ss *tail;
|
||||
|
|
@ -4567,7 +4566,7 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr,
|
|||
head = gfc_ss_terminator;
|
||||
tail = NULL;
|
||||
scalar = 1;
|
||||
for (arg = expr->value.function.actual; arg; arg = arg->next)
|
||||
for (; arg; arg = arg->next)
|
||||
{
|
||||
if (!arg->expr)
|
||||
continue;
|
||||
|
|
@ -4644,7 +4643,8 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
|
|||
/* Walk the parameters of an elemental function. For now we always pass
|
||||
by reference. */
|
||||
if (sym->attr.elemental)
|
||||
return gfc_walk_elemental_function_args (ss, expr, GFC_SS_REFERENCE);
|
||||
return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
|
||||
GFC_SS_REFERENCE);
|
||||
|
||||
/* Scalar functions are OK as these are evaluated outside the scalarization
|
||||
loop. Pass back and let the caller deal with it. */
|
||||
|
|
|
|||
|
|
@ -48,11 +48,14 @@ void gfc_trans_static_array_pointer (gfc_symbol *);
|
|||
|
||||
/* Generate scalarization information for an expression. */
|
||||
gfc_ss *gfc_walk_expr (gfc_expr *);
|
||||
/* Walk the arguments of an intrinsic function. */
|
||||
gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_expr *, gfc_ss_type);
|
||||
/* Walk the arguments of an elemental function. */
|
||||
gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_actual_arglist *,
|
||||
gfc_ss_type);
|
||||
/* Walk an intrinsic function. */
|
||||
gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *,
|
||||
gfc_intrinsic_sym *);
|
||||
/* Reverse the order of an SS chain. */
|
||||
gfc_ss *gfc_reverse_ss (gfc_ss *);
|
||||
|
||||
/* Free the SS associated with a loop. */
|
||||
void gfc_cleanup_loop (gfc_loopinfo *);
|
||||
|
|
|
|||
|
|
@ -3380,7 +3380,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
|
|||
gcc_assert (isym);
|
||||
|
||||
if (isym->elemental)
|
||||
return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR);
|
||||
return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
|
||||
|
||||
if (expr->rank == 0)
|
||||
return ss;
|
||||
|
|
|
|||
|
|
@ -209,6 +209,7 @@ tree
|
|||
gfc_trans_call (gfc_code * code)
|
||||
{
|
||||
gfc_se se;
|
||||
gfc_ss * ss;
|
||||
int has_alternate_specifier;
|
||||
|
||||
/* A CALL starts a new block because the actual arguments may have to
|
||||
|
|
@ -218,28 +219,81 @@ gfc_trans_call (gfc_code * code)
|
|||
|
||||
gcc_assert (code->resolved_sym);
|
||||
|
||||
/* Translate the call. */
|
||||
has_alternate_specifier
|
||||
= gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual);
|
||||
ss = gfc_ss_terminator;
|
||||
if (code->resolved_sym->attr.elemental)
|
||||
ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);
|
||||
|
||||
/* A subroutine without side-effect, by definition, does nothing! */
|
||||
TREE_SIDE_EFFECTS (se.expr) = 1;
|
||||
|
||||
/* Chain the pieces together and return the block. */
|
||||
if (has_alternate_specifier)
|
||||
/* Is not an elemental subroutine call with array valued arguments. */
|
||||
if (ss == gfc_ss_terminator)
|
||||
{
|
||||
gfc_code *select_code;
|
||||
gfc_symbol *sym;
|
||||
select_code = code->next;
|
||||
gcc_assert(select_code->op == EXEC_SELECT);
|
||||
sym = select_code->expr->symtree->n.sym;
|
||||
se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
|
||||
gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr);
|
||||
}
|
||||
else
|
||||
gfc_add_expr_to_block (&se.pre, se.expr);
|
||||
|
||||
gfc_add_block_to_block (&se.pre, &se.post);
|
||||
/* Translate the call. */
|
||||
has_alternate_specifier
|
||||
= gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual);
|
||||
|
||||
/* A subroutine without side-effect, by definition, does nothing! */
|
||||
TREE_SIDE_EFFECTS (se.expr) = 1;
|
||||
|
||||
/* Chain the pieces together and return the block. */
|
||||
if (has_alternate_specifier)
|
||||
{
|
||||
gfc_code *select_code;
|
||||
gfc_symbol *sym;
|
||||
select_code = code->next;
|
||||
gcc_assert(select_code->op == EXEC_SELECT);
|
||||
sym = select_code->expr->symtree->n.sym;
|
||||
se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
|
||||
gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr);
|
||||
}
|
||||
else
|
||||
gfc_add_expr_to_block (&se.pre, se.expr);
|
||||
|
||||
gfc_add_block_to_block (&se.pre, &se.post);
|
||||
}
|
||||
|
||||
else
|
||||
{
|
||||
/* An elemental subroutine call with array valued arguments has
|
||||
to be scalarized. */
|
||||
gfc_loopinfo loop;
|
||||
stmtblock_t body;
|
||||
stmtblock_t block;
|
||||
gfc_se loopse;
|
||||
|
||||
/* gfc_walk_elemental_function_args renders the ss chain in the
|
||||
reverse order to the actual argument order. */
|
||||
ss = gfc_reverse_ss (ss);
|
||||
|
||||
/* Initialize the loop. */
|
||||
gfc_init_se (&loopse, NULL);
|
||||
gfc_init_loopinfo (&loop);
|
||||
gfc_add_ss_to_loop (&loop, ss);
|
||||
|
||||
gfc_conv_ss_startstride (&loop);
|
||||
gfc_conv_loop_setup (&loop);
|
||||
gfc_mark_ss_chain_used (ss, 1);
|
||||
|
||||
/* 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);
|
||||
gfc_add_expr_to_block (&loopse.pre, loopse.expr);
|
||||
|
||||
gfc_add_block_to_block (&block, &loopse.pre);
|
||||
gfc_add_block_to_block (&block, &loopse.post);
|
||||
|
||||
/* Finish up the loop block and the loop. */
|
||||
gfc_add_expr_to_block (&body, gfc_finish_block (&block));
|
||||
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_cleanup_loop (&loop);
|
||||
}
|
||||
|
||||
return gfc_finish_block (&se.pre);
|
||||
}
|
||||
|
||||
|
|
@ -2501,6 +2555,14 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
|
|||
gfc_add_expr_to_block (&block, tmp);
|
||||
break;
|
||||
|
||||
/* Explicit subroutine calls are prevented by the frontend but interface
|
||||
assignments can legitimately produce them. */
|
||||
case EXEC_CALL:
|
||||
assign = gfc_trans_call (c);
|
||||
tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
break;
|
||||
|
||||
default:
|
||||
gcc_unreachable ();
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,3 +1,18 @@
|
|||
2006-01-07 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/22146
|
||||
* gfortran.dg/elemental_subroutine_1.f90: New test.
|
||||
* gfortran.dg/elemental_subroutine_2.f90: New test.
|
||||
|
||||
PR fortran/25029
|
||||
PR fortran/21256
|
||||
* gfortran.dg/assumed_size_refs_1.f90: New test.
|
||||
|
||||
PR fortran/20868
|
||||
PR fortran/20870
|
||||
* gfortran.dg/assumed_size_refs_2.f90: New test.
|
||||
* gfortran.dg/initialization_1.f90: Change warning message.
|
||||
|
||||
2005-01-06 Zdenek Dvorak <dvorakz@suse.cz>
|
||||
|
||||
* gcc.dg/tree-ssa/loop-15.c: New test.
|
||||
|
|
|
|||
64
gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90
Executable file
64
gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90
Executable file
|
|
@ -0,0 +1,64 @@
|
|||
!==================assumed_size_refs_1.f90==================
|
||||
! { dg-do compile }
|
||||
! Test the fix for PR25029, PR21256 in which references to
|
||||
! assumed size arrays without an upper bound to the last
|
||||
! dimension were generating no error. The first version of
|
||||
! the patch failed in DHSEQR, as pointed out by Toon Moene
|
||||
! in http://gcc.gnu.org/ml/fortran/2005-12/msg00466.html
|
||||
!
|
||||
! Contributed by Paul Thomas <pault@gcc.gnu.org>
|
||||
!
|
||||
program assumed_size_test_1
|
||||
implicit none
|
||||
real a(2, 4)
|
||||
|
||||
a = 1.0
|
||||
call foo (a)
|
||||
|
||||
contains
|
||||
subroutine foo(m)
|
||||
real, target :: m(1:2, *)
|
||||
real x(2,2,2)
|
||||
real, external :: bar
|
||||
real, pointer :: p(:,:), q(:,:)
|
||||
allocate (q(2,2))
|
||||
|
||||
! PR25029
|
||||
p => m ! { dg-error "upper bound in the last dimension" }
|
||||
q = m ! { dg-error "upper bound in the last dimension" }
|
||||
|
||||
! PR21256( and PR25060)
|
||||
m = 1 ! { dg-error "upper bound in the last dimension" }
|
||||
|
||||
m(1,1) = 2.0
|
||||
x = bar (m)
|
||||
x = fcn (m) ! { dg-error "upper bound in the last dimension" }
|
||||
m(:, 1:2) = fcn (q)
|
||||
call sub (m, x) ! { dg-error "upper bound in the last dimension" }
|
||||
call sub (m(1:2, 1:2), x)
|
||||
print *, p
|
||||
|
||||
call DHSEQR(x)
|
||||
|
||||
end subroutine foo
|
||||
|
||||
elemental function fcn (a) result (b)
|
||||
real, intent(in) :: a
|
||||
real :: b
|
||||
b = 2.0 * a
|
||||
end function fcn
|
||||
|
||||
elemental subroutine sub (a, b)
|
||||
real, intent(inout) :: a, b
|
||||
b = 2.0 * a
|
||||
end subroutine sub
|
||||
|
||||
SUBROUTINE DHSEQR( WORK )
|
||||
REAL WORK( * )
|
||||
EXTERNAL DLARFX
|
||||
INTRINSIC MIN
|
||||
WORK( 1 ) = 1.0
|
||||
CALL DLARFX( MIN( 1, 8 ), WORK )
|
||||
END SUBROUTINE DHSEQR
|
||||
|
||||
end program assumed_size_test_1
|
||||
44
gcc/testsuite/gfortran.dg/assumed_size_refs_2.f90
Executable file
44
gcc/testsuite/gfortran.dg/assumed_size_refs_2.f90
Executable file
|
|
@ -0,0 +1,44 @@
|
|||
!==================assumed_size_refs_1.f90==================
|
||||
! { dg-do compile }
|
||||
! Test the fix for PR20868 & PR20870 in which references to
|
||||
! assumed size arrays without an upper bound to the last
|
||||
! dimension were generating no error.
|
||||
!
|
||||
! Contributed by Paul Thomas <pault@gcc.gnu.org>
|
||||
!
|
||||
program assumed_size_test_2
|
||||
implicit none
|
||||
real a(2, 4)
|
||||
|
||||
a = 1.0
|
||||
call foo (a)
|
||||
|
||||
contains
|
||||
subroutine foo(m)
|
||||
real, target :: m(1:2, *)
|
||||
real x(2,2,2)
|
||||
real, pointer :: q(:,:)
|
||||
integer :: i
|
||||
allocate (q(2,2))
|
||||
|
||||
q = cos (1.0 + abs(m)) ! { dg-error "upper bound in the last dimension" }
|
||||
|
||||
x = reshape (m, (/2,2,2/)) ! { dg-error "upper bound in the last dimension" }
|
||||
|
||||
! PR20868
|
||||
print *, ubound (m) ! { dg-error "upper bound in the last dimension" }
|
||||
print *, lbound (m)
|
||||
|
||||
! PR20870
|
||||
print *, size (m) ! { dg-error "upper bound in the last dimension" }
|
||||
|
||||
! Check non-array valued intrinsics
|
||||
print *, ubound (m, 1)
|
||||
print *, ubound (m, 2) ! { dg-error "not a valid dimension index" }
|
||||
|
||||
i = 2
|
||||
print *, size (m, i)
|
||||
|
||||
end subroutine foo
|
||||
|
||||
end program assumed_size_test_2
|
||||
58
gcc/testsuite/gfortran.dg/elemental_subroutine_1.f90
Normal file
58
gcc/testsuite/gfortran.dg/elemental_subroutine_1.f90
Normal file
|
|
@ -0,0 +1,58 @@
|
|||
! { dg-do run }
|
||||
! Test the fix for pr22146, where and elemental subroutine with
|
||||
! array actual arguments would cause an ICE in gfc_conv_function_call.
|
||||
! The module is the original test case and the rest is a basic
|
||||
! functional test of the scalarization of the function call.
|
||||
!
|
||||
! Contributed by Erik Edelmann <erik.edelmann@iki.fi>
|
||||
! and Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
module pr22146
|
||||
|
||||
contains
|
||||
|
||||
elemental subroutine foo(a)
|
||||
integer, intent(out) :: a
|
||||
a = 0
|
||||
end subroutine foo
|
||||
|
||||
subroutine bar()
|
||||
integer :: a(10)
|
||||
call foo(a)
|
||||
end subroutine bar
|
||||
|
||||
end module pr22146
|
||||
|
||||
use pr22146
|
||||
real, dimension (2) :: x, y
|
||||
real :: u, v
|
||||
x = (/1.0, 2.0/)
|
||||
u = 42.0
|
||||
|
||||
call bar ()
|
||||
|
||||
! Check the various combinations of scalar and array.
|
||||
call foobar (x, y)
|
||||
if (any(y.ne.-x)) call abort ()
|
||||
|
||||
call foobar (u, y)
|
||||
if (any(y.ne.-42.0)) call abort ()
|
||||
|
||||
call foobar (u, v)
|
||||
if (v.ne.-42.0) call abort ()
|
||||
|
||||
call foobar (x, v)
|
||||
if (v.ne.-2.0) call abort ()
|
||||
|
||||
! Test an expression in the INTENT(IN) argument
|
||||
call foobar (cos (x) + u, y)
|
||||
if (any(abs (y + cos (x) + u) .gt. 2.0e-6)) call abort ()
|
||||
|
||||
contains
|
||||
|
||||
elemental subroutine foobar (a, b)
|
||||
real, intent(IN) :: a
|
||||
real, intent(out) :: b
|
||||
b = -a
|
||||
end subroutine foobar
|
||||
end
|
||||
64
gcc/testsuite/gfortran.dg/elemental_subroutine_2.f90
Normal file
64
gcc/testsuite/gfortran.dg/elemental_subroutine_2.f90
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
! { dg-do run }
|
||||
! Test the fix for pr22146, where and elemental subroutine with
|
||||
! array actual arguments would cause an ICE in gfc_conv_function_call.
|
||||
! This test checks that the main uses for elemental subroutines work
|
||||
! correctly; namely, as module procedures and as procedures called
|
||||
! from elemental functions. The compiler would ICE on the former with
|
||||
! the first version of the patch.
|
||||
!
|
||||
! Contributed by Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
module type
|
||||
type itype
|
||||
integer :: i
|
||||
character(1) :: ch
|
||||
end type itype
|
||||
end module type
|
||||
|
||||
module assign
|
||||
interface assignment (=)
|
||||
module procedure itype_to_int
|
||||
end interface
|
||||
contains
|
||||
elemental subroutine itype_to_int (i, it)
|
||||
use type
|
||||
type(itype), intent(in) :: it
|
||||
integer, intent(out) :: i
|
||||
i = it%i
|
||||
end subroutine itype_to_int
|
||||
|
||||
elemental function i_from_itype (it) result (i)
|
||||
use type
|
||||
type(itype), intent(in) :: it
|
||||
integer :: i
|
||||
i = it
|
||||
end function i_from_itype
|
||||
|
||||
end module assign
|
||||
|
||||
program test_assign
|
||||
use type
|
||||
use assign
|
||||
type(itype) :: x(2, 2)
|
||||
integer :: i(2, 2)
|
||||
|
||||
! Test an elemental subroutine call from an elementary function.
|
||||
x = reshape ((/(itype (j, "a"), j = 1,4)/), (/2,2/))
|
||||
forall (j = 1:2, k = 1:2)
|
||||
i(j, k) = i_from_itype (x (j, k))
|
||||
end forall
|
||||
if (any(reshape (i, (/4/)).ne.(/1,2,3,4/))) call abort ()
|
||||
|
||||
! Check the interface assignment (not part of the patch).
|
||||
x = reshape ((/(itype (j**2, "b"), j = 1,4)/), (/2,2/))
|
||||
i = x
|
||||
if (any(reshape (i, (/4/)).ne.(/1,4,9,16/))) call abort ()
|
||||
|
||||
! Use the interface assignment within a forall block.
|
||||
x = reshape ((/(itype (j**3, "c"), j = 1,4)/), (/2,2/))
|
||||
forall (j = 1:2, k = 1:2)
|
||||
i(j, k) = x (j, k)
|
||||
end forall
|
||||
if (any(reshape (i, (/4/)).ne.(/1,8,27,64/))) call abort ()
|
||||
|
||||
end program test_assign
|
||||
|
|
@ -26,7 +26,7 @@ contains
|
|||
integer :: l1 = len (ch1) ! { dg-warning "assumed character length variable" }
|
||||
|
||||
! These are warnings because they are gfortran extensions.
|
||||
integer :: m3 = size (x, 1) ! { dg-warning "Evaluation of nonstandard initialization" }
|
||||
integer :: m3 = size (x, 1) ! { dg-warning "upper bound in the last dimension" }
|
||||
integer :: m4(2) = shape (z) ! { dg-warning "Evaluation of nonstandard initialization" }
|
||||
|
||||
! This does not depend on non-constant properties.
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue