* [Fortran, Patch, PR72832, v1] [6/7 Regression] [OOP] ALLOCATE with SOURCE fails to allocate requested dimensions
@ 2016-09-02 7:59 Andre Vehreschild
2016-10-12 9:50 ` PING! " Andre Vehreschild
0 siblings, 1 reply; 6+ messages in thread
From: Andre Vehreschild @ 2016-09-02 7:59 UTC (permalink / raw)
To: GCC-Fortran-ML, GCC-Patches-ML
[-- Attachment #1: Type: text/plain, Size: 1670 bytes --]
Hi all,
attached patch fixes the issue raised by PR72832. The issue was that
the array descriptor of the SOURCE= in an ALLOCATE () was used to
allocate an array object although an explicit array spec had been
given.
The initial test showed a second issue when a class array was copied.
Compiling the code with -fcheck=bounds showed that no boundary check
was generated for class array copying using gfc_copy_class_to_class().
I have added the generation of a runtime boundary check when the
-fcheck=bounds flag is set to locate the current issue. The test
allocate_with_source_23 is compiled with fcheck=bounds and fails as
expected ({ xfail *-*-* } set).
Fixing the both issues unfortunately raised the next one, when trying
to get the size of a class array returned from a function (testcase:
allocate_with_source_11.f08). Here the issue was that for functions
returning class arrays gfc_conv_expr_descriptor () relied on the
descriptor being magicked into the scalarizer, which did not work in
this use case. Due to the first issue this bug did not raise beforehand.
Because I could not figure how to do it right in
gfc_conv_expr_descriptor (), I found a way to circumvent the issue by
getting the reference of the result of the function returning a class
array and massaging it to be ok for size (). This works quite neatly,
but may be someone with better knowledge of conv_expr_descriptor and
the scalarizer might want to fix it there. I suppose there are more
locations in the code, that work around this issue.
Bootstrapped and regtests ok on x86_64-linux-gnu/F23 for trunk and
gcc-6. Ok for both?
- Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr72832_1.clog --]
[-- Type: text/plain, Size: 658 bytes --]
gcc/fortran/ChangeLog:
2016-09-01 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/72832
* trans-expr.c (gfc_copy_class_to_class): Add generation of
runtime array bounds check.
* trans-intrinsic.c (gfc_conv_intrinsic_size): Add a crutch to
get the descriptor of a function returning a class object.
* trans-stmt.c (gfc_trans_allocate): Use the array spec on the
array to allocate instead of the array spec from source=.
gcc/testsuite/ChangeLog:
2016-09-01 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/72832
* gfortran.dg/allocate_with_source_22.f03: New test.
* gfortran.dg/allocate_with_source_23.f03: New test. Expected to
fail.
[-- Attachment #3: pr72832_1.patch --]
[-- Type: text/x-patch, Size: 6051 bytes --]
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 19239fb..4d2fd33 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1180,6 +1180,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
stmtblock_t body;
stmtblock_t ifbody;
gfc_loopinfo loop;
+ tree orig_nelems = nelems; /* Needed for bounds check. */
gfc_init_block (&body);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
@@ -1207,6 +1208,31 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
}
vec_safe_push (args, to_ref);
+ /* Add bounds check. */
+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
+ {
+ char *msg;
+ const char *name = "<<unknown>>";
+ tree from_len;
+
+ if (DECL_P (to))
+ name = (const char *)(DECL_NAME (to)->identifier.id.str);
+
+ from_len = gfc_conv_descriptor_size (from_data, 1);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, from_len, orig_nelems);
+ msg = xasprintf ("Array bound mismatch for dimension %d "
+ "of array '%s' (%%ld/%%ld)",
+ 1, name);
+
+ gfc_trans_runtime_check (true, false, tmp, &body,
+ &gfc_current_locus, msg,
+ fold_convert (long_integer_type_node, orig_nelems),
+ fold_convert (long_integer_type_node, from_len));
+
+ free (msg);
+ }
+
tmp = build_call_vec (fcn_type, fcn, args);
/* Build the body of the loop. */
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 8167842..d4ff85c 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -5845,9 +5845,20 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
if (actual->expr->ts.type == BT_CLASS)
gfc_add_class_array_ref (actual->expr);
- argse.want_pointer = 1;
argse.data_not_needed = 1;
- gfc_conv_expr_descriptor (&argse, actual->expr);
+ if (gfc_is_alloc_class_array_function (actual->expr))
+ {
+ /* For functions that return a class array conv_expr_descriptor is not
+ able to get the descriptor right. Therefore this special case. */
+ gfc_conv_expr_reference (&argse, actual->expr);
+ argse.expr = gfc_build_addr_expr (NULL_TREE,
+ gfc_class_data_get (argse.expr));
+ }
+ else
+ {
+ argse.want_pointer = 1;
+ gfc_conv_expr_descriptor (&argse, actual->expr);
+ }
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
arg1 = gfc_evaluate_now (argse.expr, &se->pre);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 5884e7a..8e5428a 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5485,7 +5485,8 @@ gfc_trans_allocate (gfc_code * code)
desc = tmp;
tmp = gfc_class_data_get (tmp);
}
- e3_is = E3_DESC;
+ if (code->ext.alloc.arr_spec_from_expr3)
+ e3_is = E3_DESC;
}
else
desc = !is_coarray ? se.expr
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_22.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_22.f03
new file mode 100644
index 0000000..b8689f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_22.f03
@@ -0,0 +1,48 @@
+! { dg-do run }
+!
+! Test that pr72832 is fixed now.
+! Contributed by Daan van Vugt
+
+program allocate_source
+ type :: t
+ integer :: i
+ end type t
+ type, extends(t) :: tt
+ end type tt
+
+ call test_type()
+ call test_class()
+
+contains
+
+subroutine test_class()
+ class(t), allocatable, dimension(:) :: a, b
+ allocate(tt::a(1:2))
+ a(:)%i = [ 1,2 ]
+ if (size(a) /= 2) call abort()
+ if (any(a(:)%i /= [ 1,2])) call abort()
+
+ allocate(b(1:4), source=a)
+ ! b is incorrectly initialized here. This only is diagnosed when compiled
+ ! with -fcheck=bounds.
+ if (size(b) /= 4) call abort()
+ if (any(b(1:2)%i /= [ 1,2])) call abort()
+ select type (b(1))
+ class is (tt)
+ continue
+ class default
+ call abort()
+ end select
+end subroutine
+
+subroutine test_type()
+ type(t), allocatable, dimension(:) :: a, b
+ allocate(a(1:2))
+ if (size(a) /= 2) call abort()
+
+ allocate(b(1:4), source=a)
+ if (size(b) /= 4) call abort()
+end subroutine
+end program allocate_source
+
+
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_23.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_23.f03
new file mode 100644
index 0000000..e36b5ce
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_23.f03
@@ -0,0 +1,65 @@
+! { dg-do run { xfail *-*-* } }
+! { dg-options "-fcheck=bounds" }
+! Test that pr72832 is fixed now.
+! Contributed by Daan van Vugt
+
+program allocate_source
+ type :: t
+ integer :: i
+ end type t
+ type, extends(t) :: tt
+ end type tt
+
+ call test_type()
+ call test_class_correct()
+ call test_class_fail()
+
+contains
+
+subroutine test_class_correct()
+ class(t), allocatable, dimension(:) :: a, b
+ allocate(tt::a(1:2))
+ a(:)%i = [ 1,2 ]
+ if (size(a) /= 2) call abort()
+ if (any(a(:)%i /= [ 1,2])) call abort()
+
+ allocate(b(1:4), source=a(1))
+ if (size(b) /= 4) call abort()
+ if (any(b(:)%i /= [ 1,1,1,1])) call abort()
+ select type (b(1))
+ class is (tt)
+ continue
+ class default
+ call abort()
+ end select
+end subroutine
+
+subroutine test_class_fail()
+ class(t), allocatable, dimension(:) :: a, b
+ allocate(tt::a(1:2))
+ a(:)%i = [ 1,2 ]
+ if (size(a) /= 2) call abort()
+ if (any(a(:)%i /= [ 1,2])) call abort()
+
+ allocate(b(1:4), source=a) ! Fail expected: sizes do not conform
+ if (size(b) /= 4) call abort()
+ if (any(b(1:2)%i /= [ 1,2])) call abort()
+ select type (b(1))
+ class is (tt)
+ continue
+ class default
+ call abort()
+ end select
+end subroutine
+
+subroutine test_type()
+ type(t), allocatable, dimension(:) :: a, b
+ allocate(a(1:2))
+ if (size(a) /= 2) call abort()
+
+ allocate(b(1:4), source=a)
+ if (size(b) /= 4) call abort()
+end subroutine
+end program allocate_source
+
+
^ permalink raw reply [flat|nested] 6+ messages in thread
* PING! [Fortran, Patch, PR72832, v1] [6/7 Regression] [OOP] ALLOCATE with SOURCE fails to allocate requested dimensions
2016-09-02 7:59 [Fortran, Patch, PR72832, v1] [6/7 Regression] [OOP] ALLOCATE with SOURCE fails to allocate requested dimensions Andre Vehreschild
@ 2016-10-12 9:50 ` Andre Vehreschild
2016-10-12 17:18 ` Steve Kargl
0 siblings, 1 reply; 6+ messages in thread
From: Andre Vehreschild @ 2016-10-12 9:50 UTC (permalink / raw)
To: GCC-Fortran-ML, GCC-Patches-ML
[-- Attachment #1: Type: text/plain, Size: 1892 bytes --]
Ping!
Updated patch with the comments gotten so far.
Ok for trunk?
- Andre
On Fri, 2 Sep 2016 09:59:19 +0200
Andre Vehreschild <vehre@gmx.de> wrote:
> Hi all,
>
> attached patch fixes the issue raised by PR72832. The issue was that
> the array descriptor of the SOURCE= in an ALLOCATE () was used to
> allocate an array object although an explicit array spec had been
> given.
>
> The initial test showed a second issue when a class array was copied.
> Compiling the code with -fcheck=bounds showed that no boundary check
> was generated for class array copying using gfc_copy_class_to_class().
> I have added the generation of a runtime boundary check when the
> -fcheck=bounds flag is set to locate the current issue. The test
> allocate_with_source_23 is compiled with fcheck=bounds and fails as
> expected ({ xfail *-*-* } set).
>
> Fixing the both issues unfortunately raised the next one, when trying
> to get the size of a class array returned from a function (testcase:
> allocate_with_source_11.f08). Here the issue was that for functions
> returning class arrays gfc_conv_expr_descriptor () relied on the
> descriptor being magicked into the scalarizer, which did not work in
> this use case. Due to the first issue this bug did not raise beforehand.
> Because I could not figure how to do it right in
> gfc_conv_expr_descriptor (), I found a way to circumvent the issue by
> getting the reference of the result of the function returning a class
> array and massaging it to be ok for size (). This works quite neatly,
> but may be someone with better knowledge of conv_expr_descriptor and
> the scalarizer might want to fix it there. I suppose there are more
> locations in the code, that work around this issue.
>
> Bootstrapped and regtests ok on x86_64-linux-gnu/F23 for trunk and
> gcc-6. Ok for both?
>
> - Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr72832_1.clog --]
[-- Type: text/plain, Size: 658 bytes --]
gcc/fortran/ChangeLog:
2016-09-01 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/72832
* trans-expr.c (gfc_copy_class_to_class): Add generation of
runtime array bounds check.
* trans-intrinsic.c (gfc_conv_intrinsic_size): Add a crutch to
get the descriptor of a function returning a class object.
* trans-stmt.c (gfc_trans_allocate): Use the array spec on the
array to allocate instead of the array spec from source=.
gcc/testsuite/ChangeLog:
2016-09-01 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/72832
* gfortran.dg/allocate_with_source_22.f03: New test.
* gfortran.dg/allocate_with_source_23.f03: New test. Expected to
fail.
[-- Attachment #3: pr72832_2.patch --]
[-- Type: text/x-patch, Size: 6083 bytes --]
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 1de2818..5486ec6 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1237,6 +1237,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
stmtblock_t body;
stmtblock_t ifbody;
gfc_loopinfo loop;
+ tree orig_nelems = nelems; /* Needed for bounds check. */
gfc_init_block (&body);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
@@ -1264,6 +1265,31 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
}
vec_safe_push (args, to_ref);
+ /* Add bounds check. */
+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
+ {
+ char *msg;
+ const char *name = "<<unknown>>";
+ tree from_len;
+
+ if (DECL_P (to))
+ name = (const char *)(DECL_NAME (to)->identifier.id.str);
+
+ from_len = gfc_conv_descriptor_size (from_data, 1);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, from_len, orig_nelems);
+ msg = xasprintf ("Array bound mismatch for dimension %d "
+ "of array '%s' (%%ld/%%ld)",
+ 1, name);
+
+ gfc_trans_runtime_check (true, false, tmp, &body,
+ &gfc_current_locus, msg,
+ fold_convert (long_integer_type_node, orig_nelems),
+ fold_convert (long_integer_type_node, from_len));
+
+ free (msg);
+ }
+
tmp = build_call_vec (fcn_type, fcn, args);
/* Build the body of the loop. */
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index a499c32..9d5e33c 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -6544,9 +6544,20 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
if (actual->expr->ts.type == BT_CLASS)
gfc_add_class_array_ref (actual->expr);
- argse.want_pointer = 1;
argse.data_not_needed = 1;
- gfc_conv_expr_descriptor (&argse, actual->expr);
+ if (gfc_is_alloc_class_array_function (actual->expr))
+ {
+ /* For functions that return a class array conv_expr_descriptor is not
+ able to get the descriptor right. Therefore this special case. */
+ gfc_conv_expr_reference (&argse, actual->expr);
+ argse.expr = gfc_build_addr_expr (NULL_TREE,
+ gfc_class_data_get (argse.expr));
+ }
+ else
+ {
+ argse.want_pointer = 1;
+ gfc_conv_expr_descriptor (&argse, actual->expr);
+ }
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
arg1 = gfc_evaluate_now (argse.expr, &se->pre);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 9fdacc1..deeea2f 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5489,7 +5489,8 @@ gfc_trans_allocate (gfc_code * code)
desc = tmp;
tmp = gfc_class_data_get (tmp);
}
- e3_is = E3_DESC;
+ if (code->ext.alloc.arr_spec_from_expr3)
+ e3_is = E3_DESC;
}
else
desc = !is_coarray ? se.expr
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_22.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_22.f03
new file mode 100644
index 0000000..b8689f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_22.f03
@@ -0,0 +1,48 @@
+! { dg-do run }
+!
+! Test that pr72832 is fixed now.
+! Contributed by Daan van Vugt
+
+program allocate_source
+ type :: t
+ integer :: i
+ end type t
+ type, extends(t) :: tt
+ end type tt
+
+ call test_type()
+ call test_class()
+
+contains
+
+subroutine test_class()
+ class(t), allocatable, dimension(:) :: a, b
+ allocate(tt::a(1:2))
+ a(:)%i = [ 1,2 ]
+ if (size(a) /= 2) call abort()
+ if (any(a(:)%i /= [ 1,2])) call abort()
+
+ allocate(b(1:4), source=a)
+ ! b is incorrectly initialized here. This only is diagnosed when compiled
+ ! with -fcheck=bounds.
+ if (size(b) /= 4) call abort()
+ if (any(b(1:2)%i /= [ 1,2])) call abort()
+ select type (b(1))
+ class is (tt)
+ continue
+ class default
+ call abort()
+ end select
+end subroutine
+
+subroutine test_type()
+ type(t), allocatable, dimension(:) :: a, b
+ allocate(a(1:2))
+ if (size(a) /= 2) call abort()
+
+ allocate(b(1:4), source=a)
+ if (size(b) /= 4) call abort()
+end subroutine
+end program allocate_source
+
+
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_23.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_23.f03
new file mode 100644
index 0000000..cfe8bd8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_23.f03
@@ -0,0 +1,67 @@
+! { dg-do run }
+! { dg-options "-fcheck=bounds" }
+! { dg-shouldfail "Array bounds mismatch" }
+!
+! Test that pr72832 is fixed now.
+! Contributed by Daan van Vugt
+
+program allocate_source
+ type :: t
+ integer :: i
+ end type t
+ type, extends(t) :: tt
+ end type tt
+
+ call test_type()
+ call test_class_correct()
+ call test_class_fail()
+
+contains
+
+subroutine test_class_correct()
+ class(t), allocatable, dimension(:) :: a, b
+ allocate(tt::a(1:2))
+ a(:)%i = [ 1,2 ]
+ if (size(a) /= 2) call abort()
+ if (any(a(:)%i /= [ 1,2])) call abort()
+
+ allocate(b(1:4), source=a(1))
+ if (size(b) /= 4) call abort()
+ if (any(b(:)%i /= [ 1,1,1,1])) call abort()
+ select type (b(1))
+ class is (tt)
+ continue
+ class default
+ call abort()
+ end select
+end subroutine
+
+subroutine test_class_fail()
+ class(t), allocatable, dimension(:) :: a, b
+ allocate(tt::a(1:2))
+ a(:)%i = [ 1,2 ]
+ if (size(a) /= 2) call abort()
+ if (any(a(:)%i /= [ 1,2])) call abort()
+
+ allocate(b(1:4), source=a) ! Fail expected: sizes do not conform
+ if (size(b) /= 4) call abort()
+ if (any(b(1:2)%i /= [ 1,2])) call abort()
+ select type (b(1))
+ class is (tt)
+ continue
+ class default
+ call abort()
+ end select
+end subroutine
+
+subroutine test_type()
+ type(t), allocatable, dimension(:) :: a, b
+ allocate(a(1:2))
+ if (size(a) /= 2) call abort()
+
+ allocate(b(1:4), source=a)
+ if (size(b) /= 4) call abort()
+end subroutine
+end program allocate_source
+
+
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: PING! [Fortran, Patch, PR72832, v1] [6/7 Regression] [OOP] ALLOCATE with SOURCE fails to allocate requested dimensions
2016-10-12 9:50 ` PING! " Andre Vehreschild
@ 2016-10-12 17:18 ` Steve Kargl
2016-10-13 8:53 ` Andre Vehreschild
0 siblings, 1 reply; 6+ messages in thread
From: Steve Kargl @ 2016-10-12 17:18 UTC (permalink / raw)
To: Andre Vehreschild; +Cc: GCC-Fortran-ML, GCC-Patches-ML
On Wed, Oct 12, 2016 at 11:50:10AM +0200, Andre Vehreschild wrote:
> Ping!
>
> Updated patch with the comments gotten so far.
>
> Ok for trunk?
>
Looks good to me.
--
Steve
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: PING! [Fortran, Patch, PR72832, v1] [6/7 Regression] [OOP] ALLOCATE with SOURCE fails to allocate requested dimensions
2016-10-12 17:18 ` Steve Kargl
@ 2016-10-13 8:53 ` Andre Vehreschild
2016-10-23 11:57 ` Andre Vehreschild
0 siblings, 1 reply; 6+ messages in thread
From: Andre Vehreschild @ 2016-10-13 8:53 UTC (permalink / raw)
To: Steve Kargl; +Cc: GCC-Fortran-ML, GCC-Patches-ML
[-- Attachment #1: Type: text/plain, Size: 488 bytes --]
Hi Steve,
thanks for the review. Committed as r241088 on trunk.
Letting it mature for one week in trunk before backporting to gcc-6.
Regards,
Andre
On Wed, 12 Oct 2016 10:18:29 -0700
Steve Kargl <sgk@troutmask.apl.washington.edu> wrote:
> On Wed, Oct 12, 2016 at 11:50:10AM +0200, Andre Vehreschild wrote:
> > Ping!
> >
> > Updated patch with the comments gotten so far.
> >
> > Ok for trunk?
> >
>
> Looks good to me.
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 7284 bytes --]
Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog (Revision 241086)
+++ gcc/fortran/ChangeLog (Arbeitskopie)
@@ -1,3 +1,13 @@
+2016-10-13 Andre Vehreschild <vehre@gcc.gnu.org>
+
+ PR fortran/72832
+ * trans-expr.c (gfc_copy_class_to_class): Add generation of
+ runtime array bounds check.
+ * trans-intrinsic.c (gfc_conv_intrinsic_size): Add a crutch to
+ get the descriptor of a function returning a class object.
+ * trans-stmt.c (gfc_trans_allocate): Use the array spec on the
+ array to allocate instead of the array spec from source=.
+
2016-10-12 Andre Vehreschild <vehre@gcc.gnu.org>
* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Fixed style.
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (Revision 241086)
+++ gcc/fortran/trans-expr.c (Arbeitskopie)
@@ -1235,6 +1235,7 @@
stmtblock_t body;
stmtblock_t ifbody;
gfc_loopinfo loop;
+ tree orig_nelems = nelems; /* Needed for bounds check. */
gfc_init_block (&body);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
@@ -1262,6 +1263,31 @@
}
vec_safe_push (args, to_ref);
+ /* Add bounds check. */
+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
+ {
+ char *msg;
+ const char *name = "<<unknown>>";
+ tree from_len;
+
+ if (DECL_P (to))
+ name = (const char *)(DECL_NAME (to)->identifier.id.str);
+
+ from_len = gfc_conv_descriptor_size (from_data, 1);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, from_len, orig_nelems);
+ msg = xasprintf ("Array bound mismatch for dimension %d "
+ "of array '%s' (%%ld/%%ld)",
+ 1, name);
+
+ gfc_trans_runtime_check (true, false, tmp, &body,
+ &gfc_current_locus, msg,
+ fold_convert (long_integer_type_node, orig_nelems),
+ fold_convert (long_integer_type_node, from_len));
+
+ free (msg);
+ }
+
tmp = build_call_vec (fcn_type, fcn, args);
/* Build the body of the loop. */
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (Revision 241086)
+++ gcc/fortran/trans-intrinsic.c (Arbeitskopie)
@@ -6544,9 +6544,20 @@
if (actual->expr->ts.type == BT_CLASS)
gfc_add_class_array_ref (actual->expr);
- argse.want_pointer = 1;
argse.data_not_needed = 1;
- gfc_conv_expr_descriptor (&argse, actual->expr);
+ if (gfc_is_alloc_class_array_function (actual->expr))
+ {
+ /* For functions that return a class array conv_expr_descriptor is not
+ able to get the descriptor right. Therefore this special case. */
+ gfc_conv_expr_reference (&argse, actual->expr);
+ argse.expr = gfc_build_addr_expr (NULL_TREE,
+ gfc_class_data_get (argse.expr));
+ }
+ else
+ {
+ argse.want_pointer = 1;
+ gfc_conv_expr_descriptor (&argse, actual->expr);
+ }
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
arg1 = gfc_evaluate_now (argse.expr, &se->pre);
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (Revision 241086)
+++ gcc/fortran/trans-stmt.c (Arbeitskopie)
@@ -5489,7 +5489,8 @@
desc = tmp;
tmp = gfc_class_data_get (tmp);
}
- e3_is = E3_DESC;
+ if (code->ext.alloc.arr_spec_from_expr3)
+ e3_is = E3_DESC;
}
else
desc = !is_coarray ? se.expr
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog (Revision 241086)
+++ gcc/testsuite/ChangeLog (Arbeitskopie)
@@ -1,3 +1,10 @@
+2016-10-13 Andre Vehreschild <vehre@gcc.gnu.org>
+
+ PR fortran/72832
+ * gfortran.dg/allocate_with_source_22.f03: New test.
+ * gfortran.dg/allocate_with_source_23.f03: New test. Expected to
+ fail.
+
2016-10-13 Thomas Preud'homme <thomas.preudhomme@arm.com>
* gcc.target/arm/movhi_movw.c: Enable test for ARM mode.
Index: gcc/testsuite/gfortran.dg/allocate_with_source_22.f03
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_with_source_22.f03 (nicht existent)
+++ gcc/testsuite/gfortran.dg/allocate_with_source_22.f03 (Arbeitskopie)
@@ -0,0 +1,48 @@
+! { dg-do run }
+!
+! Test that pr72832 is fixed now.
+! Contributed by Daan van Vugt
+
+program allocate_source
+ type :: t
+ integer :: i
+ end type t
+ type, extends(t) :: tt
+ end type tt
+
+ call test_type()
+ call test_class()
+
+contains
+
+subroutine test_class()
+ class(t), allocatable, dimension(:) :: a, b
+ allocate(tt::a(1:2))
+ a(:)%i = [ 1,2 ]
+ if (size(a) /= 2) call abort()
+ if (any(a(:)%i /= [ 1,2])) call abort()
+
+ allocate(b(1:4), source=a)
+ ! b is incorrectly initialized here. This only is diagnosed when compiled
+ ! with -fcheck=bounds.
+ if (size(b) /= 4) call abort()
+ if (any(b(1:2)%i /= [ 1,2])) call abort()
+ select type (b(1))
+ class is (tt)
+ continue
+ class default
+ call abort()
+ end select
+end subroutine
+
+subroutine test_type()
+ type(t), allocatable, dimension(:) :: a, b
+ allocate(a(1:2))
+ if (size(a) /= 2) call abort()
+
+ allocate(b(1:4), source=a)
+ if (size(b) /= 4) call abort()
+end subroutine
+end program allocate_source
+
+
Index: gcc/testsuite/gfortran.dg/allocate_with_source_23.f03
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_with_source_23.f03 (nicht existent)
+++ gcc/testsuite/gfortran.dg/allocate_with_source_23.f03 (Arbeitskopie)
@@ -0,0 +1,67 @@
+! { dg-do run }
+! { dg-options "-fcheck=bounds" }
+! { dg-shouldfail "Array bounds mismatch" }
+!
+! Test that pr72832 is fixed now.
+! Contributed by Daan van Vugt
+
+program allocate_source
+ type :: t
+ integer :: i
+ end type t
+ type, extends(t) :: tt
+ end type tt
+
+ call test_type()
+ call test_class_correct()
+ call test_class_fail()
+
+contains
+
+subroutine test_class_correct()
+ class(t), allocatable, dimension(:) :: a, b
+ allocate(tt::a(1:2))
+ a(:)%i = [ 1,2 ]
+ if (size(a) /= 2) call abort()
+ if (any(a(:)%i /= [ 1,2])) call abort()
+
+ allocate(b(1:4), source=a(1))
+ if (size(b) /= 4) call abort()
+ if (any(b(:)%i /= [ 1,1,1,1])) call abort()
+ select type (b(1))
+ class is (tt)
+ continue
+ class default
+ call abort()
+ end select
+end subroutine
+
+subroutine test_class_fail()
+ class(t), allocatable, dimension(:) :: a, b
+ allocate(tt::a(1:2))
+ a(:)%i = [ 1,2 ]
+ if (size(a) /= 2) call abort()
+ if (any(a(:)%i /= [ 1,2])) call abort()
+
+ allocate(b(1:4), source=a) ! Fail expected: sizes do not conform
+ if (size(b) /= 4) call abort()
+ if (any(b(1:2)%i /= [ 1,2])) call abort()
+ select type (b(1))
+ class is (tt)
+ continue
+ class default
+ call abort()
+ end select
+end subroutine
+
+subroutine test_type()
+ type(t), allocatable, dimension(:) :: a, b
+ allocate(a(1:2))
+ if (size(a) /= 2) call abort()
+
+ allocate(b(1:4), source=a)
+ if (size(b) /= 4) call abort()
+end subroutine
+end program allocate_source
+
+
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: PING! [Fortran, Patch, PR72832, v1] [6/7 Regression] [OOP] ALLOCATE with SOURCE fails to allocate requested dimensions
2016-10-13 8:53 ` Andre Vehreschild
@ 2016-10-23 11:57 ` Andre Vehreschild
0 siblings, 0 replies; 6+ messages in thread
From: Andre Vehreschild @ 2016-10-23 11:57 UTC (permalink / raw)
To: Steve Kargl; +Cc: GCC-Fortran-ML, GCC-Patches-ML
[-- Attachment #1: Type: text/plain, Size: 724 bytes --]
Hi all,
due to no complains about the trunk version, backported to gcc-6 as r241448.
Regards,
Andre
On Thu, 13 Oct 2016 10:52:59 +0200
Andre Vehreschild <vehre@gmx.de> wrote:
> Hi Steve,
>
> thanks for the review. Committed as r241088 on trunk.
>
> Letting it mature for one week in trunk before backporting to gcc-6.
>
> Regards,
> Andre
>
> On Wed, 12 Oct 2016 10:18:29 -0700
> Steve Kargl <sgk@troutmask.apl.washington.edu> wrote:
>
> > On Wed, Oct 12, 2016 at 11:50:10AM +0200, Andre Vehreschild wrote:
> > > Ping!
> > >
> > > Updated patch with the comments gotten so far.
> > >
> > > Ok for trunk?
> > >
> >
> > Looks good to me.
> >
>
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: submit_gcc6.diff --]
[-- Type: text/x-patch, Size: 7228 bytes --]
Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog (Revision 241447)
+++ gcc/fortran/ChangeLog (Arbeitskopie)
@@ -1,3 +1,14 @@
+2016-10-23 Andre Vehreschild <vehre@gcc.gnu.org>
+
+ Backported from trunk
+ PR fortran/72832
+ * trans-expr.c (gfc_copy_class_to_class): Add generation of
+ runtime array bounds check.
+ * trans-intrinsic.c (gfc_conv_intrinsic_size): Add a crutch to
+ get the descriptor of a function returning a class object.
+ * trans-stmt.c (gfc_trans_allocate): Use the array spec on the
+ array to allocate instead of the array spec from source=.
+
2016-10-17 Steven G. Kargl <kargl@gcc.gnu.org>
Backport from trunk
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (Revision 241447)
+++ gcc/fortran/trans-expr.c (Arbeitskopie)
@@ -1166,6 +1166,7 @@
stmtblock_t body;
stmtblock_t ifbody;
gfc_loopinfo loop;
+ tree orig_nelems = nelems; /* Needed for bounds check. */
gfc_init_block (&body);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
@@ -1193,6 +1194,31 @@
}
vec_safe_push (args, to_ref);
+ /* Add bounds check. */
+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
+ {
+ char *msg;
+ const char *name = "<<unknown>>";
+ tree from_len;
+
+ if (DECL_P (to))
+ name = (const char *)(DECL_NAME (to)->identifier.id.str);
+
+ from_len = gfc_conv_descriptor_size (from_data, 1);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, from_len, orig_nelems);
+ msg = xasprintf ("Array bound mismatch for dimension %d "
+ "of array '%s' (%%ld/%%ld)",
+ 1, name);
+
+ gfc_trans_runtime_check (true, false, tmp, &body,
+ &gfc_current_locus, msg,
+ fold_convert (long_integer_type_node, orig_nelems),
+ fold_convert (long_integer_type_node, from_len));
+
+ free (msg);
+ }
+
tmp = build_call_vec (fcn_type, fcn, args);
/* Build the body of the loop. */
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (Revision 241447)
+++ gcc/fortran/trans-intrinsic.c (Arbeitskopie)
@@ -5815,9 +5815,20 @@
if (actual->expr->ts.type == BT_CLASS)
gfc_add_class_array_ref (actual->expr);
- argse.want_pointer = 1;
argse.data_not_needed = 1;
- gfc_conv_expr_descriptor (&argse, actual->expr);
+ if (gfc_is_alloc_class_array_function (actual->expr))
+ {
+ /* For functions that return a class array conv_expr_descriptor is not
+ able to get the descriptor right. Therefore this special case. */
+ gfc_conv_expr_reference (&argse, actual->expr);
+ argse.expr = gfc_build_addr_expr (NULL_TREE,
+ gfc_class_data_get (argse.expr));
+ }
+ else
+ {
+ argse.want_pointer = 1;
+ gfc_conv_expr_descriptor (&argse, actual->expr);
+ }
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
arg1 = gfc_evaluate_now (argse.expr, &se->pre);
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (Revision 241447)
+++ gcc/fortran/trans-stmt.c (Arbeitskopie)
@@ -5476,7 +5476,8 @@
desc = tmp;
tmp = gfc_class_data_get (tmp);
}
- e3_is = E3_DESC;
+ if (code->ext.alloc.arr_spec_from_expr3)
+ e3_is = E3_DESC;
}
else
desc = !is_coarray ? se.expr
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog (Revision 241447)
+++ gcc/testsuite/ChangeLog (Arbeitskopie)
@@ -1,3 +1,11 @@
+2016-10-23 Andre Vehreschild <vehre@gcc.gnu.org>
+
+ Backported from trunk
+ PR fortran/72832
+ * gfortran.dg/allocate_with_source_22.f03: New test.
+ * gfortran.dg/allocate_with_source_23.f03: New test. Expected to
+ fail.
+
2016-10-19 Uros Bizjak <ubizjak@gmail.com>
PR target/77991
Index: gcc/testsuite/gfortran.dg/allocate_with_source_22.f03
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_with_source_22.f03 (nicht existent)
+++ gcc/testsuite/gfortran.dg/allocate_with_source_22.f03 (Arbeitskopie)
@@ -0,0 +1,48 @@
+! { dg-do run }
+!
+! Test that pr72832 is fixed now.
+! Contributed by Daan van Vugt
+
+program allocate_source
+ type :: t
+ integer :: i
+ end type t
+ type, extends(t) :: tt
+ end type tt
+
+ call test_type()
+ call test_class()
+
+contains
+
+subroutine test_class()
+ class(t), allocatable, dimension(:) :: a, b
+ allocate(tt::a(1:2))
+ a(:)%i = [ 1,2 ]
+ if (size(a) /= 2) call abort()
+ if (any(a(:)%i /= [ 1,2])) call abort()
+
+ allocate(b(1:4), source=a)
+ ! b is incorrectly initialized here. This only is diagnosed when compiled
+ ! with -fcheck=bounds.
+ if (size(b) /= 4) call abort()
+ if (any(b(1:2)%i /= [ 1,2])) call abort()
+ select type (b(1))
+ class is (tt)
+ continue
+ class default
+ call abort()
+ end select
+end subroutine
+
+subroutine test_type()
+ type(t), allocatable, dimension(:) :: a, b
+ allocate(a(1:2))
+ if (size(a) /= 2) call abort()
+
+ allocate(b(1:4), source=a)
+ if (size(b) /= 4) call abort()
+end subroutine
+end program allocate_source
+
+
Index: gcc/testsuite/gfortran.dg/allocate_with_source_23.f03
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_with_source_23.f03 (nicht existent)
+++ gcc/testsuite/gfortran.dg/allocate_with_source_23.f03 (Arbeitskopie)
@@ -0,0 +1,67 @@
+! { dg-do run }
+! { dg-options "-fcheck=bounds" }
+! { dg-shouldfail "Array bounds mismatch" }
+!
+! Test that pr72832 is fixed now.
+! Contributed by Daan van Vugt
+
+program allocate_source
+ type :: t
+ integer :: i
+ end type t
+ type, extends(t) :: tt
+ end type tt
+
+ call test_type()
+ call test_class_correct()
+ call test_class_fail()
+
+contains
+
+subroutine test_class_correct()
+ class(t), allocatable, dimension(:) :: a, b
+ allocate(tt::a(1:2))
+ a(:)%i = [ 1,2 ]
+ if (size(a) /= 2) call abort()
+ if (any(a(:)%i /= [ 1,2])) call abort()
+
+ allocate(b(1:4), source=a(1))
+ if (size(b) /= 4) call abort()
+ if (any(b(:)%i /= [ 1,1,1,1])) call abort()
+ select type (b(1))
+ class is (tt)
+ continue
+ class default
+ call abort()
+ end select
+end subroutine
+
+subroutine test_class_fail()
+ class(t), allocatable, dimension(:) :: a, b
+ allocate(tt::a(1:2))
+ a(:)%i = [ 1,2 ]
+ if (size(a) /= 2) call abort()
+ if (any(a(:)%i /= [ 1,2])) call abort()
+
+ allocate(b(1:4), source=a) ! Fail expected: sizes do not conform
+ if (size(b) /= 4) call abort()
+ if (any(b(1:2)%i /= [ 1,2])) call abort()
+ select type (b(1))
+ class is (tt)
+ continue
+ class default
+ call abort()
+ end select
+end subroutine
+
+subroutine test_type()
+ type(t), allocatable, dimension(:) :: a, b
+ allocate(a(1:2))
+ if (size(a) /= 2) call abort()
+
+ allocate(b(1:4), source=a)
+ if (size(b) /= 4) call abort()
+end subroutine
+end program allocate_source
+
+
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: [Fortran, Patch, PR72832, v1] [6/7 Regression] [OOP] ALLOCATE with SOURCE fails to allocate requested dimensions
@ 2016-09-03 14:20 Dominique d'Humières
0 siblings, 0 replies; 6+ messages in thread
From: Dominique d'Humières @ 2016-09-03 14:20 UTC (permalink / raw)
To: Andre Vehreschild; +Cc: fortran, gcc-patches
Hi Andre,
The patch works as expected. As said on IRC, IMO the dejagnu directives in gfortran.dg/allocate_with_source_23.f03
+! { dg-do run { xfail *-*-* } }
+! { dg-options "-fcheck=bounds" }
should be replaced with
+! { dg-do run }
+! { dg-options "-fcheck=bounds" }
+! { dg-shouldfail "Array reference out of bounds" }
(see, e.g., gfortran.dg/assumed_rank_3.f90) which is what I have tested.
Thanks for the patch,
Dominique
^ permalink raw reply [flat|nested] 6+ messages in thread
end of thread, other threads:[~2016-10-23 11:57 UTC | newest]
Thread overview: 6+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2016-09-02 7:59 [Fortran, Patch, PR72832, v1] [6/7 Regression] [OOP] ALLOCATE with SOURCE fails to allocate requested dimensions Andre Vehreschild
2016-10-12 9:50 ` PING! " Andre Vehreschild
2016-10-12 17:18 ` Steve Kargl
2016-10-13 8:53 ` Andre Vehreschild
2016-10-23 11:57 ` Andre Vehreschild
2016-09-03 14:20 Dominique d'Humières
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).