diff options
author | Paul Thomas <pault@gcc.gnu.org> | 2006-03-01 22:24:19 +0000 |
---|---|---|
committer | Paul Thomas <pault@gcc.gnu.org> | 2006-03-01 22:24:19 +0000 |
commit | 61321991ff5f055015750ddf36444705b9921464 (patch) | |
tree | 1fb7018901bd09ec73d55b0ccf66775cd2947e62 /gcc/fortran/trans-intrinsic.c | |
parent | 8acb1b3d1c6369349372f74e815db2375ea8e0c5 (diff) | |
download | gcc-61321991ff5f055015750ddf36444705b9921464.zip gcc-61321991ff5f055015750ddf36444705b9921464.tar.gz gcc-61321991ff5f055015750ddf36444705b9921464.tar.bz2 |
re PR fortran/26393 (ICE with function returning variable lenght array)
2006-03-01 Paul Thomas <pault@gcc.gnu.org>
* iresolve.c (gfc_resolve_dot_product): Remove any difference in
treatment of logical types.
* trans-intrinsic.c (gfc_conv_intrinsic_dot_product): New function.
PR fortran/26393
* trans-decl.c (gfc_get_symbol_decl): Extend condition that symbols
must be referenced to include unreferenced symbols in an interface
body.
PR fortran/20938
* trans-array.c (gfc_conv_resolve_dependencies): Add call to
gfc_are_equivalenced_arrays.
* symbol.c (gfc_free_equiv_infos, gfc_free_equiv_lists): New
functions. (gfc_free_namespace): Call them.
* trans-common.c (copy_equiv_list_to_ns): New function.
(add_equivalences): Call it.
* gfortran.h: Add equiv_lists to gfc_namespace and define
gfc_equiv_list and gfc_equiv_info.
* dependency.c (gfc_are_equivalenced_arrays): New function.
(gfc_check_dependency): Call it.
* dependency.h: Prototype for gfc_are_equivalenced_arrays.
2006-03-01 Paul Thomas <pault@gcc.gnu.org>
* gfortran.dg/logical_dot_product.f90: New test.
PR fortran/26393
* gfortran.dg/used_interface_ref.f90: New test.
PR fortran/20938
* gfortran.dg/dependency_2.f90: New test.
* gfortran.fortran-torture/execute/where17.f90: New test.
* gfortran.fortran-torture/execute/where18.f90: New test.
* gfortran.fortran-torture/execute/where19.f90: New test.
* gfortran.fortran-torture/execute/where20.f90: New test.
From-SVN: r111616
Diffstat (limited to 'gcc/fortran/trans-intrinsic.c')
-rw-r--r-- | gcc/fortran/trans-intrinsic.c | 103 |
1 files changed, 102 insertions, 1 deletions
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index f58a596..39ac939 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1561,6 +1561,104 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op) se->expr = resvar; } + +/* Inline implementation of the dot_product intrinsic. This function + is based on gfc_conv_intrinsic_arith (the previous function). */ +static void +gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr) +{ + tree resvar; + tree type; + stmtblock_t body; + stmtblock_t block; + tree tmp; + gfc_loopinfo loop; + gfc_actual_arglist *actual; + gfc_ss *arrayss1, *arrayss2; + gfc_se arrayse1, arrayse2; + gfc_expr *arrayexpr1, *arrayexpr2; + + type = gfc_typenode_for_spec (&expr->ts); + + /* Initialize the result. */ + resvar = gfc_create_var (type, "val"); + if (expr->ts.type == BT_LOGICAL) + tmp = convert (type, integer_zero_node); + else + tmp = gfc_build_const (type, integer_zero_node); + + gfc_add_modify_expr (&se->pre, resvar, tmp); + + /* Walk argument #1. */ + actual = expr->value.function.actual; + arrayexpr1 = actual->expr; + arrayss1 = gfc_walk_expr (arrayexpr1); + gcc_assert (arrayss1 != gfc_ss_terminator); + + /* Walk argument #2. */ + actual = actual->next; + arrayexpr2 = actual->expr; + arrayss2 = gfc_walk_expr (arrayexpr2); + gcc_assert (arrayss2 != gfc_ss_terminator); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, arrayss1); + gfc_add_ss_to_loop (&loop, arrayss2); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop); + + gfc_mark_ss_chain_used (arrayss1, 1); + gfc_mark_ss_chain_used (arrayss2, 1); + + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + gfc_init_block (&block); + + /* Make the tree expression for [conjg(]array1[)]. */ + gfc_init_se (&arrayse1, NULL); + gfc_copy_loopinfo_to_se (&arrayse1, &loop); + arrayse1.ss = arrayss1; + gfc_conv_expr_val (&arrayse1, arrayexpr1); + if (expr->ts.type == BT_COMPLEX) + arrayse1.expr = build1 (CONJ_EXPR, type, arrayse1.expr); + gfc_add_block_to_block (&block, &arrayse1.pre); + + /* Make the tree expression for array2. */ + gfc_init_se (&arrayse2, NULL); + gfc_copy_loopinfo_to_se (&arrayse2, &loop); + arrayse2.ss = arrayss2; + gfc_conv_expr_val (&arrayse2, arrayexpr2); + gfc_add_block_to_block (&block, &arrayse2.pre); + + /* Do the actual product and sum. */ + if (expr->ts.type == BT_LOGICAL) + { + tmp = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr); + tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp); + } + else + { + tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr); + tmp = build2 (PLUS_EXPR, type, resvar, tmp); + } + gfc_add_modify_expr (&block, resvar, tmp); + + /* Finish up the loop block and the loop. */ + tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&body, tmp); + + 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); + + se->expr = resvar; +} + + static void gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) { @@ -3135,6 +3233,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_dim (se, expr); break; + case GFC_ISYM_DOT_PRODUCT: + gfc_conv_intrinsic_dot_product (se, expr); + break; + case GFC_ISYM_DPROD: gfc_conv_intrinsic_dprod (se, expr); break; @@ -3304,7 +3406,6 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_CHDIR: - case GFC_ISYM_DOT_PRODUCT: case GFC_ISYM_ETIME: case GFC_ISYM_FGET: case GFC_ISYM_FGETC: |