diff options
36 files changed, 1454 insertions, 442 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4378597b5ae..02f8f3fa456 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 ef43946a55b..ed043a6b451 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 552bae69f2e..a7a1c558d0e 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 26919da7139..a909f302345 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 00000000000..f38f27331da --- /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 00000000000..7ba61e7095b --- /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 00000000000..89d452f713e --- /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 00000000000..ba51fa13193 --- /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 00000000000..bdb654c77ce --- /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 00000000000..62bc04c8004 --- /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 00000000000..b7c86709034 --- /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 00000000000..839f6c6b1a1 --- /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 00000000000..777db53f83c --- /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 00000000000..b3b624459c9 --- /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 00000000000..0d51f6046d5 --- /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 00000000000..90605d6458d --- /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 00000000000..65dd888a8d8 --- /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 00000000000..3b2c4a32729 --- /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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index d36e500ddca..e025ebc51db 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,67 @@ +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 diff --git a/libgfortran/generated/cshift1_4.c b/libgfortran/generated/cshift1_4.c index 43ab52b4db2..1fe0e68139f 100644 --- a/libgfortran/generated/cshift1_4.c +++ b/libgfortran/generated/cshift1_4.c @@ -34,15 +34,9 @@ Boston, MA 02110-1301, USA. */ #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]; @@ -64,7 +58,6 @@ cshift1_4 (gfc_array_char * ret, 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; @@ -78,8 +71,6 @@ cshift1_4 (gfc_array_char * ret, 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; @@ -101,7 +92,6 @@ cshift1_4 (gfc_array_char * ret, extent[0] = 1; count[0] = 0; - size = GFC_DESCRIPTOR_SIZE (array); n = 0; /* Initialized for avoiding compiler warnings. */ @@ -201,3 +191,31 @@ cshift1_4 (gfc_array_char * ret, } } } + +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); +} diff --git a/libgfortran/generated/cshift1_8.c b/libgfortran/generated/cshift1_8.c index c9664b1ed9f..8b0cb03f1a8 100644 --- a/libgfortran/generated/cshift1_8.c +++ b/libgfortran/generated/cshift1_8.c @@ -34,15 +34,9 @@ Boston, MA 02110-1301, USA. */ #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]; @@ -64,7 +58,6 @@ cshift1_8 (gfc_array_char * ret, 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; @@ -78,8 +71,6 @@ cshift1_8 (gfc_array_char * ret, 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; @@ -101,7 +92,6 @@ cshift1_8 (gfc_array_char * ret, extent[0] = 1; count[0] = 0; - size = GFC_DESCRIPTOR_SIZE (array); n = 0; /* Initialized for avoiding compiler warnings. */ @@ -201,3 +191,31 @@ cshift1_8 (gfc_array_char * ret, } } } + +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); +} diff --git a/libgfortran/generated/eoshift1_4.c b/libgfortran/generated/eoshift1_4.c index d2580f8974a..e08042ac37d 100644 --- a/libgfortran/generated/eoshift1_4.c +++ b/libgfortran/generated/eoshift1_4.c @@ -34,20 +34,10 @@ Boston, MA 02110-1301, USA. */ #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]; @@ -69,7 +59,6 @@ eoshift1_4 (gfc_array_char *ret, 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; @@ -87,14 +76,8 @@ eoshift1_4 (gfc_array_char *ret, 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) { @@ -135,7 +118,7 @@ eoshift1_4 (gfc_array_char *ret, 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++; } } @@ -186,11 +169,18 @@ eoshift1_4 (gfc_array_char *ret, 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; @@ -225,3 +215,33 @@ eoshift1_4 (gfc_array_char *ret, } } } + +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, ' '); +} diff --git a/libgfortran/generated/eoshift1_8.c b/libgfortran/generated/eoshift1_8.c index 5da23ce95e5..f375a825113 100644 --- a/libgfortran/generated/eoshift1_8.c +++ b/libgfortran/generated/eoshift1_8.c @@ -34,20 +34,10 @@ Boston, MA 02110-1301, USA. */ #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]; @@ -69,7 +59,6 @@ eoshift1_8 (gfc_array_char *ret, 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; @@ -87,14 +76,8 @@ eoshift1_8 (gfc_array_char *ret, 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) { @@ -135,7 +118,7 @@ eoshift1_8 (gfc_array_char *ret, 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++; } } @@ -186,11 +169,18 @@ eoshift1_8 (gfc_array_char *ret, 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; @@ -225,3 +215,33 @@ eoshift1_8 (gfc_array_char *ret, } } } + +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, ' '); +} diff --git a/libgfortran/generated/eoshift3_4.c b/libgfortran/generated/eoshift3_4.c index ab0d4e75876..09e0207cef9 100644 --- a/libgfortran/generated/eoshift3_4.c +++ b/libgfortran/generated/eoshift3_4.c @@ -34,18 +34,10 @@ Boston, MA 02110-1301, USA. */ #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]; @@ -71,7 +63,6 @@ eoshift3_4 (gfc_array_char *ret, gfc_array_char *array, 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; @@ -89,7 +80,6 @@ eoshift3_4 (gfc_array_char *ret, gfc_array_char *array, else which = 0; - size = GFC_DESCRIPTOR_SIZE (ret); if (ret->data == NULL) { int i; @@ -112,7 +102,6 @@ eoshift3_4 (gfc_array_char *ret, gfc_array_char *array, extent[0] = 1; count[0] = 0; - size = GFC_DESCRIPTOR_SIZE (array); n = 0; for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) { @@ -161,7 +150,7 @@ eoshift3_4 (gfc_array_char *ret, gfc_array_char *array, if (bound) bptr = bound->data; else - bptr = zeros; + bptr = NULL; while (rptr) { @@ -195,11 +184,18 @@ eoshift3_4 (gfc_array_char *ret, gfc_array_char *array, 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; @@ -237,3 +233,37 @@ eoshift3_4 (gfc_array_char *ret, gfc_array_char *array, } } } + +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, ' '); +} diff --git a/libgfortran/generated/eoshift3_8.c b/libgfortran/generated/eoshift3_8.c index 81571f43bbe..c652d98d018 100644 --- a/libgfortran/generated/eoshift3_8.c +++ b/libgfortran/generated/eoshift3_8.c @@ -34,18 +34,10 @@ Boston, MA 02110-1301, USA. */ #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]; @@ -71,7 +63,6 @@ eoshift3_8 (gfc_array_char *ret, gfc_array_char *array, 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; @@ -89,7 +80,6 @@ eoshift3_8 (gfc_array_char *ret, gfc_array_char *array, else which = 0; - size = GFC_DESCRIPTOR_SIZE (ret); if (ret->data == NULL) { int i; @@ -112,7 +102,6 @@ eoshift3_8 (gfc_array_char *ret, gfc_array_char *array, extent[0] = 1; count[0] = 0; - size = GFC_DESCRIPTOR_SIZE (array); n = 0; for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) { @@ -161,7 +150,7 @@ eoshift3_8 (gfc_array_char *ret, gfc_array_char *array, if (bound) bptr = bound->data; else - bptr = zeros; + bptr = NULL; while (rptr) { @@ -195,11 +184,18 @@ eoshift3_8 (gfc_array_char *ret, gfc_array_char *array, 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; @@ -237,3 +233,37 @@ eoshift3_8 (gfc_array_char *ret, gfc_array_char *array, } } } + +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, ' '); +} diff --git a/libgfortran/intrinsics/cshift0.c b/libgfortran/intrinsics/cshift0.c index e491e178e36..199e28314ce 100644 --- a/libgfortran/intrinsics/cshift0.c +++ b/libgfortran/intrinsics/cshift0.c @@ -78,7 +78,7 @@ DEF_COPY_LOOP(cdouble, _Complex double) 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]; @@ -95,7 +95,6 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array, 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; @@ -107,7 +106,6 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array, 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. */ @@ -298,51 +296,37 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array, } } - -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); diff --git a/libgfortran/intrinsics/eoshift0.c b/libgfortran/intrinsics/eoshift0.c index b8dfb40be3c..6f02f66d36e 100644 --- a/libgfortran/intrinsics/eoshift0.c +++ b/libgfortran/intrinsics/eoshift0.c @@ -34,15 +34,13 @@ Boston, MA 02110-1301, USA. */ #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]; @@ -60,7 +58,6 @@ eoshift0 (gfc_array_char * ret, const gfc_array_char * array, index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type dim; - index_type size; index_type len; index_type n; @@ -70,11 +67,6 @@ eoshift0 (gfc_array_char * ret, const gfc_array_char * array, soffset = 0; roffset = 0; - if (!pbound) - pbound = zeros; - - size = GFC_DESCRIPTOR_SIZE (ret); - if (ret->data == NULL) { int i; @@ -98,7 +90,6 @@ eoshift0 (gfc_array_char * ret, const gfc_array_char * array, extent[0] = 1; count[0] = 0; - size = GFC_DESCRIPTOR_SIZE (array); n = 0; for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) { @@ -174,11 +165,18 @@ eoshift0 (gfc_array_char * ret, const gfc_array_char * array, 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; @@ -212,57 +210,43 @@ eoshift0 (gfc_array_char * ret, const gfc_array_char * array, } -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); diff --git a/libgfortran/intrinsics/eoshift2.c b/libgfortran/intrinsics/eoshift2.c index dde9e1e64fa..f4990292ec4 100644 --- a/libgfortran/intrinsics/eoshift2.c +++ b/libgfortran/intrinsics/eoshift2.c @@ -34,15 +34,13 @@ Boston, MA 02110-1301, USA. */ #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]; @@ -64,7 +62,6 @@ eoshift2 (gfc_array_char *ret, const gfc_array_char *array, index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type dim; - index_type size; index_type len; index_type n; @@ -74,8 +71,6 @@ eoshift2 (gfc_array_char *ret, const gfc_array_char *array, soffset = 0; roffset = 0; - size = GFC_DESCRIPTOR_SIZE (ret); - if (ret->data == NULL) { int i; @@ -99,7 +94,6 @@ eoshift2 (gfc_array_char *ret, const gfc_array_char *array, extent[0] = 1; count[0] = 0; - size = GFC_DESCRIPTOR_SIZE (array); n = 0; for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) { @@ -156,7 +150,7 @@ eoshift2 (gfc_array_char *ret, const gfc_array_char *array, if (bound) bptr = bound->data; else - bptr = zeros; + bptr = NULL; while (rptr) { @@ -187,11 +181,18 @@ eoshift2 (gfc_array_char *ret, const gfc_array_char *array, 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; @@ -228,57 +229,44 @@ eoshift2 (gfc_array_char *ret, const gfc_array_char *array, } -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); diff --git a/libgfortran/intrinsics/pack_generic.c b/libgfortran/intrinsics/pack_generic.c index 2b0be00e11d..f07b5aac905 100644 --- a/libgfortran/intrinsics/pack_generic.c +++ b/libgfortran/intrinsics/pack_generic.c @@ -74,13 +74,10 @@ Boston, MA 02110-1301, USA. */ 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; @@ -98,10 +95,8 @@ pack (gfc_array_char *ret, const gfc_array_char *array, 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++) { @@ -189,7 +184,7 @@ pack (gfc_array_char *ret, const gfc_array_char *array, else { count[n]++; - mptr += mstride[n]; + m += mstride[n]; } } } @@ -277,13 +272,36 @@ pack (gfc_array_char *ret, const gfc_array_char *array, } } -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; @@ -297,10 +315,8 @@ pack_s (gfc_array_char *ret, const gfc_array_char *array, 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++) { @@ -426,3 +442,30 @@ pack_s (gfc_array_char *ret, const gfc_array_char *array, } } } + +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); +} diff --git a/libgfortran/intrinsics/reshape_generic.c b/libgfortran/intrinsics/reshape_generic.c index 1dc78cb3745..8cbdc89c0e2 100644 --- a/libgfortran/intrinsics/reshape_generic.c +++ b/libgfortran/intrinsics/reshape_generic.c @@ -37,15 +37,12 @@ Boston, MA 02110-1301, USA. */ 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]; @@ -76,7 +73,6 @@ reshape (parray *ret, parray *source, shape_type *shape, const char *src; int n; int dim; - int size; if (source->dim[0].stride == 0) source->dim[0].stride = 1; @@ -89,7 +85,6 @@ reshape (parray *ret, parray *source, shape_type *shape, 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++) @@ -106,7 +101,6 @@ reshape (parray *ret, parray *source, shape_type *shape, } else { - size = GFC_DESCRIPTOR_SIZE (ret); rdim = GFC_DESCRIPTOR_RANK (ret); if (ret->dim[0].stride == 0) ret->dim[0].stride = 1; @@ -260,3 +254,28 @@ reshape (parray *ret, parray *source, shape_type *shape, } } } + +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); +} diff --git a/libgfortran/intrinsics/spread_generic.c b/libgfortran/intrinsics/spread_generic.c index 5de8f9c4fdb..a9cddb0f689 100644 --- a/libgfortran/intrinsics/spread_generic.c +++ b/libgfortran/intrinsics/spread_generic.c @@ -34,13 +34,10 @@ Boston, MA 02110-1301, USA. */ #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]; @@ -60,7 +57,6 @@ spread (gfc_array_char *ret, const gfc_array_char *source, index_type extent[GFC_MAX_DIMENSIONS]; index_type n; index_type dim; - index_type size; index_type ncopies; srank = GFC_DESCRIPTOR_RANK(source); @@ -74,7 +70,6 @@ spread (gfc_array_char *ret, const gfc_array_char *source, ncopies = *pncopies; - size = GFC_DESCRIPTOR_SIZE (source); if (ret->data == NULL) { /* The front end has signalled that we need to populate the @@ -180,3 +175,28 @@ spread (gfc_array_char *ret, const gfc_array_char *source, } } } + +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); +} diff --git a/libgfortran/intrinsics/transpose_generic.c b/libgfortran/intrinsics/transpose_generic.c index 3b5ac96c63b..bd47073790b 100644 --- a/libgfortran/intrinsics/transpose_generic.c +++ b/libgfortran/intrinsics/transpose_generic.c @@ -37,8 +37,9 @@ Boston, MA 02110-1301, USA. */ 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; @@ -49,13 +50,10 @@ transpose (gfc_array_char *ret, gfc_array_char *source) 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); @@ -100,3 +98,24 @@ transpose (gfc_array_char *ret, gfc_array_char *source) 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); +} diff --git a/libgfortran/intrinsics/unpack_generic.c b/libgfortran/intrinsics/unpack_generic.c index 1d6ff3d7d40..ac4394c21fe 100644 --- a/libgfortran/intrinsics/unpack_generic.c +++ b/libgfortran/intrinsics/unpack_generic.c @@ -34,13 +34,10 @@ Boston, MA 02110-1301, USA. */ #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]; @@ -63,12 +60,7 @@ unpack1 (gfc_array_char *ret, const gfc_array_char *vector, 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 @@ -177,7 +169,35 @@ unpack1 (gfc_array_char *ret, const gfc_array_char *vector, } } } -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 *); @@ -191,5 +211,24 @@ unpack0 (gfc_array_char *ret, const gfc_array_char *vector, 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); } diff --git a/libgfortran/m4/cshift1.m4 b/libgfortran/m4/cshift1.m4 index 59c5d7e5de8..5c3d0b01324 100644 --- a/libgfortran/m4/cshift1.m4 +++ b/libgfortran/m4/cshift1.m4 @@ -35,15 +35,9 @@ Boston, MA 02110-1301, USA. */ #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]; @@ -65,7 +59,6 @@ cshift1_`'atype_kind (gfc_array_char * ret, 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; @@ -79,8 +72,6 @@ cshift1_`'atype_kind (gfc_array_char * ret, 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; @@ -102,7 +93,6 @@ cshift1_`'atype_kind (gfc_array_char * ret, extent[0] = 1; count[0] = 0; - size = GFC_DESCRIPTOR_SIZE (array); n = 0; /* Initialized for avoiding compiler warnings. */ @@ -202,3 +192,31 @@ cshift1_`'atype_kind (gfc_array_char * ret, } } } + +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); +} diff --git a/libgfortran/m4/eoshift1.m4 b/libgfortran/m4/eoshift1.m4 index 0c55c8711b6..b5245ee42ea 100644 --- a/libgfortran/m4/eoshift1.m4 +++ b/libgfortran/m4/eoshift1.m4 @@ -35,20 +35,10 @@ Boston, MA 02110-1301, USA. */ #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]; @@ -70,7 +60,6 @@ eoshift1_`'atype_kind (gfc_array_char *ret, 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; @@ -88,14 +77,8 @@ eoshift1_`'atype_kind (gfc_array_char *ret, 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) { @@ -136,7 +119,7 @@ eoshift1_`'atype_kind (gfc_array_char *ret, 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++; } } @@ -187,11 +170,18 @@ eoshift1_`'atype_kind (gfc_array_char *ret, 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; @@ -226,3 +216,33 @@ eoshift1_`'atype_kind (gfc_array_char *ret, } } } + +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, ' '); +} diff --git a/libgfortran/m4/eoshift3.m4 b/libgfortran/m4/eoshift3.m4 index 1df01b57637..aa4d8ddd333 100644 --- a/libgfortran/m4/eoshift3.m4 +++ b/libgfortran/m4/eoshift3.m4 @@ -35,18 +35,10 @@ Boston, MA 02110-1301, USA. */ #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]; @@ -72,7 +64,6 @@ eoshift3_`'atype_kind (gfc_array_char *ret, gfc_array_char *array, 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; @@ -90,7 +81,6 @@ eoshift3_`'atype_kind (gfc_array_char *ret, gfc_array_char *array, else which = 0; - size = GFC_DESCRIPTOR_SIZE (ret); if (ret->data == NULL) { int i; @@ -113,7 +103,6 @@ eoshift3_`'atype_kind (gfc_array_char *ret, gfc_array_char *array, extent[0] = 1; count[0] = 0; - size = GFC_DESCRIPTOR_SIZE (array); n = 0; for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) { @@ -162,7 +151,7 @@ eoshift3_`'atype_kind (gfc_array_char *ret, gfc_array_char *array, if (bound) bptr = bound->data; else - bptr = zeros; + bptr = NULL; while (rptr) { @@ -196,11 +185,18 @@ eoshift3_`'atype_kind (gfc_array_char *ret, gfc_array_char *array, 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; @@ -238,3 +234,37 @@ eoshift3_`'atype_kind (gfc_array_char *ret, gfc_array_char *array, } } } + +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, ' '); +} |