git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/19269 (transpose(reshape(...)) of character array segfaults.) 

gcc/fortran/
	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.

libgfortran/
	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.

From-SVN: r104217
This commit is contained in:
Richard Sandiford 2005-09-13 07:15:01 +00:00 committed by Richard Sandiford
parent 7f26dfa379
commit 7823229bc3
36 changed files with 1451 additions and 439 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/fortran/ChangeLog
View File

@ -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.

37
gcc/fortran/iresolve.c
View File

@ -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" : "");
}

4
gcc/fortran/trans-array.c
View File

@ -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
{

12
gcc/testsuite/ChangeLog
View File

@ -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

8
gcc/testsuite/gfortran.dg/char_associated_1.f90 Normal file
View File

@ -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

40
gcc/testsuite/gfortran.dg/char_cshift_1.f90 Normal file
View File

@ -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

45
gcc/testsuite/gfortran.dg/char_cshift_2.f90 Normal file
View File

@ -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

50
gcc/testsuite/gfortran.dg/char_eoshift_1.f90 Normal file
View File

@ -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

57
gcc/testsuite/gfortran.dg/char_eoshift_2.f90 Normal file
View File

@ -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

54
gcc/testsuite/gfortran.dg/char_eoshift_3.f90 Normal file
View File

@ -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

61
gcc/testsuite/gfortran.dg/char_eoshift_4.f90 Normal file
View File

@ -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

59
gcc/testsuite/gfortran.dg/char_pack_1.f90 Normal file
View File

@ -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

53
gcc/testsuite/gfortran.dg/char_pack_2.f90 Normal file
View File

@ -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

43
gcc/testsuite/gfortran.dg/char_reshape_1.f90 Normal file
View File

@ -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

32
gcc/testsuite/gfortran.dg/char_spread_1.f90 Normal file
View File

@ -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

29
gcc/testsuite/gfortran.dg/char_transpose_1.f90 Normal file
View File

@ -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

44
gcc/testsuite/gfortran.dg/char_unpack_1.f90 Normal file
View File

@ -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

40
gcc/testsuite/gfortran.dg/char_unpack_2.f90 Normal file
View File

@ -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

64
libgfortran/ChangeLog
View File

@ -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

44
libgfortran/generated/cshift1_4.c
View File

@ -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);
}

44
libgfortran/generated/cshift1_8.c
View File

@ -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);
}

74
libgfortran/generated/eoshift1_4.c
View File

@ -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, ' ');
}

74
libgfortran/generated/eoshift1_8.c
View File

@ -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, ' ');
}

72
libgfortran/generated/eoshift3_4.c
View File

@ -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, ' ');
}

72
libgfortran/generated/eoshift3_8.c
View File

@ -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, ' ');
}

84
libgfortran/intrinsics/cshift0.c
View File

@ -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,
}
}
#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); \
}
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_CSHIFT (1);
DEFINE_CSHIFT (2);
DEFINE_CSHIFT (4);
DEFINE_CSHIFT (8);

122
libgfortran/intrinsics/eoshift0.c
View File

@ -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);
#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, ' '); \
}
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_EOSHIFT (1);
DEFINE_EOSHIFT (2);
DEFINE_EOSHIFT (4);
DEFINE_EOSHIFT (8);

122
libgfortran/intrinsics/eoshift2.c
View File

@ -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);
#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, ' '); \
}
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_EOSHIFT (1);
DEFINE_EOSHIFT (2);
DEFINE_EOSHIFT (4);
DEFINE_EOSHIFT (8);

77
libgfortran/intrinsics/pack_generic.c
View File

@ -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);
}

37
libgfortran/intrinsics/reshape_generic.c
View File

@ -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);
}

38
libgfortran/intrinsics/spread_generic.c
View File

@ -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);
}

29
libgfortran/intrinsics/transpose_generic.c
View File

@ -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);
}

67
libgfortran/intrinsics/unpack_generic.c
View File

@ -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);
}

44
libgfortran/m4/cshift1.m4
View File

@ -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);
}

74
libgfortran/m4/eoshift1.m4
View File

@ -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, ' ');
}

72
libgfortran/m4/eoshift3.m4
View File

@ -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, ' ');
}