| Message ID | 1291762879-23555-1-git-send-email-sebpop@gmail.com |
|---|---|
| State | New |
| Headers | show |
On Tue, Dec 7, 2010 at 17:01, Sebastian Pop <sebpop@gmail.com> wrote: > Hi, > > This is a slightly modified version of the previous patch: apparently > force_gimple_operand does not create the MODIFY_EXPR when the > expression is already simple, so this time we create the MODIFY_EXPR > before calling force_gimple_operand. This fixes one more bug. > > Ok for trunk after regstrap on amd64-linux? This patch passed regstrap. It also fixes http://gcc.gnu.org/PR45231 Sebastian
On Tue, Dec 07, 2010 at 05:01:19PM -0600, Sebastian Pop wrote: > Hi, > > This is a slightly modified version of the previous patch: apparently > force_gimple_operand does not create the MODIFY_EXPR when the > expression is already simple, so this time we create the MODIFY_EXPR > before calling force_gimple_operand. This fixes one more bug. > > Ok for trunk after regstrap on amd64-linux? Sebastian, Testresults for this patch on current gcc trunk under x86_64-apple-darwin10 are at http://gcc.gnu.org/ml/gcc-testresults/2010-12/msg00666.html. Both PR45230 and PR45370 are fixed at -m32/-m64. Thanks. Jack > > Thanks, > Sebastian > > 2010-12-07 Sebastian Pop <sebastian.pop@amd.com> > > PR tree-optimization/45230 > PR tree-optimization/45370 > * sese.c (rename_uses): Call recompute_tree_invariant_for_addr_expr > only on the RHS of a GIMPLE_ASSIGN. Assign the new expression to > a new variable before renaming. > > * gcc.dg/graphite/id-pr45230-1.c: New. > * gfortran.dg/graphite/id-pr45370.f90: New. > --- > gcc/ChangeLog | 8 ++ > gcc/sese.c | 15 ++- > gcc/testsuite/ChangeLog | 7 + > gcc/testsuite/gcc.dg/graphite/id-pr45230-1.c | 140 +++++++++++++++++++++ > gcc/testsuite/gfortran.dg/graphite/id-pr45370.f90 | 103 +++++++++++++++ > 5 files changed, 267 insertions(+), 6 deletions(-) > create mode 100644 gcc/testsuite/gcc.dg/graphite/id-pr45230-1.c > create mode 100644 gcc/testsuite/gfortran.dg/graphite/id-pr45370.f90 > > diff --git a/gcc/ChangeLog b/gcc/ChangeLog > index ff52686..77eea2d 100644 > --- a/gcc/ChangeLog > +++ b/gcc/ChangeLog > @@ -1,3 +1,11 @@ > +2010-12-07 Sebastian Pop <sebastian.pop@amd.com> > + > + PR tree-optimization/45230 > + PR tree-optimization/45370 > + * sese.c (rename_uses): Call recompute_tree_invariant_for_addr_expr > + only on the RHS of a GIMPLE_ASSIGN. Assign the new expression to > + a new variable before renaming. > + > 2010-12-07 Paul Koning <ni1d@arrl.net> > > * config/pdp11/pdp11.c (TARGET_ASM_FUNCTION_SECTION): Define. > diff --git a/gcc/sese.c b/gcc/sese.c > index 65f8556..7741bdf 100644 > --- a/gcc/sese.c > +++ b/gcc/sese.c > @@ -492,7 +492,8 @@ rename_uses (gimple copy, htab_t rename_map, gimple_stmt_iterator *gsi_tgt, > FOR_EACH_SSA_USE_OPERAND (use_p, copy, op_iter, SSA_OP_ALL_USES) > { > tree old_name = USE_FROM_PTR (use_p); > - tree new_expr, scev; > + tree type_old_name = TREE_TYPE (old_name); > + tree new_expr, scev, var; > gimple_seq stmts; > > if (TREE_CODE (old_name) != SSA_NAME > @@ -503,20 +504,20 @@ rename_uses (gimple copy, htab_t rename_map, gimple_stmt_iterator *gsi_tgt, > new_expr = get_rename (rename_map, old_name); > if (new_expr) > { > - tree type_old_name = TREE_TYPE (old_name); > tree type_new_expr = TREE_TYPE (new_expr); > > if (type_old_name != type_new_expr > || (TREE_CODE (new_expr) != SSA_NAME > && is_gimple_reg (old_name))) > { > - tree var = create_tmp_var (type_old_name, "var"); > + var = create_tmp_var (type_old_name, "var"); > > if (type_old_name != type_new_expr) > new_expr = fold_convert (type_old_name, new_expr); > > new_expr = build2 (MODIFY_EXPR, type_old_name, var, new_expr); > - new_expr = force_gimple_operand (new_expr, &stmts, true, NULL); > + new_expr = force_gimple_operand (new_expr, &stmts, true, > + NULL_TREE); > gsi_insert_seq_before (gsi_tgt, stmts, GSI_SAME_STMT); > } > > @@ -542,13 +543,15 @@ rename_uses (gimple copy, htab_t rename_map, gimple_stmt_iterator *gsi_tgt, > && !tree_contains_chrecs (new_expr, NULL)); > > /* Replace the old_name with the new_expr. */ > + var = create_tmp_var (type_old_name, "var"); > + new_expr = build2 (MODIFY_EXPR, type_old_name, var, new_expr); > new_expr = force_gimple_operand (unshare_expr (new_expr), &stmts, > true, NULL_TREE); > gsi_insert_seq_before (gsi_tgt, stmts, GSI_SAME_STMT); > replace_exp (use_p, new_expr); > > - > - if (TREE_CODE (new_expr) == INTEGER_CST) > + if (TREE_CODE (new_expr) == INTEGER_CST > + && gimple_code (copy) == GIMPLE_ASSIGN) > { > tree rhs = gimple_assign_rhs1 (copy); > > diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog > index 96275ed..71d73d6 100644 > --- a/gcc/testsuite/ChangeLog > +++ b/gcc/testsuite/ChangeLog > @@ -1,5 +1,12 @@ > 2010-12-07 Sebastian Pop <sebastian.pop@amd.com> > > + PR tree-optimization/45230 > + PR tree-optimization/45370 > + * gcc.dg/graphite/id-pr45230-1.c: New. > + * gfortran.dg/graphite/id-pr45370.f90: New. > + > +2010-12-07 Sebastian Pop <sebastian.pop@amd.com> > + > PR tree-optimization/44676 > * gcc.dg/graphite/id-pr44676.c: New. > > diff --git a/gcc/testsuite/gcc.dg/graphite/id-pr45230-1.c b/gcc/testsuite/gcc.dg/graphite/id-pr45230-1.c > new file mode 100644 > index 0000000..ba14fe5 > --- /dev/null > +++ b/gcc/testsuite/gcc.dg/graphite/id-pr45230-1.c > @@ -0,0 +1,140 @@ > +/* Copyright (C) 2002 Free Software Foundation. > + > + Test strncmp with various combinations of pointer alignments and lengths to > + make sure any optimizations in the library are correct. > + > + Written by Michael Meissner, March 9, 2002. */ > + > +#include <string.h> > +#include <stddef.h> > + > +#ifndef MAX_OFFSET > +#define MAX_OFFSET (sizeof (long long)) > +#endif > + > +#ifndef MAX_TEST > +#define MAX_TEST (8 * sizeof (long long)) > +#endif > + > +#ifndef MAX_EXTRA > +#define MAX_EXTRA (sizeof (long long)) > +#endif > + > +#define MAX_LENGTH (MAX_OFFSET + MAX_TEST + MAX_EXTRA) > + > +static union { > + unsigned char buf[MAX_LENGTH]; > + long long align_int; > + long double align_fp; > +} u1, u2; > + > +void > +test (const unsigned char *s1, const unsigned char *s2, size_t len, int expected) > +{ > + int value = strncmp ((char *) s1, (char *) s2, len); > + > + if (expected < 0 && value >= 0) > + __builtin_abort (); > + else if (expected == 0 && value != 0) > + __builtin_abort (); > + else if (expected > 0 && value <= 0) > + __builtin_abort (); > +} > + > +main () > +{ > + size_t off1, off2, len, i; > + unsigned char *buf1, *buf2; > + unsigned char *mod1, *mod2; > + unsigned char *p1, *p2; > + > + for (off1 = 0; off1 < MAX_OFFSET; off1++) > + for (off2 = 0; off2 < MAX_OFFSET; off2++) > + for (len = 0; len < MAX_TEST; len++) > + { > + p1 = u1.buf; > + for (i = 0; i < off1; i++) > + *p1++ = '\0'; > + > + buf1 = p1; > + for (i = 0; i < len; i++) > + *p1++ = 'a'; > + > + mod1 = p1; > + for (i = 0; i < MAX_EXTRA; i++) > + *p1++ = 'x'; > + > + p2 = u2.buf; > + for (i = 0; i < off2; i++) > + *p2++ = '\0'; > + > + buf2 = p2; > + for (i = 0; i < len; i++) > + *p2++ = 'a'; > + > + mod2 = p2; > + for (i = 0; i < MAX_EXTRA; i++) > + *p2++ = 'x'; > + > + mod1[0] = '\0'; > + mod2[0] = '\0'; > + test (buf1, buf2, MAX_LENGTH, 0); > + test (buf1, buf2, len, 0); > + > + mod1[0] = 'a'; > + mod1[1] = '\0'; > + mod2[0] = '\0'; > + test (buf1, buf2, MAX_LENGTH, +1); > + test (buf1, buf2, len, 0); > + > + mod1[0] = '\0'; > + mod2[0] = 'a'; > + mod2[1] = '\0'; > + test (buf1, buf2, MAX_LENGTH, -1); > + test (buf1, buf2, len, 0); > + > + mod1[0] = 'b'; > + mod1[1] = '\0'; > + mod2[0] = 'c'; > + mod2[1] = '\0'; > + test (buf1, buf2, MAX_LENGTH, -1); > + test (buf1, buf2, len, 0); > + > + mod1[0] = 'c'; > + mod1[1] = '\0'; > + mod2[0] = 'b'; > + mod2[1] = '\0'; > + test (buf1, buf2, MAX_LENGTH, +1); > + test (buf1, buf2, len, 0); > + > + mod1[0] = 'b'; > + mod1[1] = '\0'; > + mod2[0] = (unsigned char)'\251'; > + mod2[1] = '\0'; > + test (buf1, buf2, MAX_LENGTH, -1); > + test (buf1, buf2, len, 0); > + > + mod1[0] = (unsigned char)'\251'; > + mod1[1] = '\0'; > + mod2[0] = 'b'; > + mod2[1] = '\0'; > + test (buf1, buf2, MAX_LENGTH, +1); > + test (buf1, buf2, len, 0); > + > + mod1[0] = (unsigned char)'\251'; > + mod1[1] = '\0'; > + mod2[0] = (unsigned char)'\252'; > + mod2[1] = '\0'; > + test (buf1, buf2, MAX_LENGTH, -1); > + test (buf1, buf2, len, 0); > + > + mod1[0] = (unsigned char)'\252'; > + mod1[1] = '\0'; > + mod2[0] = (unsigned char)'\251'; > + mod2[1] = '\0'; > + test (buf1, buf2, MAX_LENGTH, +1); > + test (buf1, buf2, len, 0); > + } > + > + __builtin_exit (0); > +} > diff --git a/gcc/testsuite/gfortran.dg/graphite/id-pr45370.f90 b/gcc/testsuite/gfortran.dg/graphite/id-pr45370.f90 > new file mode 100644 > index 0000000..e96d755 > --- /dev/null > +++ b/gcc/testsuite/gfortran.dg/graphite/id-pr45370.f90 > @@ -0,0 +1,103 @@ > +! { dg-do run } > +! Test the fix for PRs29396, 29606, 30625 and 30871, in which pointers > +! to arrays with subreferences did not work. > +! > + type :: t > + real :: r > + integer :: i > + character(3) :: chr > + end type t > + > + type :: t2 > + real :: r(2, 2) > + integer :: i > + character(3) :: chr > + end type t2 > + > + type :: s > + type(t), pointer :: t(:) > + end type s > + > + integer, parameter :: sh(2) = (/2,2/) > + real, parameter :: a1(2,2) = reshape ((/1.0,2.0,3.0,4.0/),sh) > + real, parameter :: a2(2,2) = reshape ((/5.0,6.0,7.0,8.0/),sh) > + > + type(t), target :: tar1(2) = (/t(1.0, 2, "abc"), t(3.0, 4, "efg")/) > + character(4), target :: tar2(2) = (/"abcd","efgh"/) > + type(s), target :: tar3 > + character(2), target :: tar4(2) = (/"ab","cd"/) > + type(t2), target :: tar5(2) = (/t2(a1, 2, "abc"), t2(a2, 4, "efg")/) > + > + integer, pointer :: ptr(:) > + character(2), pointer :: ptr2(:) > + real, pointer :: ptr3(:) > + > +!_______________component subreference___________ > + ptr => tar1%i > + ptr = ptr + 1 ! check the scalarizer is OK > + > + if (any (ptr .ne. (/3, 5/))) call abort () > + if (any ((/ptr(1), ptr(2)/) .ne. (/3, 5/))) call abort () > + if (any (tar1%i .ne. (/3, 5/))) call abort () > + > +! Make sure that the other components are not touched. > + if (any (tar1%r .ne. (/1.0, 3.0/))) call abort () > + if (any (tar1%chr .ne. (/"abc", "efg"/))) call abort () > + > +! Check that the pointer is passed correctly as an actual argument. > + call foo (ptr) > + if (any (tar1%i .ne. (/2, 4/))) call abort () > + > +! And that dummy pointers are OK too. > + call bar (ptr) > + if (any (tar1%i .ne. (/101, 103/))) call abort () > + > +!_______________substring subreference___________ > + ptr2 => tar2(:)(2:3) > + ptr2 = ptr2(:)(2:2)//"z" ! again, check the scalarizer > + > + if (any (ptr2 .ne. (/"cz", "gz"/))) call abort () > + if (any ((/ptr2(1), ptr2(2)/) .ne. (/"cz", "gz"/))) call abort () > + if (any (tar2 .ne. (/"aczd", "egzh"/))) call abort () > + > +!_______________substring component subreference___________ > + ptr2 => tar1(:)%chr(1:2) > + ptr2 = ptr2(:)(2:2)//"q" ! yet again, check the scalarizer > + if (any (ptr2 .ne. (/"bq","fq"/))) call abort () > + if (any (tar1%chr .ne. (/"bqc","fqg"/))) call abort () > + > +!_______________trailing array element subreference___________ > + ptr3 => tar5%r(1,2) > + ptr3 = (/99.0, 999.0/) > + if (any (tar5(1)%r .ne. reshape ((/1.0,2.0,99.0,4.0/), sh))) call abort () > + if (any (tar5(2)%r .ne. reshape ((/5.0,6.0,999.0,8.0/), sh))) call abort () > + > +!_______________forall assignment___________ > + ptr2 => tar2(:)(1:2) > + forall (i = 1:2) ptr2(i)(1:1) = "z" > + if (any (tar2 .ne. (/"zczd", "zgzh"/))) call abort () > + > +!_______________something more complicated___________ > + tar3%t => tar1 > + ptr3 => tar3%t%r > + ptr3 = cos (ptr3) > + if (any (abs(ptr3 - (/cos(1.0_4), cos(3.0_4)/)) >= epsilon(1.0_4))) call abort () > + > + ptr2 => tar3%t(:)%chr(2:3) > + ptr2 = " x" > + if (any (tar1%chr .ne. (/"b x", "f x"/))) call abort () > + > +!_______________check non-subref works still___________ > + ptr2 => tar4 > + if (any (ptr2 .ne. (/"ab","cd"/))) call abort () > + > +contains > + subroutine foo (arg) > + integer :: arg(:) > + arg = arg - 1 > + end subroutine > + subroutine bar (arg) > + integer, pointer :: arg(:) > + arg = arg + 99 > + end subroutine > +end > -- > 1.7.1
diff --git a/gcc/ChangeLog b/gcc/ChangeLog index ff52686..77eea2d 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,11 @@ +2010-12-07 Sebastian Pop <sebastian.pop@amd.com> + + PR tree-optimization/45230 + PR tree-optimization/45370 + * sese.c (rename_uses): Call recompute_tree_invariant_for_addr_expr + only on the RHS of a GIMPLE_ASSIGN. Assign the new expression to + a new variable before renaming. + 2010-12-07 Paul Koning <ni1d@arrl.net> * config/pdp11/pdp11.c (TARGET_ASM_FUNCTION_SECTION): Define. diff --git a/gcc/sese.c b/gcc/sese.c index 65f8556..7741bdf 100644 --- a/gcc/sese.c +++ b/gcc/sese.c @@ -492,7 +492,8 @@ rename_uses (gimple copy, htab_t rename_map, gimple_stmt_iterator *gsi_tgt, FOR_EACH_SSA_USE_OPERAND (use_p, copy, op_iter, SSA_OP_ALL_USES) { tree old_name = USE_FROM_PTR (use_p); - tree new_expr, scev; + tree type_old_name = TREE_TYPE (old_name); + tree new_expr, scev, var; gimple_seq stmts; if (TREE_CODE (old_name) != SSA_NAME @@ -503,20 +504,20 @@ rename_uses (gimple copy, htab_t rename_map, gimple_stmt_iterator *gsi_tgt, new_expr = get_rename (rename_map, old_name); if (new_expr) { - tree type_old_name = TREE_TYPE (old_name); tree type_new_expr = TREE_TYPE (new_expr); if (type_old_name != type_new_expr || (TREE_CODE (new_expr) != SSA_NAME && is_gimple_reg (old_name))) { - tree var = create_tmp_var (type_old_name, "var"); + var = create_tmp_var (type_old_name, "var"); if (type_old_name != type_new_expr) new_expr = fold_convert (type_old_name, new_expr); new_expr = build2 (MODIFY_EXPR, type_old_name, var, new_expr); - new_expr = force_gimple_operand (new_expr, &stmts, true, NULL); + new_expr = force_gimple_operand (new_expr, &stmts, true, + NULL_TREE); gsi_insert_seq_before (gsi_tgt, stmts, GSI_SAME_STMT); } @@ -542,13 +543,15 @@ rename_uses (gimple copy, htab_t rename_map, gimple_stmt_iterator *gsi_tgt, && !tree_contains_chrecs (new_expr, NULL)); /* Replace the old_name with the new_expr. */ + var = create_tmp_var (type_old_name, "var"); + new_expr = build2 (MODIFY_EXPR, type_old_name, var, new_expr); new_expr = force_gimple_operand (unshare_expr (new_expr), &stmts, true, NULL_TREE); gsi_insert_seq_before (gsi_tgt, stmts, GSI_SAME_STMT); replace_exp (use_p, new_expr); - - if (TREE_CODE (new_expr) == INTEGER_CST) + if (TREE_CODE (new_expr) == INTEGER_CST + && gimple_code (copy) == GIMPLE_ASSIGN) { tree rhs = gimple_assign_rhs1 (copy); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 96275ed..71d73d6 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,12 @@ 2010-12-07 Sebastian Pop <sebastian.pop@amd.com> + PR tree-optimization/45230 + PR tree-optimization/45370 + * gcc.dg/graphite/id-pr45230-1.c: New. + * gfortran.dg/graphite/id-pr45370.f90: New. + +2010-12-07 Sebastian Pop <sebastian.pop@amd.com> + PR tree-optimization/44676 * gcc.dg/graphite/id-pr44676.c: New. diff --git a/gcc/testsuite/gcc.dg/graphite/id-pr45230-1.c b/gcc/testsuite/gcc.dg/graphite/id-pr45230-1.c new file mode 100644 index 0000000..ba14fe5 --- /dev/null +++ b/gcc/testsuite/gcc.dg/graphite/id-pr45230-1.c @@ -0,0 +1,140 @@ +/* Copyright (C) 2002 Free Software Foundation. + + Test strncmp with various combinations of pointer alignments and lengths to + make sure any optimizations in the library are correct. + + Written by Michael Meissner, March 9, 2002. */ + +#include <string.h> +#include <stddef.h> + +#ifndef MAX_OFFSET +#define MAX_OFFSET (sizeof (long long)) +#endif + +#ifndef MAX_TEST +#define MAX_TEST (8 * sizeof (long long)) +#endif + +#ifndef MAX_EXTRA +#define MAX_EXTRA (sizeof (long long)) +#endif + +#define MAX_LENGTH (MAX_OFFSET + MAX_TEST + MAX_EXTRA) + +static union { + unsigned char buf[MAX_LENGTH]; + long long align_int; + long double align_fp; +} u1, u2; + +void +test (const unsigned char *s1, const unsigned char *s2, size_t len, int expected) +{ + int value = strncmp ((char *) s1, (char *) s2, len); + + if (expected < 0 && value >= 0) + __builtin_abort (); + else if (expected == 0 && value != 0) + __builtin_abort (); + else if (expected > 0 && value <= 0) + __builtin_abort (); +} + +main () +{ + size_t off1, off2, len, i; + unsigned char *buf1, *buf2; + unsigned char *mod1, *mod2; + unsigned char *p1, *p2; + + for (off1 = 0; off1 < MAX_OFFSET; off1++) + for (off2 = 0; off2 < MAX_OFFSET; off2++) + for (len = 0; len < MAX_TEST; len++) + { + p1 = u1.buf; + for (i = 0; i < off1; i++) + *p1++ = '\0'; + + buf1 = p1; + for (i = 0; i < len; i++) + *p1++ = 'a'; + + mod1 = p1; + for (i = 0; i < MAX_EXTRA; i++) + *p1++ = 'x'; + + p2 = u2.buf; + for (i = 0; i < off2; i++) + *p2++ = '\0'; + + buf2 = p2; + for (i = 0; i < len; i++) + *p2++ = 'a'; + + mod2 = p2; + for (i = 0; i < MAX_EXTRA; i++) + *p2++ = 'x'; + + mod1[0] = '\0'; + mod2[0] = '\0'; + test (buf1, buf2, MAX_LENGTH, 0); + test (buf1, buf2, len, 0); + + mod1[0] = 'a'; + mod1[1] = '\0'; + mod2[0] = '\0'; + test (buf1, buf2, MAX_LENGTH, +1); + test (buf1, buf2, len, 0); + + mod1[0] = '\0'; + mod2[0] = 'a'; + mod2[1] = '\0'; + test (buf1, buf2, MAX_LENGTH, -1); + test (buf1, buf2, len, 0); + + mod1[0] = 'b'; + mod1[1] = '\0'; + mod2[0] = 'c'; + mod2[1] = '\0'; + test (buf1, buf2, MAX_LENGTH, -1); + test (buf1, buf2, len, 0); + + mod1[0] = 'c'; + mod1[1] = '\0'; + mod2[0] = 'b'; + mod2[1] = '\0'; + test (buf1, buf2, MAX_LENGTH, +1); + test (buf1, buf2, len, 0); + + mod1[0] = 'b'; + mod1[1] = '\0'; + mod2[0] = (unsigned char)'\251'; + mod2[1] = '\0'; + test (buf1, buf2, MAX_LENGTH, -1); + test (buf1, buf2, len, 0); + + mod1[0] = (unsigned char)'\251'; + mod1[1] = '\0'; + mod2[0] = 'b'; + mod2[1] = '\0'; + test (buf1, buf2, MAX_LENGTH, +1); + test (buf1, buf2, len, 0); + + mod1[0] = (unsigned char)'\251'; + mod1[1] = '\0'; + mod2[0] = (unsigned char)'\252'; + mod2[1] = '\0'; + test (buf1, buf2, MAX_LENGTH, -1); + test (buf1, buf2, len, 0); + + mod1[0] = (unsigned char)'\252'; + mod1[1] = '\0'; + mod2[0] = (unsigned char)'\251'; + mod2[1] = '\0'; + test (buf1, buf2, MAX_LENGTH, +1); + test (buf1, buf2, len, 0); + } + + __builtin_exit (0); +} diff --git a/gcc/testsuite/gfortran.dg/graphite/id-pr45370.f90 b/gcc/testsuite/gfortran.dg/graphite/id-pr45370.f90 new file mode 100644 index 0000000..e96d755 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/graphite/id-pr45370.f90 @@ -0,0 +1,103 @@ +! { dg-do run } +! Test the fix for PRs29396, 29606, 30625 and 30871, in which pointers +! to arrays with subreferences did not work. +! + type :: t + real :: r + integer :: i + character(3) :: chr + end type t + + type :: t2 + real :: r(2, 2) + integer :: i + character(3) :: chr + end type t2 + + type :: s + type(t), pointer :: t(:) + end type s + + integer, parameter :: sh(2) = (/2,2/) + real, parameter :: a1(2,2) = reshape ((/1.0,2.0,3.0,4.0/),sh) + real, parameter :: a2(2,2) = reshape ((/5.0,6.0,7.0,8.0/),sh) + + type(t), target :: tar1(2) = (/t(1.0, 2, "abc"), t(3.0, 4, "efg")/) + character(4), target :: tar2(2) = (/"abcd","efgh"/) + type(s), target :: tar3 + character(2), target :: tar4(2) = (/"ab","cd"/) + type(t2), target :: tar5(2) = (/t2(a1, 2, "abc"), t2(a2, 4, "efg")/) + + integer, pointer :: ptr(:) + character(2), pointer :: ptr2(:) + real, pointer :: ptr3(:) + +!_______________component subreference___________ + ptr => tar1%i + ptr = ptr + 1 ! check the scalarizer is OK + + if (any (ptr .ne. (/3, 5/))) call abort () + if (any ((/ptr(1), ptr(2)/) .ne. (/3, 5/))) call abort () + if (any (tar1%i .ne. (/3, 5/))) call abort () + +! Make sure that the other components are not touched. + if (any (tar1%r .ne. (/1.0, 3.0/))) call abort () + if (any (tar1%chr .ne. (/"abc", "efg"/))) call abort () + +! Check that the pointer is passed correctly as an actual argument. + call foo (ptr) + if (any (tar1%i .ne. (/2, 4/))) call abort () + +! And that dummy pointers are OK too. + call bar (ptr) + if (any (tar1%i .ne. (/101, 103/))) call abort () + +!_______________substring subreference___________ + ptr2 => tar2(:)(2:3) + ptr2 = ptr2(:)(2:2)//"z" ! again, check the scalarizer + + if (any (ptr2 .ne. (/"cz", "gz"/))) call abort () + if (any ((/ptr2(1), ptr2(2)/) .ne. (/"cz", "gz"/))) call abort () + if (any (tar2 .ne. (/"aczd", "egzh"/))) call abort () + +!_______________substring component subreference___________ + ptr2 => tar1(:)%chr(1:2) + ptr2 = ptr2(:)(2:2)//"q" ! yet again, check the scalarizer + if (any (ptr2 .ne. (/"bq","fq"/))) call abort () + if (any (tar1%chr .ne. (/"bqc","fqg"/))) call abort () + +!_______________trailing array element subreference___________ + ptr3 => tar5%r(1,2) + ptr3 = (/99.0, 999.0/) + if (any (tar5(1)%r .ne. reshape ((/1.0,2.0,99.0,4.0/), sh))) call abort () + if (any (tar5(2)%r .ne. reshape ((/5.0,6.0,999.0,8.0/), sh))) call abort () + +!_______________forall assignment___________ + ptr2 => tar2(:)(1:2) + forall (i = 1:2) ptr2(i)(1:1) = "z" + if (any (tar2 .ne. (/"zczd", "zgzh"/))) call abort () + +!_______________something more complicated___________ + tar3%t => tar1 + ptr3 => tar3%t%r + ptr3 = cos (ptr3) + if (any (abs(ptr3 - (/cos(1.0_4), cos(3.0_4)/)) >= epsilon(1.0_4))) call abort () + + ptr2 => tar3%t(:)%chr(2:3) + ptr2 = " x" + if (any (tar1%chr .ne. (/"b x", "f x"/))) call abort () + +!_______________check non-subref works still___________ + ptr2 => tar4 + if (any (ptr2 .ne. (/"ab","cd"/))) call abort () + +contains + subroutine foo (arg) + integer :: arg(:) + arg = arg - 1 + end subroutine + subroutine bar (arg) + integer, pointer :: arg(:) + arg = arg + 99 + end subroutine +end