fortran 95 Bud Davis jmdavis@link.com
fortran 95 Steve Kargl sgk@troutmask.apl.washington.edu
fortran 95 Erik Edelmann erik.edelmann@iki.fi
+fortran 95 Paul Thomas pault@gcc.gnu.org
+fortran 95 Tobias Schlüter tobias.schlueter@physik.uni-muenchen.de
c++ Jason Merrill jason@redhat.com
c++ Mark Mitchell mark@codesourcery.com
c++ Nathan Sidwell nathan@codesourcery.com
Douglas Rupp rupp@gnat.com
Matthew Sachs msachs@apple.com
Alex Samuel samuel@codesourcery.com
-Tobias Schlüter tobias.schlueter@physik.uni-muenchen.de
Svein Seldal svein@dev.seldal.com
Thiemo Seufer ths@networkno.de
Franz Sirl franz.sirl-kernel@lauterbach.com
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
+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 Roger Sayle <roger@eyesopen.com>
* dependency.c (gfc_is_same_range): Compare the stride, lower and
}
+/* Return 1 if e1 and e2 are equivalenced arrays, either
+ directly or indirectly; ie. equivalence (a,b) for a and b
+ or equivalence (a,c),(b,c). This function uses the equiv_
+ lists, generated in trans-common(add_equivalences), that are
+ guaranteed to pick up indirect equivalences. A rudimentary
+ use is made of the offset to ensure that cases where the
+ source elements are moved down to the destination are not
+ identified as dependencies. */
+
+int
+gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
+{
+ gfc_equiv_list *l;
+ gfc_equiv_info *s, *fl1, *fl2;
+
+ gcc_assert (e1->expr_type == EXPR_VARIABLE
+ && e2->expr_type == EXPR_VARIABLE);
+
+ if (!e1->symtree->n.sym->attr.in_equivalence
+ || !e2->symtree->n.sym->attr.in_equivalence
+ || !e1->rank
+ || !e2->rank)
+ return 0;
+
+ /* Go through the equiv_lists and return 1 if the variables
+ e1 and e2 are members of the same group and satisfy the
+ requirement on their relative offsets. */
+ for (l = gfc_current_ns->equiv_lists; l; l = l->next)
+ {
+ fl1 = NULL;
+ fl2 = NULL;
+ for (s = l->equiv; s; s = s->next)
+ {
+ if (s->sym == e1->symtree->n.sym)
+ fl1 = s;
+ if (s->sym == e2->symtree->n.sym)
+ fl2 = s;
+ if (fl1 && fl2 && (fl1->offset > fl2->offset))
+ return 1;
+ }
+ }
+return 0;
+}
+
+
/* Return true if the statement body redefines the condition. Returns
true if expr2 depends on expr1. expr1 should be a single term
suitable for the lhs of an assignment. The IDENTICAL flag indicates
return 1;
}
+ /* Return 1 if expr1 and expr2 are equivalenced arrays. */
+ if (gfc_are_equivalenced_arrays (expr1, expr2))
+ return 1;
+
if (expr1->symtree->n.sym != expr2->symtree->n.sym)
return 0;
int gfc_expr_is_one (gfc_expr *, int);
int gfc_dep_resolver(gfc_ref *, gfc_ref *);
+int gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *);
/* Points to the equivalences set up in this namespace. */
struct gfc_equiv *equiv;
+
+ /* Points to the equivalence groups produced by trans_common. */
+ struct gfc_equiv_list *equiv_lists;
+
gfc_interface *operator[GFC_INTRINSIC_OPS];
/* Points to the parent namespace, i.e. the namespace of a module or
#define gfc_get_equiv() gfc_getmem(sizeof(gfc_equiv))
+/* Holds a single equivalence member after processing. */
+typedef struct gfc_equiv_info
+{
+ gfc_symbol *sym;
+ HOST_WIDE_INT offset;
+ struct gfc_equiv_info *next;
+} gfc_equiv_info;
+
+/* Holds equivalence groups, after they have been processed. */
+typedef struct gfc_equiv_list
+{
+ gfc_equiv_info *equiv;
+ struct gfc_equiv_list *next;
+} gfc_equiv_list;
/* gfc_case stores the selector list of a case statement. The *low
and *high pointers can point to the same expression in the case of
{
gfc_expr temp;
- if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
- {
- f->ts.type = BT_LOGICAL;
- f->ts.kind = gfc_default_logical_kind;
- }
- else
- {
- temp.expr_type = EXPR_OP;
- gfc_clear_ts (&temp.ts);
- temp.value.op.operator = INTRINSIC_NONE;
- temp.value.op.op1 = a;
- temp.value.op.op2 = b;
- gfc_type_convert_binary (&temp);
- f->ts = temp.ts;
- }
+ temp.expr_type = EXPR_OP;
+ gfc_clear_ts (&temp.ts);
+ temp.value.op.operator = INTRINSIC_NONE;
+ temp.value.op.op1 = a;
+ temp.value.op.op2 = b;
+ gfc_type_convert_binary (&temp);
+ f->ts = temp.ts;
f->value.function.name =
gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
}
+/* Free the gfc_equiv_info's. */
+
+static void
+gfc_free_equiv_infos (gfc_equiv_info * s)
+{
+ if (s == NULL)
+ return;
+ gfc_free_equiv_infos (s->next);
+ gfc_free (s);
+}
+
+
+/* Free the gfc_equiv_lists. */
+
+static void
+gfc_free_equiv_lists (gfc_equiv_list * l)
+{
+ if (l == NULL)
+ return;
+ gfc_free_equiv_lists (l->next);
+ gfc_free_equiv_infos (l->equiv);
+ gfc_free (l);
+}
+
+
/* Free a namespace structure and everything below it. Interface
lists associated with intrinsic operators are not freed. These are
taken care of when a specific name is freed. */
free_st_labels (ns->st_labels);
gfc_free_equiv (ns->equiv);
+ gfc_free_equiv_lists (ns->equiv_lists);
gfc_free_dt_list (ns->derived_types);
if (ss->type != GFC_SS_SECTION)
continue;
- if (gfc_could_be_alias (dest, ss))
+ if (gfc_could_be_alias (dest, ss)
+ || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
{
nDepend = 1;
break;
static segment_info * current_segment;
static gfc_namespace *gfc_common_ns = NULL;
+
/* Make a segment_info based on a symbol. */
static segment_info *
return s;
}
+
+/* Add a copy of a segment list to the namespace. This is specifically for
+ equivalence segments, so that dependency checking can be done on
+ equivalence group members. */
+
+static void
+copy_equiv_list_to_ns (segment_info *c)
+{
+ segment_info *f;
+ gfc_equiv_info *s;
+ gfc_equiv_list *l;
+
+ l = (gfc_equiv_list *) gfc_getmem (sizeof (gfc_equiv_list));
+
+ l->next = c->sym->ns->equiv_lists;
+ c->sym->ns->equiv_lists = l;
+
+ for (f = c; f; f = f->next)
+ {
+ s = (gfc_equiv_info *) gfc_getmem (sizeof (gfc_equiv_info));
+ s->next = l->equiv;
+ l->equiv = s;
+ s->sym = f->sym;
+ s->offset = f->offset;
+ }
+}
+
+
/* Add combine segment V and segment LIST. */
static segment_info *
}
}
}
+
+ /* Add a copy of this segment list to the namespace. */
+ copy_equiv_list_to_ns (current_segment);
}
tree length = NULL_TREE;
int byref;
- gcc_assert (sym->attr.referenced);
+ gcc_assert (sym->attr.referenced
+ || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
if (sym->ns && sym->ns->proc_name->attr.function)
byref = gfc_return_by_reference (sym->ns->proc_name);
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)
{
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;
break;
case GFC_ISYM_CHDIR:
- case GFC_ISYM_DOT_PRODUCT:
case GFC_ISYM_ETIME:
case GFC_ISYM_FGET:
case GFC_ISYM_FGETC:
+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.
+
2006-03-01 Daniel Berlin <dberlin@dberlin.org>
* g++.dg/tree-ssa/pr26443.C: New test case.
--- /dev/null
+! { dg-do run }
+! Tests the fix for PR20938 in which dependencies between equivalenced
+! arrays were not detected.
+!
+real, dimension (3) :: a = (/1., 2., 3./), b, c
+equivalence (a(2), b), (a(1), c)
+b = a;
+if (any(b .ne. (/1., 2., 3./))) call abort ()
+b = c
+if (any(b .ne. (/1., 1., 2./))) call abort ()
+end
--- /dev/null
+! { dg-do run }
+! Checks the LOGICAL version of dot_product
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+ logical :: l1(4) = (/.TRUE.,.FALSE.,.TRUE.,.FALSE./)
+ logical :: l2(4) = (/.FALSE.,.TRUE.,.FALSE.,.TRUE./)
+ if (dot_product (l1, l2)) call abort ()
+ l2 = .TRUE.
+ if (.not.dot_product (l1, l2)) call abort ()
+end
\ No newline at end of file
--- /dev/null
+! { dg-do run }
+! Tests the fix for PR26393, in which an ICE would occur in trans-decl.c
+! (gfc_get_symbol_decl) because anzKomponenten is not referenced in the
+! interface for solveCConvert. The solution was to assert that the symbol
+! is either referenced or in an interface body.
+!
+! Based on the testcase in the PR.
+!
+ MODULE MODULE_CONC
+ INTEGER, SAVE :: anzKomponenten = 2
+ END MODULE MODULE_CONC
+
+ MODULE MODULE_THERMOCALC
+ INTERFACE
+ FUNCTION solveCConvert ()
+ USE MODULE_CONC, ONLY: anzKomponenten
+ REAL :: solveCConvert(1:anzKomponenten)
+ END FUNCTION solveCConvert
+ END INTERFACE
+ END MODULE MODULE_THERMOCALC
+
+ SUBROUTINE outDiffKoeff
+ USE MODULE_CONC
+ USE MODULE_THERMOCALC
+ REAL :: buffer_conc(1:anzKomponenten)
+ buffer_conc = solveCConvert ()
+ if (any(buffer_conc .ne. (/(real(i), i = 1, anzKomponenten)/))) &
+ call abort ()
+ END SUBROUTINE outDiffKoeff
+
+ program missing_ref
+ USE MODULE_CONC
+ call outDiffKoeff
+! Now set anzKomponenten to a value that would cause a segfault if
+! buffer_conc and solveCConvert did not have the correct allocation
+! of memory.
+ anzKomponenten = 5000
+ call outDiffKoeff
+ end program missing_ref
+
+ FUNCTION solveCConvert ()
+ USE MODULE_CONC, ONLY: anzKomponenten
+ REAL :: solveCConvert(1:anzKomponenten)
+ solveCConvert = (/(real(i), i = 1, anzKomponenten)/)
+ END FUNCTION solveCConvert
+
+
+
--- /dev/null
+! Check to ensure only the first true clause in WHERE is
+! executed.
+program where_17
+ integer :: a(3)
+
+ a = (/1, 2, 3/)
+ where (a .eq. 1)
+ a = 2
+ elsewhere (a .le. 2)
+ a = 3
+ elsewhere (a .le. 3)
+ a = 4
+ endwhere
+ if (any (a .ne. (/2, 3, 4/))) call abort
+end program
--- /dev/null
+! Check to ensure mask is calculated first in WHERE
+! statements.
+program where_18
+ integer :: a(4)
+ integer :: b(3)
+ integer :: c(3)
+ equivalence (a(1), b(1)), (a(2), c(1))
+
+ a = (/1, 1, 1, 1/)
+ where (b .eq. 1)
+ c = 2
+ elsewhere (b .eq. 2)
+ c = 3
+ endwhere
+ if (any (a .ne. (/1, 2, 2, 2/))) &
+ call abort
+
+ a = (/1, 1, 1, 1/)
+ where (c .eq. 1)
+ b = 2
+ elsewhere (b .eq. 2)
+ b = 3
+ endwhere
+ if (any (a .ne. (/2, 2, 2, 1/))) &
+ call abort
+end program
--- /dev/null
+! Check to ensure result is calculated from unmodified
+! version of the right-hand-side in WHERE statements.
+program where_19
+ integer :: a(4)
+ integer :: b(3)
+ integer :: c(3)
+ equivalence (a(1), b(1)), (a(2), c(1))
+
+ a = (/1, 2, 3, 4/)
+ where (b .gt. 1)
+ c = b
+ endwhere
+ if (any (a .ne. (/1, 2, 2, 3/))) &
+ call abort ()
+
+ a = (/1, 2, 3, 4/)
+ where (c .gt. 1)
+ b = c
+ endwhere
+ if (any (a .ne. (/2, 3, 4, 4/))) &
+ call abort ()
+end program
+
--- /dev/null
+! Test the dependency checking in simple where. This
+! did not work and was fixed as part of the patch for
+! pr24519.
+!
+program where_20
+ integer :: a(4)
+ integer :: b(3)
+ integer :: c(3)
+ integer :: d(3) = (/1, 2, 3/)
+ equivalence (a(1), b(1)), (a(2), c(1))
+
+! This classic case worked before the patch.
+ a = (/1, 2, 3, 4/)
+ where (b .gt. 1) a(2:4) = a(1:3)
+ if (any(a .ne. (/1,2,2,3/))) call abort ()
+
+! This is the original manifestation of the problem
+! and is repeated in where_19.f90.
+ a = (/1, 2, 3, 4/)
+ where (b .gt. 1)
+ c = b
+ endwhere
+ if (any(a .ne. (/1,2,2,3/))) call abort ()
+
+! Mask to.destination dependency.
+ a = (/1, 2, 3, 4/)
+ where (b .gt. 1)
+ c = d
+ endwhere
+ if (any(a .ne. (/1,2,2,3/))) call abort ()
+
+! Source to.destination dependency.
+ a = (/1, 2, 3, 4/)
+ where (d .gt. 1)
+ c = b
+ endwhere
+ if (any(a .ne. (/1,2,2,3/))) call abort ()
+
+! Check the simple where.
+ a = (/1, 2, 3, 4/)
+ where (b .gt. 1) c = b
+ if (any(a .ne. (/1,2,2,3/))) call abort ()
+
+! This was OK before the patch.
+ a = (/1, 2, 3, 4/)
+ where (b .gt. 1)
+ where (d .gt. 1)
+ c = b
+ end where
+ endwhere
+ if (any(a .ne. (/1,2,2,3/))) call abort ()
+
+end program
+
projects / platform / upstream / gcc.git / commitdiff