aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog12
-rw-r--r--gcc/fortran/iresolve.c37
-rw-r--r--gcc/fortran/trans-array.c4
-rw-r--r--gcc/testsuite/ChangeLog12
-rw-r--r--gcc/testsuite/gfortran.dg/char_associated_1.f908
-rw-r--r--gcc/testsuite/gfortran.dg/char_cshift_1.f9040
-rw-r--r--gcc/testsuite/gfortran.dg/char_cshift_2.f9045
-rw-r--r--gcc/testsuite/gfortran.dg/char_eoshift_1.f9050
-rw-r--r--gcc/testsuite/gfortran.dg/char_eoshift_2.f9057
-rw-r--r--gcc/testsuite/gfortran.dg/char_eoshift_3.f9054
-rw-r--r--gcc/testsuite/gfortran.dg/char_eoshift_4.f9061
-rw-r--r--gcc/testsuite/gfortran.dg/char_pack_1.f9059
-rw-r--r--gcc/testsuite/gfortran.dg/char_pack_2.f9053
-rw-r--r--gcc/testsuite/gfortran.dg/char_reshape_1.f9043
-rw-r--r--gcc/testsuite/gfortran.dg/char_spread_1.f9032
-rw-r--r--gcc/testsuite/gfortran.dg/char_transpose_1.f9029
-rw-r--r--gcc/testsuite/gfortran.dg/char_unpack_1.f9044
-rw-r--r--gcc/testsuite/gfortran.dg/char_unpack_2.f9040
18 files changed, 664 insertions, 16 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4378597..02f8f3f 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2005-09-13 Richard Sandiford <richard@codesourcery.com>
+
+ PR target/19269
+ * iresolve.c (gfc_resolve_cshift, gfc_resolve_eoshift)
+ (gfc_resolve_pack, gfc_resolve_reshape, gfc_resolve_spread)
+ (gfc_resolve_transpose, gfc_resolve_unpack): Add "_char" to the name
+ for character-based operations.
+ (gfc_resolve_pack): Remove ATTRIBUTE_UNUSED from array argument.
+ (gfc_resolve_unpack): Copy the whole typespec from the vector.
+ * trans-array.c (gfc_conv_expr_descriptor): In the EXPR_FUNCTION
+ case, get the string length from the scalarization state.
+
2005-09-14 Francois-Xavier Coudert <coudert@clipper.ens.fr>
* Make-lang.in: Change targets prefixes from f95 to fortran.
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index ef43946..ed043a6 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -403,7 +403,8 @@ gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
gfc_convert_type_warn (dim, &shift->ts, 2, 0);
}
f->value.function.name =
- gfc_get_string (PREFIX("cshift%d_%d"), n, shift->ts.kind);
+ gfc_get_string (PREFIX("cshift%d_%d%s"), n, shift->ts.kind,
+ array->ts.type == BT_CHARACTER ? "_char" : "");
}
@@ -503,7 +504,8 @@ gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
}
f->value.function.name =
- gfc_get_string (PREFIX("eoshift%d_%d"), n, shift->ts.kind);
+ gfc_get_string (PREFIX("eoshift%d_%d%s"), n, shift->ts.kind,
+ array->ts.type == BT_CHARACTER ? "_char" : "");
}
@@ -1083,16 +1085,16 @@ gfc_resolve_not (gfc_expr * f, gfc_expr * i)
void
-gfc_resolve_pack (gfc_expr * f,
- gfc_expr * array ATTRIBUTE_UNUSED,
- gfc_expr * mask,
+gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
gfc_expr * vector ATTRIBUTE_UNUSED)
{
f->ts = array->ts;
f->rank = 1;
if (mask->rank != 0)
- f->value.function.name = PREFIX("pack");
+ f->value.function.name = (array->ts.type == BT_CHARACTER
+ ? PREFIX("pack_char")
+ : PREFIX("pack"));
else
{
/* We convert mask to default logical only in the scalar case.
@@ -1107,7 +1109,9 @@ gfc_resolve_pack (gfc_expr * f,
gfc_convert_type (mask, &ts, 2);
}
- f->value.function.name = PREFIX("pack_s");
+ f->value.function.name = (array->ts.type == BT_CHARACTER
+ ? PREFIX("pack_s_char")
+ : PREFIX("pack_s"));
}
}
@@ -1214,7 +1218,9 @@ gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
break;
default:
- f->value.function.name = PREFIX("reshape");
+ f->value.function.name = (source->ts.type == BT_CHARACTER
+ ? PREFIX("reshape_char")
+ : PREFIX("reshape"));
break;
}
@@ -1362,7 +1368,9 @@ gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
{
f->ts = source->ts;
f->rank = source->rank + 1;
- f->value.function.name = PREFIX("spread");
+ f->value.function.name = (source->ts.type == BT_CHARACTER
+ ? PREFIX("spread_char")
+ : PREFIX("spread"));
gfc_resolve_dim_arg (dim);
gfc_resolve_index (ncopies, 1);
@@ -1542,7 +1550,10 @@ gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
break;
default:
- f->value.function.name = PREFIX("transpose");
+ f->value.function.name = (matrix->ts.type == BT_CHARACTER
+ ? PREFIX("transpose_char")
+ : PREFIX("transpose"));
+ break;
}
}
@@ -1601,12 +1612,12 @@ void
gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
gfc_expr * field ATTRIBUTE_UNUSED)
{
- f->ts.type = vector->ts.type;
- f->ts.kind = vector->ts.kind;
+ f->ts = vector->ts;
f->rank = mask->rank;
f->value.function.name =
- gfc_get_string (PREFIX("unpack%d"), field->rank > 0 ? 1 : 0);
+ gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
+ vector->ts.type == BT_CHARACTER ? "_char" : "");
}
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 552bae6..a7a1c55 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3883,9 +3883,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
else if (expr->expr_type == EXPR_FUNCTION)
{
desc = info->descriptor;
-
- if (expr->ts.type == BT_CHARACTER)
- se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
+ se->string_length = ss->string_length;
}
else
{
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 26919da..a909f30 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,15 @@
+2005-09-13 Richard Sandiford <richard@codesourcery.com>
+
+ PR target/19269
+ * gfortran.dg/char_associated_1.f90, gfortran.dg/char_cshift_1.f90,
+ * gfortran.dg/char_cshift_2.f90, gfortran.dg/char_eoshift_1.f90,
+ * gfortran.dg/char_eoshift_2.f90, gfortran.dg/char_eoshift_3.f90,
+ * gfortran.dg/char_eoshift_4.f90, gfortran.dg/char_pack_1.f90,
+ * gfortran.dg/char_pack_2.f90, gfortran.dg/char_reshape_1.f90,
+ * gfortran.dg/char_spread_1.f90, gfortran.dg/char_transpoe_1.f90,
+ * gfortran.dg/char_unpack_1.f90, gfortran.dg/char_unpack_2.f90: New
+ tests.
+
2005-09-12 Mark Mitchell <mark@codesourcery.com>
PR c++/23841
diff --git a/gcc/testsuite/gfortran.dg/char_associated_1.f90 b/gcc/testsuite/gfortran.dg/char_associated_1.f90
new file mode 100644
index 0000000..f38f273
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_associated_1.f90
@@ -0,0 +1,8 @@
+! Check that associated works correctly for character arrays.
+! { dg-do run }
+program main
+ character (len = 5), dimension (:), pointer :: ptr
+ character (len = 5), dimension (2), target :: a = (/ 'abcde', 'fghij' /)
+ ptr => a
+ if (.not. associated (ptr, a)) call abort
+end program main
diff --git a/gcc/testsuite/gfortran.dg/char_cshift_1.f90 b/gcc/testsuite/gfortran.dg/char_cshift_1.f90
new file mode 100644
index 0000000..7ba61e7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_cshift_1.f90
@@ -0,0 +1,40 @@
+! Test cshift0 for character arrays.
+! { dg-do run }
+program main
+ implicit none
+ integer, parameter :: n1 = 2, n2 = 3, n3 = 4, slen = 3
+ character (len = slen), dimension (n1, n2, n3) :: a
+ integer (kind = 1) :: shift1 = 3
+ integer (kind = 2) :: shift2 = 4
+ integer (kind = 4) :: shift3 = 5
+ integer (kind = 8) :: shift4 = 6
+ integer :: i1, i2, i3
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2, i3) = 'ab'(i1:i1) // 'cde'(i2:i2) // 'fghi'(i3:i3)
+ end do
+ end do
+ end do
+
+ call test (cshift (a, shift1, 1), int (shift1), 0, 0)
+ call test (cshift (a, shift2, 2), 0, int (shift2), 0)
+ call test (cshift (a, shift3, 3), 0, 0, int (shift3))
+ call test (cshift (a, shift4, 3), 0, 0, int (shift4))
+contains
+ subroutine test (b, d1, d2, d3)
+ character (len = slen), dimension (n1, n2, n3) :: b
+ integer :: d1, d2, d3
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (b (i1, i2, i3) .ne. a (mod (d1 + i1 - 1, n1) + 1, &
+ mod (d2 + i2 - 1, n2) + 1, &
+ mod (d3 + i3 - 1, n3) + 1)) call abort
+ end do
+ end do
+ end do
+ end subroutine test
+end program main
diff --git a/gcc/testsuite/gfortran.dg/char_cshift_2.f90 b/gcc/testsuite/gfortran.dg/char_cshift_2.f90
new file mode 100644
index 0000000..89d452f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_cshift_2.f90
@@ -0,0 +1,45 @@
+! Test cshift1 for character arrays.
+! { dg-do run }
+program main
+ implicit none
+ integer, parameter :: n1 = 2, n2 = 3, n3 = 4, slen = 3
+ character (len = slen), dimension (n1, n2, n3) :: a
+ integer (kind = 1), dimension (2, 4) :: shift1
+ integer (kind = 2), dimension (2, 4) :: shift2
+ integer (kind = 4), dimension (2, 4) :: shift3
+ integer (kind = 8), dimension (2, 4) :: shift4
+ integer :: i1, i2, i3
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2, i3) = 'ab'(i1:i1) // 'cde'(i2:i2) // 'fghi'(i3:i3)
+ end do
+ end do
+ end do
+
+ shift1 (1, :) = (/ 4, 11, 19, 20 /)
+ shift1 (2, :) = (/ 55, 5, 1, 2 /)
+ shift2 = shift1
+ shift3 = shift1
+ shift4 = shift1
+
+ call test (cshift (a, shift1, 2))
+ call test (cshift (a, shift2, 2))
+ call test (cshift (a, shift3, 2))
+ call test (cshift (a, shift4, 2))
+contains
+ subroutine test (b)
+ character (len = slen), dimension (n1, n2, n3) :: b
+ integer :: i2p
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ i2p = mod (shift1 (i1, i3) + i2 - 1, n2) + 1
+ if (b (i1, i2, i3) .ne. a (i1, i2p, i3)) call abort
+ end do
+ end do
+ end do
+ end subroutine test
+end program main
diff --git a/gcc/testsuite/gfortran.dg/char_eoshift_1.f90 b/gcc/testsuite/gfortran.dg/char_eoshift_1.f90
new file mode 100644
index 0000000..ba51fa1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_eoshift_1.f90
@@ -0,0 +1,50 @@
+! Test eoshift0 for character arrays.
+! { dg-do run }
+program main
+ implicit none
+ integer, parameter :: n1 = 6, n2 = 5, n3 = 4, slen = 3
+ character (len = slen), dimension (n1, n2, n3) :: a
+ character (len = slen) :: filler
+ integer (kind = 1) :: shift1 = 4
+ integer (kind = 2) :: shift2 = 2
+ integer (kind = 4) :: shift3 = 3
+ integer (kind = 8) :: shift4 = 1
+ integer :: i1, i2, i3
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2, i3) = 'abcdef'(i1:i1) // 'ghijk'(i2:i2) // 'lmno'(i3:i3)
+ end do
+ end do
+ end do
+
+ call test (eoshift (a, shift1, 'foo', 1), int (shift1), 0, 0, 'foo')
+ call test (eoshift (a, shift2, 'foo', 2), 0, int (shift2), 0, 'foo')
+ call test (eoshift (a, shift3, 'foo', 2), 0, int (shift3), 0, 'foo')
+ call test (eoshift (a, shift4, 'foo', 3), 0, 0, int (shift4), 'foo')
+
+ filler = ''
+ call test (eoshift (a, shift1, dim = 1), int (shift1), 0, 0, filler)
+ call test (eoshift (a, shift2, dim = 2), 0, int (shift2), 0, filler)
+ call test (eoshift (a, shift3, dim = 2), 0, int (shift3), 0, filler)
+ call test (eoshift (a, shift4, dim = 3), 0, 0, int (shift4), filler)
+contains
+ subroutine test (b, d1, d2, d3, filler)
+ character (len = slen), dimension (n1, n2, n3) :: b
+ character (len = slen) :: filler
+ integer :: d1, d2, d3
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (i1 + d1 .gt. n1 .or. i2 + d2 .gt. n2 .or. i3 + d3 .gt. n3) then
+ if (b (i1, i2, i3) .ne. filler) call abort
+ else
+ if (b (i1, i2, i3) .ne. a (i1 + d1, i2 + d2, i3 + d3)) call abort
+ end if
+ end do
+ end do
+ end do
+ end subroutine test
+end program main
diff --git a/gcc/testsuite/gfortran.dg/char_eoshift_2.f90 b/gcc/testsuite/gfortran.dg/char_eoshift_2.f90
new file mode 100644
index 0000000..bdb654c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_eoshift_2.f90
@@ -0,0 +1,57 @@
+! Test eoshift1 for character arrays.
+! { dg-do run }
+program main
+ implicit none
+ integer, parameter :: n1 = 2, n2 = 5, n3 = 4, slen = 3
+ character (len = slen), dimension (n1, n2, n3) :: a
+ character (len = slen) :: filler
+ integer (kind = 1), dimension (n1, n3) :: shift1
+ integer (kind = 2), dimension (n1, n3) :: shift2
+ integer (kind = 4), dimension (n1, n3) :: shift3
+ integer (kind = 8), dimension (n1, n3) :: shift4
+ integer :: i1, i2, i3
+
+ shift1 (1, :) = (/ 1, 3, 2, 2 /)
+ shift1 (2, :) = (/ 2, 1, 1, 3 /)
+ shift2 = shift1
+ shift3 = shift1
+ shift4 = shift1
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2, i3) = 'ab'(i1:i1) // 'cdefg'(i2:i2) // 'hijk'(i3:i3)
+ end do
+ end do
+ end do
+
+ call test (eoshift (a, shift1, 'foo', 2), 'foo')
+ call test (eoshift (a, shift2, 'foo', 2), 'foo')
+ call test (eoshift (a, shift3, 'foo', 2), 'foo')
+ call test (eoshift (a, shift4, 'foo', 2), 'foo')
+
+ filler = ''
+ call test (eoshift (a, shift1, dim = 2), filler)
+ call test (eoshift (a, shift2, dim = 2), filler)
+ call test (eoshift (a, shift3, dim = 2), filler)
+ call test (eoshift (a, shift4, dim = 2), filler)
+contains
+ subroutine test (b, filler)
+ character (len = slen), dimension (n1, n2, n3) :: b
+ character (len = slen) :: filler
+ integer :: i2p
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ i2p = i2 + shift1 (i1, i3)
+ if (i2p .gt. n2) then
+ if (b (i1, i2, i3) .ne. filler) call abort
+ else
+ if (b (i1, i2, i3) .ne. a (i1, i2p, i3)) call abort
+ end if
+ end do
+ end do
+ end do
+ end subroutine test
+end program main
diff --git a/gcc/testsuite/gfortran.dg/char_eoshift_3.f90 b/gcc/testsuite/gfortran.dg/char_eoshift_3.f90
new file mode 100644
index 0000000..62bc04c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_eoshift_3.f90
@@ -0,0 +1,54 @@
+! Test eoshift2 for character arrays.
+! { dg-do run }
+program main
+ implicit none
+ integer, parameter :: n1 = 2, n2 = 5, n3 = 4, slen = 3
+ character (len = slen), dimension (n1, n2, n3) :: a
+ character (len = slen), dimension (n1, n3) :: filler
+ integer (kind = 1) :: shift1 = 4
+ integer (kind = 2) :: shift2 = 2
+ integer (kind = 4) :: shift3 = 3
+ integer (kind = 8) :: shift4 = 1
+ integer :: i1, i2, i3
+
+ filler (1, :) = (/ 'tic', 'tac', 'toe', 'tip' /)
+ filler (2, :) = (/ 'zzz', 'yyy', 'xxx', 'www' /)
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2, i3) = 'ab'(i1:i1) // 'cdefg'(i2:i2) // 'hijk'(i3:i3)
+ end do
+ end do
+ end do
+
+ call test (eoshift (a, shift1, filler, 2), int (shift1), .true.)
+ call test (eoshift (a, shift2, filler, 2), int (shift2), .true.)
+ call test (eoshift (a, shift3, filler, 2), int (shift3), .true.)
+ call test (eoshift (a, shift4, filler, 2), int (shift4), .true.)
+
+ call test (eoshift (a, shift1, dim = 2), int (shift1), .false.)
+ call test (eoshift (a, shift2, dim = 2), int (shift2), .false.)
+ call test (eoshift (a, shift3, dim = 2), int (shift3), .false.)
+ call test (eoshift (a, shift4, dim = 2), int (shift4), .false.)
+contains
+ subroutine test (b, d2, has_filler)
+ character (len = slen), dimension (n1, n2, n3) :: b
+ logical :: has_filler
+ integer :: d2
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (i2 + d2 .le. n2) then
+ if (b (i1, i2, i3) .ne. a (i1, i2 + d2, i3)) call abort
+ else if (has_filler) then
+ if (b (i1, i2, i3) .ne. filler (i1, i3)) call abort
+ else
+ if (b (i1, i2, i3) .ne. '') call abort
+ end if
+ end do
+ end do
+ end do
+ end subroutine test
+end program main
diff --git a/gcc/testsuite/gfortran.dg/char_eoshift_4.f90 b/gcc/testsuite/gfortran.dg/char_eoshift_4.f90
new file mode 100644
index 0000000..b7c8670
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_eoshift_4.f90
@@ -0,0 +1,61 @@
+! Test eoshift3 for character arrays.
+! { dg-do run }
+program main
+ implicit none
+ integer, parameter :: n1 = 2, n2 = 5, n3 = 4, slen = 3
+ character (len = slen), dimension (n1, n2, n3) :: a
+ character (len = slen), dimension (n1, n3) :: filler
+ integer (kind = 1), dimension (n1, n3) :: shift1
+ integer (kind = 2), dimension (n1, n3) :: shift2
+ integer (kind = 4), dimension (n1, n3) :: shift3
+ integer (kind = 8), dimension (n1, n3) :: shift4
+ integer :: i1, i2, i3
+
+ filler (1, :) = (/ 'tic', 'tac', 'toe', 'tip' /)
+ filler (2, :) = (/ 'zzz', 'yyy', 'xxx', 'www' /)
+
+ shift1 (1, :) = (/ 1, 3, 2, 2 /)
+ shift1 (2, :) = (/ 2, 1, 1, 3 /)
+ shift2 = shift1
+ shift3 = shift1
+ shift4 = shift1
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2, i3) = 'ab'(i1:i1) // 'cdefg'(i2:i2) // 'hijk'(i3:i3)
+ end do
+ end do
+ end do
+
+ call test (eoshift (a, shift1, filler, 2), .true.)
+ call test (eoshift (a, shift2, filler, 2), .true.)
+ call test (eoshift (a, shift3, filler, 2), .true.)
+ call test (eoshift (a, shift4, filler, 2), .true.)
+
+ call test (eoshift (a, shift1, dim = 2), .false.)
+ call test (eoshift (a, shift2, dim = 2), .false.)
+ call test (eoshift (a, shift3, dim = 2), .false.)
+ call test (eoshift (a, shift4, dim = 2), .false.)
+contains
+ subroutine test (b, has_filler)
+ character (len = slen), dimension (n1, n2, n3) :: b
+ logical :: has_filler
+ integer :: i2p
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ i2p = i2 + shift1 (i1, i3)
+ if (i2p .le. n2) then
+ if (b (i1, i2, i3) .ne. a (i1, i2p, i3)) call abort
+ else if (has_filler) then
+ if (b (i1, i2, i3) .ne. filler (i1, i3)) call abort
+ else
+ if (b (i1, i2, i3) .ne. '') call abort
+ end if
+ end do
+ end do
+ end do
+ end subroutine test
+end program main
diff --git a/gcc/testsuite/gfortran.dg/char_pack_1.f90 b/gcc/testsuite/gfortran.dg/char_pack_1.f90
new file mode 100644
index 0000000..839f6c6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_pack_1.f90
@@ -0,0 +1,59 @@
+! Test (non-scalar) pack for character arrays.
+! { dg-do run }
+program main
+ implicit none
+ integer, parameter :: n1 = 3, n2 = 4, nv = 10, slen = 9
+ character (len = slen), dimension (n1, n2) :: a
+ character (len = slen), dimension (nv) :: vector
+ logical, dimension (n1, n2) :: mask
+ integer :: i1, i2, i
+
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2) = 'abc'(i1:i1) // 'defg'(i2:i2) // 'cantrip'
+ end do
+ end do
+ mask (1, :) = (/ .true., .false., .true., .true. /)
+ mask (2, :) = (/ .true., .false., .false., .false. /)
+ mask (3, :) = (/ .false., .true., .true., .true. /)
+
+ do i = 1, nv
+ vector (i) = 'crespo' // '0123456789'(i:i)
+ end do
+
+ call test1 (pack (a, mask))
+ call test2 (pack (a, mask, vector))
+contains
+ subroutine test1 (b)
+ character (len = slen), dimension (:) :: b
+
+ i = 0
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (mask (i1, i2)) then
+ i = i + 1
+ if (b (i) .ne. a (i1, i2)) call abort
+ end if
+ end do
+ end do
+ if (size (b, 1) .ne. i) call abort
+ end subroutine test1
+
+ subroutine test2 (b)
+ character (len = slen), dimension (:) :: b
+
+ if (size (b, 1) .ne. nv) call abort
+ i = 0
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (mask (i1, i2)) then
+ i = i + 1
+ if (b (i) .ne. a (i1, i2)) call abort
+ end if
+ end do
+ end do
+ do i = i + 1, nv
+ if (b (i) .ne. vector (i)) call abort
+ end do
+ end subroutine test2
+end program main
diff --git a/gcc/testsuite/gfortran.dg/char_pack_2.f90 b/gcc/testsuite/gfortran.dg/char_pack_2.f90
new file mode 100644
index 0000000..777db53
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_pack_2.f90
@@ -0,0 +1,53 @@
+! Test scalar pack for character arrays.
+! { dg-do run }
+program main
+ implicit none
+ integer, parameter :: n1 = 3, n2 = 4, nv = 10, slen = 9
+ character (len = slen), dimension (n1, n2) :: a
+ character (len = slen), dimension (nv) :: vector
+ logical :: mask
+ integer :: i1, i2, i
+
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2) = 'abc'(i1:i1) // 'defg'(i2:i2) // 'cantrip'
+ end do
+ end do
+
+ do i = 1, nv
+ vector (i) = 'crespo' // '0123456789'(i:i)
+ end do
+
+ mask = .true.
+ call test1 (pack (a, mask))
+ call test2 (pack (a, mask, vector))
+contains
+ subroutine test1 (b)
+ character (len = slen), dimension (:) :: b
+
+ i = 0
+ do i2 = 1, n2
+ do i1 = 1, n1
+ i = i + 1
+ if (b (i) .ne. a (i1, i2)) call abort
+ end do
+ end do
+ if (size (b, 1) .ne. i) call abort
+ end subroutine test1
+
+ subroutine test2 (b)
+ character (len = slen), dimension (:) :: b
+
+ if (size (b, 1) .ne. nv) call abort
+ i = 0
+ do i2 = 1, n2
+ do i1 = 1, n1
+ i = i + 1
+ if (b (i) .ne. a (i1, i2)) call abort
+ end do
+ end do
+ do i = i + 1, nv
+ if (b (i) .ne. vector (i)) call abort
+ end do
+ end subroutine test2
+end program main
diff --git a/gcc/testsuite/gfortran.dg/char_reshape_1.f90 b/gcc/testsuite/gfortran.dg/char_reshape_1.f90
new file mode 100644
index 0000000..b3b6244
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_reshape_1.f90
@@ -0,0 +1,43 @@
+! Test reshape for character arrays.
+! { dg-do run }
+program main
+ implicit none
+ integer, parameter :: n = 20, slen = 9
+ character (len = slen), dimension (n) :: a, pad
+ integer, dimension (3) :: shape, order
+ integer :: i
+
+ do i = 1, n
+ a (i) = 'abcdefghijklmnopqrstuvwxyz'(i:i+6)
+ pad (i) = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'(i:i+6)
+ end do
+
+ shape = (/ 4, 6, 5 /)
+ order = (/ 3, 1, 2 /)
+ call test (reshape (a, shape, pad, order))
+contains
+ subroutine test (b)
+ character (len = slen), dimension (:, :, :) :: b
+ integer :: i1, i2, i3, ai, padi
+
+ do i = 1, 3
+ if (size (b, i) .ne. shape (i)) call abort
+ end do
+ ai = 0
+ padi = 0
+ do i2 = 1, shape (2)
+ do i1 = 1, shape (1)
+ do i3 = 1, shape (3)
+ if (ai .lt. n) then
+ ai = ai + 1
+ if (b (i1, i2, i3) .ne. a (ai)) call abort
+ else
+ padi = padi + 1
+ if (padi .gt. n) padi = 1
+ if (b (i1, i2, i3) .ne. pad (padi)) call abort
+ end if
+ end do
+ end do
+ end do
+ end subroutine test
+end program main
diff --git a/gcc/testsuite/gfortran.dg/char_spread_1.f90 b/gcc/testsuite/gfortran.dg/char_spread_1.f90
new file mode 100644
index 0000000..0d51f60
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_spread_1.f90
@@ -0,0 +1,32 @@
+! Test spread for character arrays.
+! { dg-do run }
+program main
+ implicit none
+ integer, parameter :: n1 = 3, n2 = 10, n3 = 4, slen = 9
+ character (len = slen), dimension (n1, n3) :: a
+ integer :: i1, i2, i3
+
+ do i3 = 1, n3
+ do i1 = 1, n1
+ a (i1, i3) = 'ab'(i1:i1) // 'cde'(i3:i3) // 'cantrip'
+ end do
+ end do
+
+ call test (spread (a, 2, n2))
+contains
+ subroutine test (b)
+ character (len = slen), dimension (:, :, :) :: b
+
+ if (size (b, 1) .ne. n1) call abort
+ if (size (b, 2) .ne. n2) call abort
+ if (size (b, 3) .ne. n3) call abort
+
+ do i3 = 1, n3
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (b (i1, i2, i3) .ne. a (i1, i3)) call abort
+ end do
+ end do
+ end do
+ end subroutine test
+end program main
diff --git a/gcc/testsuite/gfortran.dg/char_transpose_1.f90 b/gcc/testsuite/gfortran.dg/char_transpose_1.f90
new file mode 100644
index 0000000..90605d6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_transpose_1.f90
@@ -0,0 +1,29 @@
+! Test transpose for character arrays.
+! { dg-do run }
+program main
+ implicit none
+ integer, parameter :: n1 = 3, n2 = 4, slen = 9
+ character (len = slen), dimension (n1, n2) :: a
+ integer :: i1, i2
+
+ do i2 = 1, n2
+ do i1 = 1, n1
+ a (i1, i2) = 'ab'(i1:i1) // 'cde'(i2:i2) // 'cantrip'
+ end do
+ end do
+
+ call test (transpose (a))
+contains
+ subroutine test (b)
+ character (len = slen), dimension (:, :) :: b
+
+ if (size (b, 1) .ne. n2) call abort
+ if (size (b, 2) .ne. n1) call abort
+
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (b (i2, i1) .ne. a (i1, i2)) call abort
+ end do
+ end do
+ end subroutine test
+end program main
diff --git a/gcc/testsuite/gfortran.dg/char_unpack_1.f90 b/gcc/testsuite/gfortran.dg/char_unpack_1.f90
new file mode 100644
index 0000000..65dd888
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_unpack_1.f90
@@ -0,0 +1,44 @@
+! Test unpack0 for character arrays.
+! { dg-do run }
+program main
+ implicit none
+ integer, parameter :: n1 = 3, n2 = 4, nv = 10, slen = 9
+ character (len = slen), dimension (n1, n2) :: field
+ character (len = slen), dimension (nv) :: vector
+ logical, dimension (n1, n2) :: mask
+ integer :: i1, i2, i
+
+ do i2 = 1, n2
+ do i1 = 1, n1
+ field (i1, i2) = 'abc'(i1:i1) // 'defg'(i2:i2) // 'cantrip'
+ end do
+ end do
+ mask (1, :) = (/ .true., .false., .true., .true. /)
+ mask (2, :) = (/ .true., .false., .false., .false. /)
+ mask (3, :) = (/ .false., .true., .true., .true. /)
+
+ do i = 1, nv
+ vector (i) = 'crespo' // '0123456789'(i:i)
+ end do
+
+ call test (unpack (vector, mask, field))
+contains
+ subroutine test (a)
+ character (len = slen), dimension (:, :) :: a
+
+ if (size (a, 1) .ne. n1) call abort
+ if (size (a, 2) .ne. n2) call abort
+
+ i = 0
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (mask (i1, i2)) then
+ i = i + 1
+ if (a (i1, i2) .ne. vector (i)) call abort
+ else
+ if (a (i1, i2) .ne. field (i1, i2)) call abort
+ end if
+ end do
+ end do
+ end subroutine test
+end program main
diff --git a/gcc/testsuite/gfortran.dg/char_unpack_2.f90 b/gcc/testsuite/gfortran.dg/char_unpack_2.f90
new file mode 100644
index 0000000..3b2c4a3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_unpack_2.f90
@@ -0,0 +1,40 @@
+! Test unpack1 for character arrays.
+! { dg-do run }
+program main
+ implicit none
+ integer, parameter :: n1 = 3, n2 = 4, nv = 10, slen = 9
+ character (len = slen) :: field
+ character (len = slen), dimension (nv) :: vector
+ logical, dimension (n1, n2) :: mask
+ integer :: i1, i2, i
+
+ field = 'broadside'
+ mask (1, :) = (/ .true., .false., .true., .true. /)
+ mask (2, :) = (/ .true., .false., .false., .false. /)
+ mask (3, :) = (/ .false., .true., .true., .true. /)
+
+ do i = 1, nv
+ vector (i) = 'crespo' // '0123456789'(i:i)
+ end do
+
+ call test (unpack (vector, mask, field))
+contains
+ subroutine test (a)
+ character (len = slen), dimension (:, :) :: a
+
+ if (size (a, 1) .ne. n1) call abort
+ if (size (a, 2) .ne. n2) call abort
+
+ i = 0
+ do i2 = 1, n2
+ do i1 = 1, n1
+ if (mask (i1, i2)) then
+ i = i + 1
+ if (a (i1, i2) .ne. vector (i)) call abort
+ else
+ if (a (i1, i2) .ne. field) call abort
+ end if
+ end do
+ end do
+ end subroutine test
+end program main
generated by cgit v1.1 at 2025-12-25 21:13:42 +0000