+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.
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" : "");
}
}
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" : "");
}
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.
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"));
}
}
break;
default:
- f->value.function.name = PREFIX("reshape");
+ f->value.function.name = (source->ts.type == BT_CHARACTER
+ ? PREFIX("reshape_char")
+ : PREFIX("reshape"));
break;
}
{
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);
break;
default:
- f->value.function.name = PREFIX("transpose");
+ f->value.function.name = (matrix->ts.type == BT_CHARACTER
+ ? PREFIX("transpose_char")
+ : PREFIX("transpose"));
+ break;
}
}
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" : "");
}
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
{
+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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
+2005-09-13 Richard Sandiford <richard@codesourcery.com>
+
+ PR target/19269
+ * intrinsics/cshift0.c (cshift0): Add an extra size argument.
+ (cshift0_1, cshift0_2, cshift0_4, cshift0_8): Replace explicit
+ implementations with...
+ (DEFINE_CSHIFT): ...this new macro. Define character versions too.
+ * intrinsics/eoshift0.c (zeros): Delete.
+ (eoshift0): Add extra size and filler arguments. Use memset if no
+ bound is provided.
+ (eoshift0_1, eoshift0_2, eoshift0_4, eoshift0_8): Replace explicit
+ implementations with...
+ (DEFINE_EOSHIFT): ...this new macro. Define character versions too.
+ * intrinsics/eoshift2.c (zeros): Delete.
+ (eoshift2): Add extra size and filler arguments. Use memset if no
+ bound is provided.
+ (eoshift2_1, eoshift2_2, eoshift2_4, eoshift2_8): Replace explicit
+ implementations with...
+ (DEFINE_EOSHIFT): ...this new macro. Define character versions too.
+ * intrinsics/pack.c (pack_internal): New static function, reusing
+ the contents of pack and adding an extra size argument. Change
+ "mptr" rather than "m" when calculating the array size.
+ (pack): Redefine as a forwarder to pack_internal.
+ (pack_s_internal): New static function, reusing the contents of
+ pack_s and adding an extra size argument.
+ (pack_s): Redefine as a forwarder to pack_s_internal.
+ (pack_char, pack_s_char): New functions.
+ * intrinsics/reshape.c (reshape_internal): New static function,
+ reusing the contents of reshape and adding an extra size argument.
+ (reshape): Redefine as a forwarder to reshape_internal.
+ (reshape_char): New function.
+ * intrinsics/spread.c (spread_internal): New static function,
+ reusing the contents of spread and adding an extra size argument.
+ (spread): Redefine as a forwarder to spread_internal.
+ (spread_char): New function.
+ * intrinsics/transpose.c (transpose_internal): New static function,
+ reusing the contents of transpose and adding an extra size argument.
+ (transpose): Redefine as a forwarder to transpose_internal.
+ (transpose_char): New function.
+ * intrinsics/unpack.c (unpack_internal): New static function, reusing
+ the contents of unpack1 and adding extra size and fsize arguments.
+ (unpack1): Redefine as a forwarder to unpack_internal.
+ (unpack0): Call unpack_internal instead of unpack1.
+ (unpack1_char, unpack0_char): New functions.
+ * m4/cshift1.m4 (cshift1): New static function, reusing the contents
+ of cshift1_<kind> and adding an extra size argument.
+ (cshift1_<kind>): Redefine as a forwarder to cshift1.
+ (cshift1_<kind>_char): New function.
+ * m4/eoshift1.m4 (zeros): Delete.
+ (eoshift1): New static function, reusing the contents of
+ eoshift1_<kind> and adding extra size and filler arguments.
+ Fix calculation of hstride. Use memset if no bound is provided.
+ (eoshift1_<kind>): Redefine as a forwarder to eoshift1.
+ (eoshift1_<kind>_char): New function.
+ * m4/eoshift3.m4 (zeros): Delete.
+ (eoshift3): New static function, reusing the contents of
+ eoshift3_<kind> and adding extra size and filler arguments.
+ Use memset if no bound is provided.
+ (eoshift3_<kind>): Redefine as a forwarder to eoshift3.
+ (eoshift3_<kind>_char): New function.
+ * generated/cshift1_4.c, generated/cshift1_8.c,
+ * generated/eoshift1_4.c, generated/eoshift1_8.c,
+ * generated/eoshift3_4.c, generated/eoshift3_8.c: Regenerate.
+
2005-09-11 Francois-Xavier Coudert <coudert@clipper.ens.fr>
PR libfortran/20179
#include <string.h>
#include "libgfortran.h"
-void cshift1_4 (gfc_array_char * ret,
- const gfc_array_char * array,
- const gfc_array_i4 * h, const GFC_INTEGER_4 * pwhich);
-export_proto(cshift1_4);
-
-void
-cshift1_4 (gfc_array_char * ret,
- const gfc_array_char * array,
- const gfc_array_i4 * h, const GFC_INTEGER_4 * pwhich)
+static void
+cshift1 (gfc_array_char * ret, const gfc_array_char * array,
+ const gfc_array_i4 * h, const GFC_INTEGER_4 * pwhich, index_type size)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
int which;
if (which < 0 || (which + 1) > GFC_DESCRIPTOR_RANK (array))
runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
- size = GFC_DESCRIPTOR_SIZE (ret);
-
if (ret->data == NULL)
{
int i;
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
/* Initialized for avoiding compiler warnings. */
}
}
}
+
+void cshift1_4 (gfc_array_char *, const gfc_array_char *,
+ const gfc_array_i4 *, const GFC_INTEGER_4 *);
+export_proto(cshift1_4);
+
+void
+cshift1_4 (gfc_array_char * ret,
+ const gfc_array_char * array,
+ const gfc_array_i4 * h, const GFC_INTEGER_4 * pwhich)
+{
+ cshift1 (ret, array, h, pwhich, GFC_DESCRIPTOR_SIZE (array));
+}
+
+void cshift1_4_char (gfc_array_char * ret, GFC_INTEGER_4,
+ const gfc_array_char * array,
+ const gfc_array_i4 * h, const GFC_INTEGER_4 * pwhich,
+ GFC_INTEGER_4);
+export_proto(cshift1_4_char);
+
+void
+cshift1_4_char (gfc_array_char * ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char * array,
+ const gfc_array_i4 * h, const GFC_INTEGER_4 * pwhich,
+ GFC_INTEGER_4 array_length)
+{
+ cshift1 (ret, array, h, pwhich, array_length);
+}
#include <string.h>
#include "libgfortran.h"
-void cshift1_8 (gfc_array_char * ret,
- const gfc_array_char * array,
- const gfc_array_i8 * h, const GFC_INTEGER_8 * pwhich);
-export_proto(cshift1_8);
-
-void
-cshift1_8 (gfc_array_char * ret,
- const gfc_array_char * array,
- const gfc_array_i8 * h, const GFC_INTEGER_8 * pwhich)
+static void
+cshift1 (gfc_array_char * ret, const gfc_array_char * array,
+ const gfc_array_i8 * h, const GFC_INTEGER_8 * pwhich, index_type size)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
int which;
if (which < 0 || (which + 1) > GFC_DESCRIPTOR_RANK (array))
runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
- size = GFC_DESCRIPTOR_SIZE (ret);
-
if (ret->data == NULL)
{
int i;
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
/* Initialized for avoiding compiler warnings. */
}
}
}
+
+void cshift1_8 (gfc_array_char *, const gfc_array_char *,
+ const gfc_array_i8 *, const GFC_INTEGER_8 *);
+export_proto(cshift1_8);
+
+void
+cshift1_8 (gfc_array_char * ret,
+ const gfc_array_char * array,
+ const gfc_array_i8 * h, const GFC_INTEGER_8 * pwhich)
+{
+ cshift1 (ret, array, h, pwhich, GFC_DESCRIPTOR_SIZE (array));
+}
+
+void cshift1_8_char (gfc_array_char * ret, GFC_INTEGER_4,
+ const gfc_array_char * array,
+ const gfc_array_i8 * h, const GFC_INTEGER_8 * pwhich,
+ GFC_INTEGER_4);
+export_proto(cshift1_8_char);
+
+void
+cshift1_8_char (gfc_array_char * ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char * array,
+ const gfc_array_i8 * h, const GFC_INTEGER_8 * pwhich,
+ GFC_INTEGER_4 array_length)
+{
+ cshift1 (ret, array, h, pwhich, array_length);
+}
#include <string.h>
#include "libgfortran.h"
-static const char zeros[16] =
- {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
-
-extern void eoshift1_4 (gfc_array_char *,
- const gfc_array_char *,
- const gfc_array_i4 *, const char *,
- const GFC_INTEGER_4 *);
-export_proto(eoshift1_4);
-
-void
-eoshift1_4 (gfc_array_char *ret,
- const gfc_array_char *array,
- const gfc_array_i4 *h, const char *pbound,
- const GFC_INTEGER_4 *pwhich)
+static void
+eoshift1 (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_i4 *h,
+ const char *pbound, const GFC_INTEGER_4 *pwhich, index_type size,
+ char filler)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
int which;
else
which = 0;
- if (!pbound)
- pbound = zeros;
-
- size = GFC_DESCRIPTOR_SIZE (ret);
-
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
if (ret->data == NULL)
{
rstride[n] = ret->dim[dim].stride * size;
sstride[n] = array->dim[dim].stride * size;
- hstride[n] = h->dim[n].stride * size;
+ hstride[n] = h->dim[n].stride;
n++;
}
}
dest = rptr;
n = delta;
- while (n--)
- {
- memcpy (dest, pbound, size);
- dest += roffset;
- }
+ if (pbound)
+ while (n--)
+ {
+ memcpy (dest, pbound, size);
+ dest += roffset;
+ }
+ else
+ while (n--)
+ {
+ memset (dest, filler, size);
+ dest += roffset;
+ }
/* Advance to the next section. */
rptr += rstride0;
}
}
}
+
+void eoshift1_4 (gfc_array_char *, const gfc_array_char *,
+ const gfc_array_i4 *, const char *, const GFC_INTEGER_4 *);
+export_proto(eoshift1_4);
+
+void
+eoshift1_4 (gfc_array_char *ret, const gfc_array_char *array,
+ const gfc_array_i4 *h, const char *pbound,
+ const GFC_INTEGER_4 *pwhich)
+{
+ eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0);
+}
+
+void eoshift1_4_char (gfc_array_char *, GFC_INTEGER_4,
+ const gfc_array_char *, const gfc_array_i4 *,
+ const char *, const GFC_INTEGER_4 *,
+ GFC_INTEGER_4, GFC_INTEGER_4);
+export_proto(eoshift1_4_char);
+
+void
+eoshift1_4_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char *array, const gfc_array_i4 *h,
+ const char *pbound, const GFC_INTEGER_4 *pwhich,
+ GFC_INTEGER_4 array_length,
+ GFC_INTEGER_4 bound_length
+ __attribute__((unused)))
+{
+ eoshift1 (ret, array, h, pbound, pwhich, array_length, ' ');
+}
#include <string.h>
#include "libgfortran.h"
-static const char zeros[16] =
- {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
-
-extern void eoshift1_8 (gfc_array_char *,
- const gfc_array_char *,
- const gfc_array_i8 *, const char *,
- const GFC_INTEGER_8 *);
-export_proto(eoshift1_8);
-
-void
-eoshift1_8 (gfc_array_char *ret,
- const gfc_array_char *array,
- const gfc_array_i8 *h, const char *pbound,
- const GFC_INTEGER_8 *pwhich)
+static void
+eoshift1 (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_i8 *h,
+ const char *pbound, const GFC_INTEGER_8 *pwhich, index_type size,
+ char filler)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
int which;
else
which = 0;
- if (!pbound)
- pbound = zeros;
-
- size = GFC_DESCRIPTOR_SIZE (ret);
-
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
if (ret->data == NULL)
{
rstride[n] = ret->dim[dim].stride * size;
sstride[n] = array->dim[dim].stride * size;
- hstride[n] = h->dim[n].stride * size;
+ hstride[n] = h->dim[n].stride;
n++;
}
}
dest = rptr;
n = delta;
- while (n--)
- {
- memcpy (dest, pbound, size);
- dest += roffset;
- }
+ if (pbound)
+ while (n--)
+ {
+ memcpy (dest, pbound, size);
+ dest += roffset;
+ }
+ else
+ while (n--)
+ {
+ memset (dest, filler, size);
+ dest += roffset;
+ }
/* Advance to the next section. */
rptr += rstride0;
}
}
}
+
+void eoshift1_8 (gfc_array_char *, const gfc_array_char *,
+ const gfc_array_i8 *, const char *, const GFC_INTEGER_8 *);
+export_proto(eoshift1_8);
+
+void
+eoshift1_8 (gfc_array_char *ret, const gfc_array_char *array,
+ const gfc_array_i8 *h, const char *pbound,
+ const GFC_INTEGER_8 *pwhich)
+{
+ eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0);
+}
+
+void eoshift1_8_char (gfc_array_char *, GFC_INTEGER_4,
+ const gfc_array_char *, const gfc_array_i8 *,
+ const char *, const GFC_INTEGER_8 *,
+ GFC_INTEGER_4, GFC_INTEGER_4);
+export_proto(eoshift1_8_char);
+
+void
+eoshift1_8_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char *array, const gfc_array_i8 *h,
+ const char *pbound, const GFC_INTEGER_8 *pwhich,
+ GFC_INTEGER_4 array_length,
+ GFC_INTEGER_4 bound_length
+ __attribute__((unused)))
+{
+ eoshift1 (ret, array, h, pbound, pwhich, array_length, ' ');
+}
#include <string.h>
#include "libgfortran.h"
-static const char zeros[16] =
- {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
-
-extern void eoshift3_4 (gfc_array_char *, gfc_array_char *,
- gfc_array_i4 *, const gfc_array_char *,
- GFC_INTEGER_4 *);
-export_proto(eoshift3_4);
-
-void
-eoshift3_4 (gfc_array_char *ret, gfc_array_char *array,
- gfc_array_i4 *h, const gfc_array_char *bound,
- GFC_INTEGER_4 *pwhich)
+static void
+eoshift3 (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_i4 *h,
+ const gfc_array_char *bound, const GFC_INTEGER_4 *pwhich,
+ index_type size, char filler)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
int which;
else
which = 0;
- size = GFC_DESCRIPTOR_SIZE (ret);
if (ret->data == NULL)
{
int i;
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
{
if (bound)
bptr = bound->data;
else
- bptr = zeros;
+ bptr = NULL;
while (rptr)
{
dest = rptr;
n = delta;
- while (n--)
- {
- memcpy (dest, bptr, size);
- dest += roffset;
- }
+ if (bptr)
+ while (n--)
+ {
+ memcpy (dest, bptr, size);
+ dest += roffset;
+ }
+ else
+ while (n--)
+ {
+ memset (dest, filler, size);
+ dest += roffset;
+ }
/* Advance to the next section. */
rptr += rstride0;
}
}
}
+
+extern void eoshift3_4 (gfc_array_char *, const gfc_array_char *,
+ const gfc_array_i4 *, const gfc_array_char *,
+ const GFC_INTEGER_4 *);
+export_proto(eoshift3_4);
+
+void
+eoshift3_4 (gfc_array_char *ret, const gfc_array_char *array,
+ const gfc_array_i4 *h, const gfc_array_char *bound,
+ const GFC_INTEGER_4 *pwhich)
+{
+ eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0);
+}
+
+extern void eoshift3_4_char (gfc_array_char *, GFC_INTEGER_4,
+ const gfc_array_char *,
+ const gfc_array_i4 *,
+ const gfc_array_char *,
+ const GFC_INTEGER_4 *, GFC_INTEGER_4,
+ GFC_INTEGER_4);
+export_proto(eoshift3_4_char);
+
+void
+eoshift3_4_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char *array, const gfc_array_i4 *h,
+ const gfc_array_char *bound,
+ const GFC_INTEGER_4 *pwhich,
+ GFC_INTEGER_4 array_length,
+ GFC_INTEGER_4 bound_length
+ __attribute__((unused)))
+{
+ eoshift3 (ret, array, h, bound, pwhich, array_length, ' ');
+}
#include <string.h>
#include "libgfortran.h"
-static const char zeros[16] =
- {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
-
-extern void eoshift3_8 (gfc_array_char *, gfc_array_char *,
- gfc_array_i8 *, const gfc_array_char *,
- GFC_INTEGER_8 *);
-export_proto(eoshift3_8);
-
-void
-eoshift3_8 (gfc_array_char *ret, gfc_array_char *array,
- gfc_array_i8 *h, const gfc_array_char *bound,
- GFC_INTEGER_8 *pwhich)
+static void
+eoshift3 (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_i8 *h,
+ const gfc_array_char *bound, const GFC_INTEGER_8 *pwhich,
+ index_type size, char filler)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
int which;
else
which = 0;
- size = GFC_DESCRIPTOR_SIZE (ret);
if (ret->data == NULL)
{
int i;
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
{
if (bound)
bptr = bound->data;
else
- bptr = zeros;
+ bptr = NULL;
while (rptr)
{
dest = rptr;
n = delta;
- while (n--)
- {
- memcpy (dest, bptr, size);
- dest += roffset;
- }
+ if (bptr)
+ while (n--)
+ {
+ memcpy (dest, bptr, size);
+ dest += roffset;
+ }
+ else
+ while (n--)
+ {
+ memset (dest, filler, size);
+ dest += roffset;
+ }
/* Advance to the next section. */
rptr += rstride0;
}
}
}
+
+extern void eoshift3_8 (gfc_array_char *, const gfc_array_char *,
+ const gfc_array_i8 *, const gfc_array_char *,
+ const GFC_INTEGER_8 *);
+export_proto(eoshift3_8);
+
+void
+eoshift3_8 (gfc_array_char *ret, const gfc_array_char *array,
+ const gfc_array_i8 *h, const gfc_array_char *bound,
+ const GFC_INTEGER_8 *pwhich)
+{
+ eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0);
+}
+
+extern void eoshift3_8_char (gfc_array_char *, GFC_INTEGER_4,
+ const gfc_array_char *,
+ const gfc_array_i8 *,
+ const gfc_array_char *,
+ const GFC_INTEGER_8 *, GFC_INTEGER_4,
+ GFC_INTEGER_4);
+export_proto(eoshift3_8_char);
+
+void
+eoshift3_8_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char *array, const gfc_array_i8 *h,
+ const gfc_array_char *bound,
+ const GFC_INTEGER_8 *pwhich,
+ GFC_INTEGER_4 array_length,
+ GFC_INTEGER_4 bound_length
+ __attribute__((unused)))
+{
+ eoshift3 (ret, array, h, bound, pwhich, array_length, ' ');
+}
static void
cshift0 (gfc_array_char * ret, const gfc_array_char * array,
- ssize_t shift, int which)
+ ssize_t shift, int which, index_type size)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
int whichloop;
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
/* The values assigned here must match the cases in the inner loop. */
}
}
-
-extern void cshift0_1 (gfc_array_char *, const gfc_array_char *,
- const GFC_INTEGER_1 *, const GFC_INTEGER_1 *);
-export_proto(cshift0_1);
-
-void
-cshift0_1 (gfc_array_char *ret, const gfc_array_char *array,
- const GFC_INTEGER_1 *pshift, const GFC_INTEGER_1 *pdim)
-{
- cshift0 (ret, array, *pshift, pdim ? *pdim : 1);
-}
-
-
-extern void cshift0_2 (gfc_array_char *, const gfc_array_char *,
- const GFC_INTEGER_2 *, const GFC_INTEGER_2 *);
-export_proto(cshift0_2);
-
-void
-cshift0_2 (gfc_array_char *ret, const gfc_array_char *array,
- const GFC_INTEGER_2 *pshift, const GFC_INTEGER_2 *pdim)
-{
- cshift0 (ret, array, *pshift, pdim ? *pdim : 1);
-}
-
-
-extern void cshift0_4 (gfc_array_char *, const gfc_array_char *,
- const GFC_INTEGER_4 *, const GFC_INTEGER_4 *);
-export_proto(cshift0_4);
-
-void
-cshift0_4 (gfc_array_char *ret, const gfc_array_char *array,
- const GFC_INTEGER_4 *pshift, const GFC_INTEGER_4 *pdim)
-{
- cshift0 (ret, array, *pshift, pdim ? *pdim : 1);
-}
-
-
-extern void cshift0_8 (gfc_array_char *, const gfc_array_char *,
- const GFC_INTEGER_8 *, const GFC_INTEGER_8 *);
-export_proto(cshift0_8);
-
-void
-cshift0_8 (gfc_array_char *ret, const gfc_array_char *array,
- const GFC_INTEGER_8 *pshift, const GFC_INTEGER_8 *pdim)
-{
- cshift0 (ret, array, *pshift, pdim ? *pdim : 1);
-}
-
+#define DEFINE_CSHIFT(N) \
+ extern void cshift0_##N (gfc_array_char *, const gfc_array_char *, \
+ const GFC_INTEGER_##N *, const GFC_INTEGER_##N *); \
+ export_proto(cshift0_##N); \
+ \
+ void \
+ cshift0_##N (gfc_array_char *ret, const gfc_array_char *array, \
+ const GFC_INTEGER_##N *pshift, const GFC_INTEGER_##N *pdim) \
+ { \
+ cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \
+ GFC_DESCRIPTOR_SIZE (array)); \
+ } \
+ \
+ extern void cshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4, \
+ const gfc_array_char *, \
+ const GFC_INTEGER_##N *, \
+ const GFC_INTEGER_##N *, GFC_INTEGER_4); \
+ export_proto(cshift0_##N##_char); \
+ \
+ void \
+ cshift0_##N##_char (gfc_array_char *ret, \
+ GFC_INTEGER_4 ret_length __attribute__((unused)), \
+ const gfc_array_char *array, \
+ const GFC_INTEGER_##N *pshift, \
+ const GFC_INTEGER_##N *pdim, \
+ GFC_INTEGER_4 array_length) \
+ { \
+ cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length); \
+ }
+
+DEFINE_CSHIFT (1);
+DEFINE_CSHIFT (2);
+DEFINE_CSHIFT (4);
+DEFINE_CSHIFT (8);
#include <string.h>
#include "libgfortran.h"
-static const char zeros[16] =
- {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
-
/* TODO: make this work for large shifts when
sizeof(int) < sizeof (index_type). */
static void
eoshift0 (gfc_array_char * ret, const gfc_array_char * array,
- int shift, const char * pbound, int which)
+ int shift, const char * pbound, int which, index_type size,
+ char filler)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
soffset = 0;
roffset = 0;
- if (!pbound)
- pbound = zeros;
-
- size = GFC_DESCRIPTOR_SIZE (ret);
-
if (ret->data == NULL)
{
int i;
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
{
n = -shift;
}
- while (n--)
- {
- memcpy (dest, pbound, size);
- dest += roffset;
- }
+ if (pbound)
+ while (n--)
+ {
+ memcpy (dest, pbound, size);
+ dest += roffset;
+ }
+ else
+ while (n--)
+ {
+ memset (dest, filler, size);
+ dest += roffset;
+ }
/* Advance to the next section. */
rptr += rstride0;
}
-extern void eoshift0_1 (gfc_array_char *, const gfc_array_char *,
- const GFC_INTEGER_1 *, const char *,
- const GFC_INTEGER_1 *);
-export_proto(eoshift0_1);
-
-void
-eoshift0_1 (gfc_array_char *ret, const gfc_array_char *array,
- const GFC_INTEGER_1 *pshift, const char *pbound,
- const GFC_INTEGER_1 *pdim)
-{
- eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
-}
-
-
-extern void eoshift0_2 (gfc_array_char *, const gfc_array_char *,
- const GFC_INTEGER_2 *, const char *,
- const GFC_INTEGER_2 *);
-export_proto(eoshift0_2);
-
-void
-eoshift0_2 (gfc_array_char *ret, const gfc_array_char *array,
- const GFC_INTEGER_2 *pshift, const char *pbound,
- const GFC_INTEGER_2 *pdim)
-{
- eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
-}
-
-
-extern void eoshift0_4 (gfc_array_char *, const gfc_array_char *,
- const GFC_INTEGER_4 *, const char *,
- const GFC_INTEGER_4 *);
-export_proto(eoshift0_4);
-
-void
-eoshift0_4 (gfc_array_char *ret, const gfc_array_char *array,
- const GFC_INTEGER_4 *pshift, const char *pbound,
- const GFC_INTEGER_4 *pdim)
-{
- eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
-}
-
-
-extern void eoshift0_8 (gfc_array_char *, const gfc_array_char *,
- const GFC_INTEGER_8 *, const char *,
- const GFC_INTEGER_8 *);
-export_proto(eoshift0_8);
-
-void
-eoshift0_8 (gfc_array_char *ret, const gfc_array_char *array,
- const GFC_INTEGER_8 *pshift, const char *pbound,
- const GFC_INTEGER_8 *pdim)
-{
- eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
-}
+#define DEFINE_EOSHIFT(N) \
+ extern void eoshift0_##N (gfc_array_char *, const gfc_array_char *, \
+ const GFC_INTEGER_##N *, const char *, \
+ const GFC_INTEGER_##N *); \
+ export_proto(eoshift0_##N); \
+ \
+ void \
+ eoshift0_##N (gfc_array_char *ret, const gfc_array_char *array, \
+ const GFC_INTEGER_##N *pshift, const char *pbound, \
+ const GFC_INTEGER_##N *pdim) \
+ { \
+ eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \
+ GFC_DESCRIPTOR_SIZE (array), 0); \
+ } \
+ \
+ extern void eoshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4, \
+ const gfc_array_char *, \
+ const GFC_INTEGER_##N *, const char *, \
+ const GFC_INTEGER_##N *, GFC_INTEGER_4, \
+ GFC_INTEGER_4); \
+ export_proto(eoshift0_##N##_char); \
+ \
+ void \
+ eoshift0_##N##_char (gfc_array_char *ret, \
+ GFC_INTEGER_4 ret_length __attribute__((unused)), \
+ const gfc_array_char *array, \
+ const GFC_INTEGER_##N *pshift, \
+ const char *pbound, \
+ const GFC_INTEGER_##N *pdim, \
+ GFC_INTEGER_4 array_length, \
+ GFC_INTEGER_4 bound_length __attribute__((unused))) \
+ { \
+ eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \
+ array_length, ' '); \
+ }
+
+DEFINE_EOSHIFT (1);
+DEFINE_EOSHIFT (2);
+DEFINE_EOSHIFT (4);
+DEFINE_EOSHIFT (8);
#include <string.h>
#include "libgfortran.h"
-static const char zeros[16] =
- {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
-
/* TODO: make this work for large shifts when
sizeof(int) < sizeof (index_type). */
static void
eoshift2 (gfc_array_char *ret, const gfc_array_char *array,
- int shift, const gfc_array_char *bound, int which)
+ int shift, const gfc_array_char *bound, int which,
+ index_type size, char filler)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
soffset = 0;
roffset = 0;
- size = GFC_DESCRIPTOR_SIZE (ret);
-
if (ret->data == NULL)
{
int i;
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
{
if (bound)
bptr = bound->data;
else
- bptr = zeros;
+ bptr = NULL;
while (rptr)
{
n = -shift;
}
- while (n--)
- {
- memcpy (dest, bptr, size);
- dest += roffset;
- }
+ if (bptr)
+ while (n--)
+ {
+ memcpy (dest, bptr, size);
+ dest += roffset;
+ }
+ else
+ while (n--)
+ {
+ memset (dest, filler, size);
+ dest += roffset;
+ }
/* Advance to the next section. */
rptr += rstride0;
}
-extern void eoshift2_1 (gfc_array_char *, const gfc_array_char *,
- const GFC_INTEGER_1 *, const gfc_array_char *,
- const GFC_INTEGER_1 *);
-export_proto(eoshift2_1);
-
-void
-eoshift2_1 (gfc_array_char *ret, const gfc_array_char *array,
- const GFC_INTEGER_1 *pshift, const gfc_array_char *bound,
- const GFC_INTEGER_1 *pdim)
-{
- eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
-}
-
-
-extern void eoshift2_2 (gfc_array_char *, const gfc_array_char *,
- const GFC_INTEGER_2 *, const gfc_array_char *,
- const GFC_INTEGER_2 *);
-export_proto(eoshift2_2);
-
-void
-eoshift2_2 (gfc_array_char *ret, const gfc_array_char *array,
- const GFC_INTEGER_2 *pshift, const gfc_array_char *bound,
- const GFC_INTEGER_2 *pdim)
-{
- eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
-}
-
-
-extern void eoshift2_4 (gfc_array_char *, const gfc_array_char *,
- const GFC_INTEGER_4 *, const gfc_array_char *,
- const GFC_INTEGER_4 *);
-export_proto(eoshift2_4);
-
-void
-eoshift2_4 (gfc_array_char *ret, const gfc_array_char *array,
- const GFC_INTEGER_4 *pshift, const gfc_array_char *bound,
- const GFC_INTEGER_4 *pdim)
-{
- eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
-}
-
-
-extern void eoshift2_8 (gfc_array_char *, const gfc_array_char *,
- const GFC_INTEGER_8 *, const gfc_array_char *,
- const GFC_INTEGER_8 *);
-export_proto(eoshift2_8);
-
-void
-eoshift2_8 (gfc_array_char *ret, const gfc_array_char *array,
- const GFC_INTEGER_8 *pshift, const gfc_array_char *bound,
- const GFC_INTEGER_8 *pdim)
-{
- eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
-}
+#define DEFINE_EOSHIFT(N) \
+ extern void eoshift2_##N (gfc_array_char *, const gfc_array_char *, \
+ const GFC_INTEGER_##N *, const gfc_array_char *, \
+ const GFC_INTEGER_##N *); \
+ export_proto(eoshift2_##N); \
+ \
+ void \
+ eoshift2_##N (gfc_array_char *ret, const gfc_array_char *array, \
+ const GFC_INTEGER_##N *pshift, const gfc_array_char *pbound, \
+ const GFC_INTEGER_##N *pdim) \
+ { \
+ eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \
+ GFC_DESCRIPTOR_SIZE (array), 0); \
+ } \
+ \
+ extern void eoshift2_##N##_char (gfc_array_char *, GFC_INTEGER_4, \
+ const gfc_array_char *, \
+ const GFC_INTEGER_##N *, \
+ const gfc_array_char *, \
+ const GFC_INTEGER_##N *, \
+ GFC_INTEGER_4, GFC_INTEGER_4); \
+ export_proto(eoshift2_##N##_char); \
+ \
+ void \
+ eoshift2_##N##_char (gfc_array_char *ret, \
+ GFC_INTEGER_4 ret_length __attribute__((unused)), \
+ const gfc_array_char *array, \
+ const GFC_INTEGER_##N *pshift, \
+ const gfc_array_char *pbound, \
+ const GFC_INTEGER_##N *pdim, \
+ GFC_INTEGER_4 array_length, \
+ GFC_INTEGER_4 bound_length __attribute__((unused))) \
+ { \
+ eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \
+ array_length, ' '); \
+ }
+
+DEFINE_EOSHIFT (1);
+DEFINE_EOSHIFT (2);
+DEFINE_EOSHIFT (4);
+DEFINE_EOSHIFT (8);
There are two variants of the PACK intrinsic: one, where MASK is
array valued, and the other one where MASK is scalar. */
-extern void pack (gfc_array_char *, const gfc_array_char *,
- const gfc_array_l4 *, const gfc_array_char *);
-export_proto(pack);
-
-void
-pack (gfc_array_char *ret, const gfc_array_char *array,
- const gfc_array_l4 *mask, const gfc_array_char *vector)
+static void
+pack_internal (gfc_array_char *ret, const gfc_array_char *array,
+ const gfc_array_l4 *mask, const gfc_array_char *vector,
+ index_type size)
{
/* r.* indicates the return array. */
index_type rstride0;
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
- index_type size;
index_type nelem;
- size = GFC_DESCRIPTOR_SIZE (array);
dim = GFC_DESCRIPTOR_RANK (array);
for (n = 0; n < dim; n++)
{
else
{
count[n]++;
- mptr += mstride[n];
+ m += mstride[n];
}
}
}
}
}
-extern void pack_s (gfc_array_char *ret, const gfc_array_char *array,
- const GFC_LOGICAL_4 *, const gfc_array_char *);
-export_proto(pack_s);
+extern void pack (gfc_array_char *, const gfc_array_char *,
+ const gfc_array_l4 *, const gfc_array_char *);
+export_proto(pack);
void
-pack_s (gfc_array_char *ret, const gfc_array_char *array,
- const GFC_LOGICAL_4 *mask, const gfc_array_char *vector)
+pack (gfc_array_char *ret, const gfc_array_char *array,
+ const gfc_array_l4 *mask, const gfc_array_char *vector)
+{
+ pack_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
+}
+
+extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *,
+ const gfc_array_l4 *, const gfc_array_char *,
+ GFC_INTEGER_4, GFC_INTEGER_4);
+export_proto(pack_char);
+
+void
+pack_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char *array, const gfc_array_l4 *mask,
+ const gfc_array_char *vector, GFC_INTEGER_4 array_length,
+ GFC_INTEGER_4 vector_length __attribute__((unused)))
+{
+ pack_internal (ret, array, mask, vector, array_length);
+}
+
+static void
+pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
+ const GFC_LOGICAL_4 *mask, const gfc_array_char *vector,
+ index_type size)
{
/* r.* indicates the return array. */
index_type rstride0;
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
- index_type size;
index_type nelem;
- size = GFC_DESCRIPTOR_SIZE (array);
dim = GFC_DESCRIPTOR_RANK (array);
for (n = 0; n < dim; n++)
{
}
}
}
+
+extern void pack_s (gfc_array_char *ret, const gfc_array_char *array,
+ const GFC_LOGICAL_4 *, const gfc_array_char *);
+export_proto(pack_s);
+
+void
+pack_s (gfc_array_char *ret, const gfc_array_char *array,
+ const GFC_LOGICAL_4 *mask, const gfc_array_char *vector)
+{
+ pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
+}
+
+extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4,
+ const gfc_array_char *array, const GFC_LOGICAL_4 *,
+ const gfc_array_char *, GFC_INTEGER_4,
+ GFC_INTEGER_4);
+export_proto(pack_s_char);
+
+void
+pack_s_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char *array, const GFC_LOGICAL_4 *mask,
+ const gfc_array_char *vector, GFC_INTEGER_4 array_length,
+ GFC_INTEGER_4 vector_length __attribute__((unused)))
+{
+ pack_s_internal (ret, array, mask, vector, array_length);
+}
typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;
typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) parray;
-extern void reshape (parray *, parray *, shape_type *, parray *, shape_type *);
-export_proto(reshape);
-
/* The shape parameter is ignored. We can currently deduce the shape from the
return array. */
-void
-reshape (parray *ret, parray *source, shape_type *shape,
- parray *pad, shape_type *order)
+static void
+reshape_internal (parray *ret, parray *source, shape_type *shape,
+ parray *pad, shape_type *order, index_type size)
{
/* r.* indicates the return array. */
index_type rcount[GFC_MAX_DIMENSIONS];
const char *src;
int n;
int dim;
- int size;
if (source->dim[0].stride == 0)
source->dim[0].stride = 1;
if (ret->data == NULL)
{
- size = GFC_DESCRIPTOR_SIZE (ret);
rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
rs = 1;
for (n=0; n < rdim; n++)
}
else
{
- size = GFC_DESCRIPTOR_SIZE (ret);
rdim = GFC_DESCRIPTOR_RANK (ret);
if (ret->dim[0].stride == 0)
ret->dim[0].stride = 1;
}
}
}
+
+extern void reshape (parray *, parray *, shape_type *, parray *, shape_type *);
+export_proto(reshape);
+
+void
+reshape (parray *ret, parray *source, shape_type *shape, parray *pad,
+ shape_type *order)
+{
+ reshape_internal (ret, source, shape, pad, order,
+ GFC_DESCRIPTOR_SIZE (source));
+}
+
+extern void reshape_char (parray *, GFC_INTEGER_4, parray *, shape_type *,
+ parray *, shape_type *, GFC_INTEGER_4,
+ GFC_INTEGER_4);
+export_proto(reshape_char);
+
+void
+reshape_char (parray *ret, GFC_INTEGER_4 ret_length __attribute__((unused)),
+ parray *source, shape_type *shape, parray *pad,
+ shape_type *order, GFC_INTEGER_4 source_length,
+ GFC_INTEGER_4 pad_length __attribute__((unused)))
+{
+ reshape_internal (ret, source, shape, pad, order, source_length);
+}
#include <string.h>
#include "libgfortran.h"
-extern void spread (gfc_array_char *, const gfc_array_char *,
- const index_type *, const index_type *);
-export_proto(spread);
-
-void
-spread (gfc_array_char *ret, const gfc_array_char *source,
- const index_type *along, const index_type *pncopies)
+static void
+spread_internal (gfc_array_char *ret, const gfc_array_char *source,
+ const index_type *along, const index_type *pncopies,
+ index_type size)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
- index_type size;
index_type ncopies;
srank = GFC_DESCRIPTOR_RANK(source);
ncopies = *pncopies;
- size = GFC_DESCRIPTOR_SIZE (source);
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
}
}
}
+
+extern void spread (gfc_array_char *, const gfc_array_char *,
+ const index_type *, const index_type *);
+export_proto(spread);
+
+void
+spread (gfc_array_char *ret, const gfc_array_char *source,
+ const index_type *along, const index_type *pncopies)
+{
+ spread_internal (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (source));
+}
+
+extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
+ const gfc_array_char *, const index_type *,
+ const index_type *, GFC_INTEGER_4);
+export_proto(spread_char);
+
+void
+spread_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char *source, const index_type *along,
+ const index_type *pncopies, GFC_INTEGER_4 source_length)
+{
+ spread_internal (ret, source, along, pncopies, source_length);
+}
extern void transpose (gfc_array_char *, gfc_array_char *);
export_proto(transpose);
-void
-transpose (gfc_array_char *ret, gfc_array_char *source)
+static void
+transpose_internal (gfc_array_char *ret, gfc_array_char *source,
+ index_type size)
{
/* r.* indicates the return array. */
index_type rxstride, rystride;
index_type xcount, ycount;
index_type x, y;
- index_type size;
assert (GFC_DESCRIPTOR_RANK (source) == 2
&& GFC_DESCRIPTOR_RANK (ret) == 2);
- size = GFC_DESCRIPTOR_SIZE (source);
-
if (ret->data == NULL)
{
assert (ret->dtype == source->dtype);
rptr += rxstride - (rystride * xcount);
}
}
+
+extern void transpose (gfc_array_char *, gfc_array_char *);
+export_proto(transpose);
+
+void
+transpose (gfc_array_char *ret, gfc_array_char *source)
+{
+ transpose_internal (ret, source, GFC_DESCRIPTOR_SIZE (source));
+}
+
+extern void transpose_char (gfc_array_char *, GFC_INTEGER_4,
+ gfc_array_char *, GFC_INTEGER_4);
+export_proto(transpose_char);
+
+void
+transpose_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ gfc_array_char *source, GFC_INTEGER_4 source_length)
+{
+ transpose_internal (ret, source, source_length);
+}
#include <string.h>
#include "libgfortran.h"
-extern void unpack1 (gfc_array_char *, const gfc_array_char *,
- const gfc_array_l4 *, const gfc_array_char *);
-iexport_proto(unpack1);
-
-void
-unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
- const gfc_array_l4 *mask, const gfc_array_char *field)
+static void
+unpack_internal (gfc_array_char *ret, const gfc_array_char *vector,
+ const gfc_array_l4 *mask, const gfc_array_char *field,
+ index_type size, index_type fsize)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
- index_type size;
- index_type fsize;
- size = GFC_DESCRIPTOR_SIZE (ret);
- /* A field element size of 0 actually means this is a scalar. */
- fsize = GFC_DESCRIPTOR_SIZE (field);
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
}
}
}
-iexport(unpack1);
+
+extern void unpack1 (gfc_array_char *, const gfc_array_char *,
+ const gfc_array_l4 *, const gfc_array_char *);
+export_proto(unpack1);
+
+void
+unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
+ const gfc_array_l4 *mask, const gfc_array_char *field)
+{
+ unpack_internal (ret, vector, mask, field,
+ GFC_DESCRIPTOR_SIZE (vector),
+ GFC_DESCRIPTOR_SIZE (field));
+}
+
+extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
+ const gfc_array_char *, const gfc_array_l4 *,
+ const gfc_array_char *, GFC_INTEGER_4,
+ GFC_INTEGER_4);
+export_proto(unpack1_char);
+
+void
+unpack1_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char *vector, const gfc_array_l4 *mask,
+ const gfc_array_char *field, GFC_INTEGER_4 vector_length,
+ GFC_INTEGER_4 field_length)
+{
+ unpack_internal (ret, vector, mask, field, vector_length, field_length);
+}
extern void unpack0 (gfc_array_char *, const gfc_array_char *,
const gfc_array_l4 *, char *);
tmp.dtype = 0;
tmp.data = field;
- unpack1 (ret, vector, mask, &tmp);
+ unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector), 0);
+}
+
+extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
+ const gfc_array_char *, const gfc_array_l4 *,
+ char *, GFC_INTEGER_4, GFC_INTEGER_4);
+export_proto(unpack0_char);
+
+void
+unpack0_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char *vector, const gfc_array_l4 *mask,
+ char *field, GFC_INTEGER_4 vector_length,
+ GFC_INTEGER_4 field_length __attribute__((unused)))
+{
+ gfc_array_char tmp;
+
+ tmp.dtype = 0;
+ tmp.data = field;
+ unpack_internal (ret, vector, mask, &tmp, vector_length, 0);
}
#include "libgfortran.h"'
include(iparm.m4)dnl
-void cshift1_`'atype_kind (gfc_array_char * ret,
- const gfc_array_char * array,
- const atype * h, const atype_name * pwhich);
-export_proto(cshift1_`'atype_kind);
-
-void
-cshift1_`'atype_kind (gfc_array_char * ret,
- const gfc_array_char * array,
- const atype * h, const atype_name * pwhich)
+static void
+cshift1 (gfc_array_char * ret, const gfc_array_char * array,
+ const atype * h, const atype_name * pwhich, index_type size)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
int which;
if (which < 0 || (which + 1) > GFC_DESCRIPTOR_RANK (array))
runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
- size = GFC_DESCRIPTOR_SIZE (ret);
-
if (ret->data == NULL)
{
int i;
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
/* Initialized for avoiding compiler warnings. */
}
}
}
+
+void cshift1_`'atype_kind (gfc_array_char *, const gfc_array_char *,
+ const atype *, const atype_name *);
+export_proto(cshift1_`'atype_kind);
+
+void
+cshift1_`'atype_kind (gfc_array_char * ret,
+ const gfc_array_char * array,
+ const atype * h, const atype_name * pwhich)
+{
+ cshift1 (ret, array, h, pwhich, GFC_DESCRIPTOR_SIZE (array));
+}
+
+void cshift1_`'atype_kind`'_char (gfc_array_char * ret, GFC_INTEGER_4,
+ const gfc_array_char * array,
+ const atype * h, const atype_name * pwhich,
+ GFC_INTEGER_4);
+export_proto(cshift1_`'atype_kind`'_char);
+
+void
+cshift1_`'atype_kind`'_char (gfc_array_char * ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char * array,
+ const atype * h, const atype_name * pwhich,
+ GFC_INTEGER_4 array_length)
+{
+ cshift1 (ret, array, h, pwhich, array_length);
+}
#include "libgfortran.h"'
include(iparm.m4)dnl
-static const char zeros[16] =
- {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
-
-extern void eoshift1_`'atype_kind (gfc_array_char *,
- const gfc_array_char *,
- const atype *, const char *,
- const atype_name *);
-export_proto(eoshift1_`'atype_kind);
-
-void
-eoshift1_`'atype_kind (gfc_array_char *ret,
- const gfc_array_char *array,
- const atype *h, const char *pbound,
- const atype_name *pwhich)
+static void
+eoshift1 (gfc_array_char *ret, const gfc_array_char *array, const atype *h,
+ const char *pbound, const atype_name *pwhich, index_type size,
+ char filler)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
int which;
else
which = 0;
- if (!pbound)
- pbound = zeros;
-
- size = GFC_DESCRIPTOR_SIZE (ret);
-
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
if (ret->data == NULL)
{
rstride[n] = ret->dim[dim].stride * size;
sstride[n] = array->dim[dim].stride * size;
- hstride[n] = h->dim[n].stride * size;
+ hstride[n] = h->dim[n].stride;
n++;
}
}
dest = rptr;
n = delta;
- while (n--)
- {
- memcpy (dest, pbound, size);
- dest += roffset;
- }
+ if (pbound)
+ while (n--)
+ {
+ memcpy (dest, pbound, size);
+ dest += roffset;
+ }
+ else
+ while (n--)
+ {
+ memset (dest, filler, size);
+ dest += roffset;
+ }
/* Advance to the next section. */
rptr += rstride0;
}
}
}
+
+void eoshift1_`'atype_kind (gfc_array_char *, const gfc_array_char *,
+ const atype *, const char *, const atype_name *);
+export_proto(eoshift1_`'atype_kind);
+
+void
+eoshift1_`'atype_kind (gfc_array_char *ret, const gfc_array_char *array,
+ const atype *h, const char *pbound,
+ const atype_name *pwhich)
+{
+ eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0);
+}
+
+void eoshift1_`'atype_kind`'_char (gfc_array_char *, GFC_INTEGER_4,
+ const gfc_array_char *, const atype *,
+ const char *, const atype_name *,
+ GFC_INTEGER_4, GFC_INTEGER_4);
+export_proto(eoshift1_`'atype_kind`'_char);
+
+void
+eoshift1_`'atype_kind`'_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char *array, const atype *h,
+ const char *pbound, const atype_name *pwhich,
+ GFC_INTEGER_4 array_length,
+ GFC_INTEGER_4 bound_length
+ __attribute__((unused)))
+{
+ eoshift1 (ret, array, h, pbound, pwhich, array_length, ' ');
+}
#include "libgfortran.h"'
include(iparm.m4)dnl
-static const char zeros[16] =
- {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
-
-extern void eoshift3_`'atype_kind (gfc_array_char *, gfc_array_char *,
- atype *, const gfc_array_char *,
- atype_name *);
-export_proto(eoshift3_`'atype_kind);
-
-void
-eoshift3_`'atype_kind (gfc_array_char *ret, gfc_array_char *array,
- atype *h, const gfc_array_char *bound,
- atype_name *pwhich)
+static void
+eoshift3 (gfc_array_char *ret, const gfc_array_char *array, const atype *h,
+ const gfc_array_char *bound, const atype_name *pwhich,
+ index_type size, char filler)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
- index_type size;
index_type len;
index_type n;
int which;
else
which = 0;
- size = GFC_DESCRIPTOR_SIZE (ret);
if (ret->data == NULL)
{
int i;
extent[0] = 1;
count[0] = 0;
- size = GFC_DESCRIPTOR_SIZE (array);
n = 0;
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
{
if (bound)
bptr = bound->data;
else
- bptr = zeros;
+ bptr = NULL;
while (rptr)
{
dest = rptr;
n = delta;
- while (n--)
- {
- memcpy (dest, bptr, size);
- dest += roffset;
- }
+ if (bptr)
+ while (n--)
+ {
+ memcpy (dest, bptr, size);
+ dest += roffset;
+ }
+ else
+ while (n--)
+ {
+ memset (dest, filler, size);
+ dest += roffset;
+ }
/* Advance to the next section. */
rptr += rstride0;
}
}
}
+
+extern void eoshift3_`'atype_kind (gfc_array_char *, const gfc_array_char *,
+ const atype *, const gfc_array_char *,
+ const atype_name *);
+export_proto(eoshift3_`'atype_kind);
+
+void
+eoshift3_`'atype_kind (gfc_array_char *ret, const gfc_array_char *array,
+ const atype *h, const gfc_array_char *bound,
+ const atype_name *pwhich)
+{
+ eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), 0);
+}
+
+extern void eoshift3_`'atype_kind`'_char (gfc_array_char *, GFC_INTEGER_4,
+ const gfc_array_char *,
+ const atype *,
+ const gfc_array_char *,
+ const atype_name *, GFC_INTEGER_4,
+ GFC_INTEGER_4);
+export_proto(eoshift3_`'atype_kind`'_char);
+
+void
+eoshift3_`'atype_kind`'_char (gfc_array_char *ret,
+ GFC_INTEGER_4 ret_length __attribute__((unused)),
+ const gfc_array_char *array, const atype *h,
+ const gfc_array_char *bound,
+ const atype_name *pwhich,
+ GFC_INTEGER_4 array_length,
+ GFC_INTEGER_4 bound_length
+ __attribute__((unused)))
+{
+ eoshift3 (ret, array, h, bound, pwhich, array_length, ' ');
+}
projects / platform / upstream / linaro-gcc.git / commitdiff