diff options
| -rw-r--r-- | MAINTAINERS | 1 | ||||
| -rw-r--r-- | gcc/fortran/ChangeLog | 29 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 138 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 10 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.h | 7 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 96 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 15 | ||||
| -rwxr-xr-x | gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90 | 64 | ||||
| -rwxr-xr-x | gcc/testsuite/gfortran.dg/assumed_size_refs_2.f90 | 44 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/elemental_subroutine_1.f90 | 58 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/elemental_subroutine_2.f90 | 64 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/initialization_1.f90 | 2 |
13 files changed, 503 insertions, 27 deletions
diff --git a/MAINTAINERS b/MAINTAINERS index 7ba223635b0..9d51fdd4ee4 100644 --- a/MAINTAINERS +++ b/MAINTAINERS @@ -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 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 81790d88e81..ea086409fe8 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2e870bbc968..5e64bf7ff0d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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; } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index e943d8ec103..68bed0a18b3 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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. */ diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 8ceced9f9e3..564e6490a26 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -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 *); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index e3f4bdf6cdf..699a2947e93 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 1b56cf478de..cf88918b586 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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); + + /* 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 - gfc_add_expr_to_block (&se.pre, se.expr); + { + /* 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); + } - gfc_add_block_to_block (&se.pre, &se.post); 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 (); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ca893730e66..7a0e309a6b7 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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. diff --git a/gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90 b/gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90 new file mode 100755 index 00000000000..ff42c02a623 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/assumed_size_refs_2.f90 b/gcc/testsuite/gfortran.dg/assumed_size_refs_2.f90 new file mode 100755 index 00000000000..8eb708d4989 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_size_refs_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/elemental_subroutine_1.f90 b/gcc/testsuite/gfortran.dg/elemental_subroutine_1.f90 new file mode 100644 index 00000000000..450dd059e09 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/elemental_subroutine_1.f90 @@ -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
\ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/elemental_subroutine_2.f90 b/gcc/testsuite/gfortran.dg/elemental_subroutine_2.f90 new file mode 100644 index 00000000000..5683de89d37 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/elemental_subroutine_2.f90 @@ -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
\ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/initialization_1.f90 b/gcc/testsuite/gfortran.dg/initialization_1.f90 index 479348e7e9c..e845472043d 100644 --- a/gcc/testsuite/gfortran.dg/initialization_1.f90 +++ b/gcc/testsuite/gfortran.dg/initialization_1.f90 @@ -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. |