+2009-05-10 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/38863
+ * trans-expr.c (gfc_conv_operator_assign): Remove function.
+ * trans.h : Remove prototype for gfc_conv_operator_assign.
+ * trans-stmt.c (gfc_conv_elemental_dependencies): Initialize
+ derivde types with intent(out).
+ (gfc_trans_call): Add mask, count1 and invert arguments. Add
+ code to use mask for WHERE assignments.
+ (gfc_trans_forall_1): Use new arguments for gfc_trans_call.
+ (gfc_trans_where_assign): The gfc_symbol argument is replaced
+ by the corresponding code. If this has a resolved_sym, then
+ gfc_trans_call is called. The call to gfc_conv_operator_assign
+ is removed.
+ (gfc_trans_where_2): Change the last argument in the call to
+ gfc_trans_where_assign.
+ * trans-stmt.h : Modify prototype for gfc_trans_call.
+ * trans.c (gfc_trans_code): Use new args for gfc_trans_call.
+
2009-05-08 Janus Weil <janus@gcc.gnu.org>
PR fortran/39876
}
-/* Translate the call for an elemental subroutine call used in an operator
- assignment. This is a simplified version of gfc_conv_procedure_call. */
-
-tree
-gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
-{
- tree args;
- tree tmp;
- gfc_se se;
- stmtblock_t block;
-
- /* Only elemental subroutines with two arguments. */
- gcc_assert (sym->attr.elemental && sym->attr.subroutine);
- gcc_assert (sym->formal->next->next == NULL);
-
- gfc_init_block (&block);
-
- gfc_add_block_to_block (&block, &lse->pre);
- gfc_add_block_to_block (&block, &rse->pre);
-
- /* Build the argument list for the call, including hidden string lengths. */
- args = gfc_chainon_list (NULL_TREE, gfc_build_addr_expr (NULL_TREE, lse->expr));
- args = gfc_chainon_list (args, gfc_build_addr_expr (NULL_TREE, rse->expr));
- if (lse->string_length != NULL_TREE)
- args = gfc_chainon_list (args, lse->string_length);
- if (rse->string_length != NULL_TREE)
- args = gfc_chainon_list (args, rse->string_length);
-
- /* Build the function call. */
- gfc_init_se (&se, NULL);
- conv_function_val (&se, sym, NULL);
- tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
- tmp = build_call_list (tmp, se.expr, args);
- gfc_add_expr_to_block (&block, tmp);
-
- gfc_add_block_to_block (&block, &lse->post);
- gfc_add_block_to_block (&block, &rse->post);
-
- return gfc_finish_block (&block);
-}
-
-
/* Initialize MAPPING. */
void
gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
gfc_add_block_to_block (&se->pre, &parmse.pre);
- /* If we've got INTENT(INOUT), initialize the array temporary with
- a copy of the values. */
- if (fsym->attr.intent == INTENT_INOUT)
+ /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
+ initialize the array temporary with a copy of the values. */
+ if (fsym->attr.intent == INTENT_INOUT
+ || (fsym->ts.type ==BT_DERIVED
+ && fsym->attr.intent == INTENT_OUT))
initial = parmse.expr;
else
initial = NULL_TREE;
/* Translate the CALL statement. Builds a call to an F95 subroutine. */
tree
-gfc_trans_call (gfc_code * code, bool dependency_check)
+gfc_trans_call (gfc_code * code, bool dependency_check,
+ tree mask, tree count1, bool invert)
{
gfc_se se;
gfc_ss * ss;
int has_alternate_specifier;
gfc_dep_check check_variable;
+ tree index = NULL_TREE;
+ tree maskexpr = NULL_TREE;
+ tree tmp;
/* A CALL starts a new block because the actual arguments may have to
be evaluated first. */
gfc_start_scalarized_body (&loop, &body);
gfc_init_block (&block);
+ if (mask && count1)
+ {
+ /* Form the mask expression according to the mask. */
+ index = count1;
+ maskexpr = gfc_build_array_ref (mask, index, NULL);
+ if (invert)
+ maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr),
+ maskexpr);
+ }
+
/* Add the subroutine call to the block. */
- gfc_conv_procedure_call (&loopse, code->resolved_sym, code->ext.actual,
- code->expr, NULL_TREE);
- gfc_add_expr_to_block (&loopse.pre, loopse.expr);
+ gfc_conv_procedure_call (&loopse, code->resolved_sym,
+ code->ext.actual, code->expr,
+ NULL_TREE);
+
+ if (mask && count1)
+ {
+ tmp = build3_v (COND_EXPR, maskexpr, loopse.expr,
+ build_empty_stmt ());
+ gfc_add_expr_to_block (&loopse.pre, tmp);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ count1, gfc_index_one_node);
+ gfc_add_modify (&loopse.pre, count1, tmp);
+ }
+ else
+ 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);
/* Explicit subroutine calls are prevented by the frontend but interface
assignments can legitimately produce them. */
case EXEC_ASSIGN_CALL:
- assign = gfc_trans_call (c, true);
+ assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false);
tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
gfc_add_expr_to_block (&block, tmp);
break;
gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
tree mask, bool invert,
tree count1, tree count2,
- gfc_symbol *sym)
+ gfc_code *cnext)
{
gfc_se lse;
gfc_se rse;
stmtblock_t body;
tree index, maskexpr;
+ /* A defined assignment. */
+ if (cnext && cnext->resolved_sym)
+ return gfc_trans_call (cnext, true, mask, count1, invert);
+
#if 0
/* TODO: handle this special case.
Special case a single function returning an array. */
maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
/* Use the scalar assignment as is. */
- if (sym == NULL)
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
- loop.temp_ss != NULL, false);
- else
- tmp = gfc_conv_operator_assign (&lse, &rse, sym);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+ loop.temp_ss != NULL, false);
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
count1, count2,
- cnext->resolved_sym);
+ cnext);
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
tmp, 1);
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
count1, count2,
- cnext->resolved_sym);
+ cnext);
gfc_add_expr_to_block (block, tmp);
}
tree gfc_trans_entry (gfc_code *);
tree gfc_trans_pause (gfc_code *);
tree gfc_trans_stop (gfc_code *);
-tree gfc_trans_call (gfc_code *, bool);
+tree gfc_trans_call (gfc_code *, bool, tree, tree, bool);
tree gfc_trans_return (gfc_code *);
tree gfc_trans_if (gfc_code *);
tree gfc_trans_arithmetic_if (gfc_code *);
if (code->resolved_isym
&& code->resolved_isym->id == GFC_ISYM_MVBITS)
is_mvbits = true;
- res = gfc_trans_call (code, is_mvbits);
+ res = gfc_trans_call (code, is_mvbits, NULL_TREE,
+ NULL_TREE, false);
}
break;
case EXEC_CALL_PPC:
- res = gfc_trans_call (code, false);
+ res = gfc_trans_call (code, false, NULL_TREE,
+ NULL_TREE, false);
break;
case EXEC_ASSIGN_CALL:
- res = gfc_trans_call (code, true);
+ res = gfc_trans_call (code, true, NULL_TREE,
+ NULL_TREE, false);
break;
case EXEC_RETURN:
/* Does an intrinsic map directly to an external library call. */
int gfc_is_intrinsic_libcall (gfc_expr *);
-/* Used to call the elemental subroutines used in operator assignments. */
-tree gfc_conv_operator_assign (gfc_se *, gfc_se *, gfc_symbol *);
-
/* Used to call ordinary functions/subroutines
and procedure pointer components. */
int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
-2009-04-10 David Billinghurst <billingd@gcc.gnu.org>
+2009-05-10 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/38863
+ * gfortran.dg/dependency_24.f90: New test.
+ * gfortran.dg/dependency_23.f90: Clean up module files.
+
+2009-05-10 David Billinghurst <billingd@gcc.gnu.org>
PR fortran/38956
* gfortran.dg/chmod_1.f90: Don't run on *-*-cygwin*.
use rg0045_stuff
call rg0045(1, 2, 3)
end
+! { dg-final { cleanup-modules "rg0045_stuff" } }
--- /dev/null
+***************
+*** 52,56 ****
+ use rg0045_stuff
+ call rg0045(1, 2, 3)
+ end
+
+
+--- 52,57 ----
+ use rg0045_stuff
+ call rg0045(1, 2, 3)
+ end
++ ! { dg-final { cleanup-modules "rg0045_stuff" } }
+
+
--- /dev/null
+! { dg-do run }
+! Check the fix for PR38863 comment #1, where defined assignment
+! to derived types was not treating components correctly that were
+! not set explicitly.
+!
+! Contributed by Mikael Morin <mikael@gcc.gnu.org>
+!
+module m
+ type t
+ integer :: i,j
+ end type t
+ type ti
+ integer :: i,j = 99
+ end type ti
+ interface assignment (=)
+ module procedure i_to_t, i_to_ti
+ end interface
+contains
+ elemental subroutine i_to_ti (p, q)
+ type(ti), intent(out) :: p
+ integer, intent(in) :: q
+ p%i = q
+ end subroutine
+ elemental subroutine i_to_t (p, q)
+ type(t), intent(out) :: p
+ integer, intent(in) :: q
+ p%i = q
+ end subroutine
+end module
+
+ use m
+ call test_t ! Check original problem
+ call test_ti ! Default initializers were treated wrongly
+contains
+ subroutine test_t
+ type(t), target :: a(3)
+ type(t), target :: b(3)
+ type(t), dimension(:), pointer :: p
+ logical :: l(3)
+
+ a%i = 1
+ a%j = [101, 102, 103]
+ b%i = 3
+ b%j = 4
+
+ p => b
+ l = .true.
+
+ where (l)
+ a = p%i ! Comment #1 of PR38863 concerned WHERE assignment
+ end where
+ if (any (a%j .ne. [101, 102, 103])) call abort
+
+ a = p%i ! Ordinary assignment was wrong too.
+ if (any (a%j .ne. [101, 102, 103])) call abort
+ end subroutine
+
+ subroutine test_ti
+ type(ti), target :: a(3)
+ type(ti), target :: b(3)
+ type(ti), dimension(:), pointer :: p
+ logical :: l(3)
+
+ a%i = 1
+ a%j = [101, 102, 103]
+ b%i = 3
+ b%j = 4
+
+ p => b
+ l = .true.
+
+ where (l)
+ a = p%i
+ end where
+ if (any (a%j .ne. 99)) call abort
+
+ a = p%i
+ if (any (a%j .ne. 99)) call abort
+ end subroutine
+end
+! { dg-final { cleanup-modules "m" } }
projects / platform / upstream / gcc.git / commitdiff