aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog16
-rw-r--r--gcc/fortran/check.c10
-rw-r--r--gcc/fortran/expr.c12
-rw-r--r--gcc/fortran/gfortran.h3
-rw-r--r--gcc/fortran/trans-expr.c38
-rw-r--r--gcc/fortran/trans-intrinsic.c13
-rw-r--r--gcc/fortran/trans.h4
-rw-r--r--gcc/testsuite/ChangeLog8
-rw-r--r--gcc/testsuite/gfortran.dg/char_pointer_assign_2.f904
-rw-r--r--gcc/testsuite/gfortran.dg/char_pointer_assign_4.f9020
-rw-r--r--gcc/testsuite/gfortran.dg/char_pointer_assign_5.f9023
11 files changed, 125 insertions, 26 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 3cd8c1a..c33c58c 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,19 @@
+2008-12-18 Daniel Kraft <d@domob.eu>
+
+ PR fortran/31822
+ * gfortran.h (gfc_check_same_strlen): Made public.
+ * trans.h (gfc_trans_same_strlen_check): Made public.
+ * check.c (gfc_check_same_strlen): Made public and adapted error
+ message output to be useful not only for intrinsics.
+ (gfc_check_merge): Adapt to gfc_check_same_strlen change.
+ * expr.c (gfc_check_pointer_assign): Use gfc_check_same_strlen for
+ string length compile-time check.
+ * trans-expr.c (gfc_trans_pointer_assignment): Add runtime-check for
+ equal string lengths using gfc_trans_same_strlen_check.
+ * trans-intrinsic.c (gfc_trans_same_strlen_check): Renamed and made
+ public from conv_same_strlen_check.
+ (gfc_conv_intrinsic_merge): Adapted accordingly.
+
2008-12-17 Daniel Kraft <d@domob.eu>
PR fortran/38137
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 8ca67f2..8b2732b 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -396,8 +396,8 @@ identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
/* Check whether two character expressions have the same length;
returns SUCCESS if they have or if the length cannot be determined. */
-static gfc_try
-check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
+gfc_try
+gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
{
long len_a, len_b;
len_a = len_b = -1;
@@ -423,8 +423,8 @@ check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
if (len_a == len_b)
return SUCCESS;
- gfc_error ("Unequal character lengths (%ld and %ld) in %s intrinsic "
- "at %L", len_a, len_b, name, &a->where);
+ gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
+ len_a, len_b, name, &a->where);
return FAILURE;
}
@@ -2011,7 +2011,7 @@ gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
return FAILURE;
if (tsource->ts.type == BT_CHARACTER)
- return check_same_strlen (tsource, fsource, "MERGE");
+ return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
return SUCCESS;
}
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 4bdee7c..8a992ca 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3179,15 +3179,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (rvalue->expr_type == EXPR_NULL)
return SUCCESS;
- if (lvalue->ts.type == BT_CHARACTER
- && lvalue->ts.cl && rvalue->ts.cl
- && lvalue->ts.cl->length && rvalue->ts.cl->length
- && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
- rvalue->ts.cl->length)) == 1)
+ if (lvalue->ts.type == BT_CHARACTER)
{
- gfc_error ("Different character lengths in pointer "
- "assignment at %L", &lvalue->where);
- return FAILURE;
+ gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
+ if (t == FAILURE)
+ return FAILURE;
}
if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 1370124..c05fb88 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2580,4 +2580,7 @@ void gfc_global_used (gfc_gsymbol *, locus *);
/* dependency.c */
int gfc_dep_compare_expr (gfc_expr *, gfc_expr *);
+/* check.c */
+gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*);
+
#endif /* GCC_GFORTRAN_H */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 4a84234..5d41145 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4016,7 +4016,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
tree tmp;
tree decl;
-
gfc_start_block (&block);
gfc_init_se (&lse, NULL);
@@ -4039,15 +4038,32 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
+
+ /* Check character lengths if character expression. The test is only
+ really added if -fbounds-check is enabled. */
+ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+ {
+ gcc_assert (expr2->ts.type == BT_CHARACTER);
+ gcc_assert (lse.string_length && rse.string_length);
+ gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
+ lse.string_length, rse.string_length,
+ &block);
+ }
+
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
+
gfc_add_block_to_block (&block, &rse.post);
gfc_add_block_to_block (&block, &lse.post);
}
else
{
+ tree strlen_lhs;
+ tree strlen_rhs = NULL_TREE;
+
/* Array pointer. */
gfc_conv_expr_descriptor (&lse, expr1, lss);
+ strlen_lhs = lse.string_length;
switch (expr2->expr_type)
{
case EXPR_NULL:
@@ -4057,8 +4073,9 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
case EXPR_VARIABLE:
/* Assign directly to the pointer's descriptor. */
- lse.direct_byref = 1;
+ lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss);
+ strlen_rhs = lse.string_length;
/* If this is a subreference array pointer assignment, use the rhs
descriptor element size for the lhs span. */
@@ -4071,7 +4088,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
if (!INTEGER_CST_P (tmp))
- gfc_add_block_to_block (&lse.post, &rse.pre);
+ gfc_add_block_to_block (&lse.post, &rse.pre);
gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
}
@@ -4086,10 +4103,23 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
lse.expr = tmp;
lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss);
+ strlen_rhs = lse.string_length;
gfc_add_modify (&lse.pre, desc, tmp);
break;
- }
+ }
+
gfc_add_block_to_block (&block, &lse.pre);
+
+ /* Check string lengths if applicable. The check is only really added
+ to the output code if -fbounds-check is enabled. */
+ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+ {
+ gcc_assert (expr2->ts.type == BT_CHARACTER);
+ gcc_assert (strlen_lhs && strlen_rhs);
+ gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
+ strlen_lhs, strlen_rhs, &block);
+ }
+
gfc_add_block_to_block (&block, &lse.post);
}
return gfc_finish_block (&block);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 577cd20..e006ea7 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -751,9 +751,9 @@ gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
string lengths for both expressions are the same (needed for e.g. MERGE).
If bounds-checking is not enabled, does nothing. */
-static void
-conv_same_strlen_check (const char* intr_name, locus* where, tree a, tree b,
- stmtblock_t* target)
+void
+gfc_trans_same_strlen_check (const char* intr_name, locus* where,
+ tree a, tree b, stmtblock_t* target)
{
tree cond;
tree name;
@@ -769,8 +769,7 @@ conv_same_strlen_check (const char* intr_name, locus* where, tree a, tree b,
name = gfc_build_cstring_const (intr_name);
name = gfc_build_addr_expr (pchar_type_node, name);
gfc_trans_runtime_check (true, false, cond, target, where,
- "Unequal character lengths (%ld/%ld) for arguments"
- " to %s",
+ "Unequal character lengths (%ld/%ld) in %s",
fold_convert (long_integer_type_node, a),
fold_convert (long_integer_type_node, b), name);
}
@@ -3081,8 +3080,8 @@ gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
fsource = args[3];
mask = args[4];
- conv_same_strlen_check ("MERGE", &expr->where, len, len2, &se->post);
-
+ gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
+ &se->pre);
se->string_length = len;
}
type = TREE_TYPE (tsource);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 23d61ea..aa21775 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -458,6 +458,10 @@ tree gfc_trans_runtime_error_vararg (bool, locus*, const char*, va_list);
void gfc_trans_runtime_check (bool, bool, tree, stmtblock_t *, locus *,
const char *, ...);
+/* Generate a runtime check for same string length. */
+void gfc_trans_same_strlen_check (const char*, locus*, tree, tree,
+ stmtblock_t*);
+
/* Generate a call to free() after checking that its arg is non-NULL. */
tree gfc_call_free (tree);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 640cf78..a6fec3b 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2008-12-18 Daniel Kraft <d@domob.eu>
+
+ PR fortran/31822
+ * gfortran.dg/char_pointer_assign_2.f90: Updated expected error message
+ to be more detailed.
+ * gfortran.dg/char_pointer_assign_4.f90: New test.
+ * gfortran.dg/char_pointer_assign_5.f90: New test.
+
2008-12-18 Jakub Jelinek <jakub@redhat.com>
PR middle-end/38533
diff --git a/gcc/testsuite/gfortran.dg/char_pointer_assign_2.f90 b/gcc/testsuite/gfortran.dg/char_pointer_assign_2.f90
index f99b20f..c67bbb4 100644
--- a/gcc/testsuite/gfortran.dg/char_pointer_assign_2.f90
+++ b/gcc/testsuite/gfortran.dg/char_pointer_assign_2.f90
@@ -6,6 +6,6 @@
character(5), pointer :: ch3(:)
ch2 => ch1 ! Check correct is OK
- ch3 => ch1 ! { dg-error "Different character lengths" }
+ ch3 => ch1 ! { dg-error "Unequal character lengths \\(5/4\\)" }
-end \ No newline at end of file
+end
diff --git a/gcc/testsuite/gfortran.dg/char_pointer_assign_4.f90 b/gcc/testsuite/gfortran.dg/char_pointer_assign_4.f90
new file mode 100644
index 0000000..7dfc39b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_pointer_assign_4.f90
@@ -0,0 +1,20 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "Unequal character length" }
+
+! PR fortran/31822
+! Verify that runtime checks for matching character length
+! in pointer assignment work.
+
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+program ptr
+ implicit none
+ character(len=10), target :: s1
+ character(len=5), pointer :: p1
+ integer, volatile :: i
+ i = 8
+ p1 => s1(1:i)
+end program ptr
+
+! { dg-output "Unequal character lengths \\(5/8\\)" }
diff --git a/gcc/testsuite/gfortran.dg/char_pointer_assign_5.f90 b/gcc/testsuite/gfortran.dg/char_pointer_assign_5.f90
new file mode 100644
index 0000000..471f6e6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_pointer_assign_5.f90
@@ -0,0 +1,23 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "Unequal character length" }
+
+! PR fortran/31822
+! Verify that runtime checks for matching character length
+! in pointer assignment work.
+
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+program ptr
+ implicit none
+ character(len=10), target :: s1
+ call bar((/ s1, s1 /))
+contains
+ subroutine bar(s)
+ character(len=*),target :: s(2)
+ character(len=17),pointer :: p(:)
+ p => s
+ end subroutine bar
+end program ptr
+
+! { dg-output "Unequal character lengths \\(17/10\\)" }
generated by cgit v1.1 at 2025-03-19 22:42:12 +0000