procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/36313 ([F03] {MIN,MAX}{LOC,VAL} should accept character arguments)

Browse source 
2017-12-03  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/36313
	* check.c (gfc_check_minval_maxval): Use
	int_orLreal_or_char_check_f2003 for array argument.
	* iresolve.c (gfc_resolve_maxval): Insert number in
	function name for character arguments.
	(gfc_resolve_minval): Likewise.
	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc):
	Fix comment.
	(gfc_conv_intrinsic_minmaxval): Resort arguments and call library
	function if dealing with a character function.

2017-12-03  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/36313
	* Makefile.am: Add new files for character-valued
	maxval and minval.
	* Makefile.in: Regenerated.
	* gfortran.map: Add new functions.
	* m4/iforeach-s2.m4: New file.
	* m4/ifunction-s2.m4: New file.
	* m4/iparm.m4: Add intitval for minval and maxval.
	* m4/maxval0s.m4: New file.
	* m4/maxval1s.m4: New file.
	* m4/minval0s.m4: New file.
	* m4/minval1s.m4: New file.
        * generated/maxval0_s1.c: New file.
        * generated/maxval0_s4.c: New file.
        * generated/maxval1_s1.c: New file.
        * generated/maxval1_s4.c: New file.
        * generated/minval0_s1.c: New file.
        * generated/minval0_s4.c: New file.
        * generated/minval1_s1.c: New file.
        * generated/minval1_s4.c: New file.

2017-12-03  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/36313
	* gfortran.dg/maxval_char_1.f90: New test.
	* gfortran.dg/maxval_char_2.f90: New test.
	* gfortran.dg/maxval_char_3.f90: New test.
	* gfortran.dg/maxval_char_4.f90: New test.
	* gfortran.dg/minval_char_1.f90: New test.
	* gfortran.dg/minval_char_2.f90: New test.
	* gfortran.dg/minval_char_3.f90: New test.
	* gfortran.dg/minval_char_4.f90: New test.

From-SVN: r255367
This commit is contained in:
Thomas Koenig 2017-12-03 20:14:05 +00:00
parent af5ad1e2e5
commit 0ac7425470
32 changed files with 4988 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
gcc/fortran/ChangeLog
View file

@ -1,3 +1,16 @@
2017-12-03 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/36313
* check.c (gfc_check_minval_maxval): Use
int_orLreal_or_char_check_f2003 for array argument.
* iresolve.c (gfc_resolve_maxval): Insert number in
function name for character arguments.
(gfc_resolve_minval): Likewise.
* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc):
Fix comment.
(gfc_conv_intrinsic_minmaxval): Resort arguments and call library
function if dealing with a character function.
2017-12-01 Qing Zhao <qing.zhao@oracle.com>
* decl.c (gfc_get_pdt_instance): Adjust the call to sprintf

2
gcc/fortran/check.c
View file

@ -3317,7 +3317,7 @@ check_reduction (gfc_actual_arglist *ap)
bool
gfc_check_minval_maxval (gfc_actual_arglist *ap)
{
if (!int_or_real_check (ap->expr, 0)
if (!int_or_real_or_char_check_f2003 (ap->expr, 0)
|| !array_check (ap->expr, 0))
return false;

22
gcc/fortran/iresolve.c
View file

@ -1823,9 +1823,14 @@ gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
else
name = "maxval";
f->value.function.name
= gfc_get_string (PREFIX ("%s_%c%d"), name,
gfc_type_letter (array->ts.type), array->ts.kind);
if (array->ts.type != BT_CHARACTER)
f->value.function.name
= gfc_get_string (PREFIX ("%s_%c%d"), name,
gfc_type_letter (array->ts.type), array->ts.kind);
else
f->value.function.name
= gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
gfc_type_letter (array->ts.type), array->ts.kind);
}
@ -2023,9 +2028,14 @@ gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
else
name = "minval";
f->value.function.name
= gfc_get_string (PREFIX ("%s_%c%d"), name,
gfc_type_letter (array->ts.type), array->ts.kind);
if (array->ts.type != BT_CHARACTER)
f->value.function.name
= gfc_get_string (PREFIX ("%s_%c%d"), name,
gfc_type_letter (array->ts.type), array->ts.kind);
else
f->value.function.name
= gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
gfc_type_letter (array->ts.type), array->ts.kind);
}

32
gcc/fortran/trans-intrinsic.c
View file

@ -4571,7 +4571,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
actual = expr->value.function.actual;
arrayexpr = actual->expr;
/* Special case for character maxval. Remove unneeded actual
/* Special case for character maxloc. Remove unneeded actual
arguments, then call a library function. */
if (arrayexpr->ts.type == BT_CHARACTER)
@ -5039,6 +5039,34 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
return;
}
actual = expr->value.function.actual;
arrayexpr = actual->expr;
if (arrayexpr->ts.type == BT_CHARACTER)
{
gfc_actual_arglist *a2, *a3;
a2 = actual->next; /* dim */
a3 = a2->next; /* mask */
if (a2->expr == NULL || expr->rank == 0)
{
if (a3->expr == NULL)
actual->next = NULL;
else
{
actual->next = a3;
a2->next = NULL;
}
gfc_free_actual_arglist (a2);
}
else
if (a3->expr == NULL)
{
a2->next = NULL;
gfc_free_actual_arglist (a3);
}
gfc_conv_intrinsic_funcall (se, expr);
return;
}
type = gfc_typenode_for_spec (&expr->ts);
/* Initialize the result. */
limit = gfc_create_var (type, "limit");
@ -5087,8 +5115,6 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
gfc_add_modify (&se->pre, limit, tmp);
/* Walk the arguments. */
actual = expr->value.function.actual;
arrayexpr = actual->expr;
arrayss = gfc_walk_expr (arrayexpr);
gcc_assert (arrayss != gfc_ss_terminator);

12
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,15 @@
2017-12-03 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/36313
* gfortran.dg/maxval_char_1.f90: New test.
* gfortran.dg/maxval_char_2.f90: New test.
* gfortran.dg/maxval_char_3.f90: New test.
* gfortran.dg/maxval_char_4.f90: New test.
* gfortran.dg/minval_char_1.f90: New test.
* gfortran.dg/minval_char_2.f90: New test.
* gfortran.dg/minval_char_3.f90: New test.
* gfortran.dg/minval_char_4.f90: New test.
2017-12-03 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/831916

42
gcc/testsuite/gfortran.dg/maxval_char_1.f90 Normal file
View file

@ -0,0 +1,42 @@
! { dg-do run }
program main
implicit none
integer, parameter :: n=5, m=3
character(len=5), dimension(n) :: a
character(len=5), dimension(n,m) :: b
character(len=5) :: res
integer, dimension(n,m) :: v
real, dimension(n,m) :: r
integer :: i,j
logical, dimension(n,m) :: mask
character(len=5), dimension(:,:), allocatable :: empty
character(len=5) , parameter :: all_zero = achar(0) // achar(0) // achar(0) // achar(0) // achar(0)
logical :: smask
write (unit=a,fmt='(I5.5)') (21-i*i+6*i,i=1,n)
res = maxval(a)
if (res /= '00030') call abort
res = maxval(a,dim=1)
if (res /= '00030') call abort
do
call random_number(r)
if (count(r>0.2) > 1) exit
end do
v = int(r * 100)
write (unit=b,fmt='(I5.5)') v
write (unit=res,fmt='(I5.5)') maxval(v)
if (res /= maxval(b)) call abort
smask = .true.
if (res /= maxval(b, smask)) call abort
smask = .false.
if (all_zero /= maxval(b, smask)) call abort
mask = v < 30
write (unit=res,fmt='(I5.5)') maxval(v,mask)
if (res /= maxval(b, mask)) call abort
mask = .false.
if (maxval(b, mask) /= all_zero) call abort
allocate (empty(0:3,0))
res = maxval(empty)
if (res /= all_zero) call abort
end program main

40
gcc/testsuite/gfortran.dg/maxval_char_2.f90 Normal file
View file

@ -0,0 +1,40 @@
! { dg-do run }
program main
implicit none
integer, parameter :: n=5, m=3
character(kind=4,len=5), dimension(n) :: a
character(kind=4,len=5), dimension(n,m) :: b
character(kind=4,len=5) :: res
integer, dimension(n,m) :: v
real, dimension(n,m) :: r
integer :: i,j
logical, dimension(n,m) :: mask
character(kind=4,len=5), dimension(:,:), allocatable :: empty
character(kind=4,len=5) , parameter :: all_zero = achar(0) // achar(0) // achar(0) // achar(0) // achar(0)
logical :: smask
write (unit=a,fmt='(I5.5)') (21-i*i+6*i,i=1,n)
res = maxval(a)
if (res /= 4_'00030') call abort
do
call random_number(r)
if (count(r>0.2) > 1) exit
end do
v = int(r * 100)
write (unit=b,fmt='(I5.5)') v
write (unit=res,fmt='(I5.5)') maxval(v)
if (res /= maxval(b)) call abort
smask = .true.
if (res /= maxval(b, smask)) call abort
smask = .false.
if (all_zero /= maxval(b, smask)) call abort
mask = v < 30
write (unit=res,fmt='(I5.5)') maxval(v,mask)
if (res /= maxval(b, mask)) call abort
mask = .false.
if (maxval(b, mask) /= all_zero) call abort
allocate (empty(0:3,0))
res = maxval(empty)
if (res /= all_zero) call abort
end program main

69
gcc/testsuite/gfortran.dg/maxval_char_3.f90 Normal file
View file

@ -0,0 +1,69 @@
! { dg-do run }
program main
implicit none
integer, parameter :: n=5
character(len=6), dimension(n,n) :: a
integer, dimension(n,n) :: v
character(len=6), dimension(n) :: r1, r2
character(len=6), dimension(:,:), allocatable :: a_alloc
integer, dimension(:,:), allocatable :: v_alloc
character(len=6), parameter :: zero = achar(0) // achar(0) // achar(0) // achar(0) // achar(0) // achar(0)
integer :: i
character(len=6),dimension(1) :: ret
logical, dimension(n,n) :: mask
logical :: smask
v = reshape([(i*i+200-17*i,i=1,n*n)],shape(v))
write (unit=a,fmt='(I6.6)') (i*i+200-17*i,i=1,n*n)
r1 = maxval(a,dim=1)
write (unit=r2,fmt='(I6.6)') maxval(v,dim=1)
if (any (r1 /= r2)) call abort
r1 = 'x'
write (unit=r1,fmt='(I6.6)') maxval(v,dim=1)
if (any (r1 /= r2)) call abort
r1 = 'y'
r1 = maxval(a,dim=2)
write (unit=r2,fmt='(I6.6)') maxval(v,dim=2)
if (any (r1 /= r2)) call abort
r1 = 'z'
write (unit=r1,fmt='(I6.6)') maxval(v,dim=2)
if (any (r1 /= r2)) call abort
allocate (a_alloc(0,1), v_alloc(0,1))
ret = 'what'
ret = maxval(a_alloc,dim=1)
if (ret(1) /= zero) call abort
r1 = 'qq'
r1 = maxval(a, dim=1, mask=a>"000200");
if (any(r1 /= zero .neqv. maxval(v,dim=1, mask=v>200) > 0)) call abort
if (any(maxval(a, dim=1, mask=a>"000200") /= zero .neqv. maxval(v,dim=1, mask=v>200) > 0)) call abort
r1 = 'rr'
r1 = maxval(a, dim=2, mask=a>"000200");
if (any(r1 /= zero .neqv. maxval(v,dim=2, mask=v>200) > 0)) call abort
if (any(maxval(a, dim=2, mask=a>"000200") /= zero .neqv. maxval(v,dim=2, mask=v>200) > 0)) call abort
mask = .true.
forall (i=1:n)
mask(i,i) = .false.
end forall
r1 = 'aa'
r1 = maxval(a, dim=1, mask=mask)
write(unit=r2,fmt='(I6.6)') maxval(v,dim=1, mask=mask)
if (any(r1 /= r2)) call abort
r1 = 'xyz'
smask = .true.
r1 = maxval(a, dim=1, mask=smask)
write (unit=r2,fmt='(I6.6)') maxval(v,dim=1)
if (any (r1 /= r2)) call abort
smask = .false.
r1 = 'foobar'
r1 = maxval(a, dim=1, mask=smask)
if (any(r1 /= zero)) call abort
end program main

69
gcc/testsuite/gfortran.dg/maxval_char_4.f90 Normal file
View file

@ -0,0 +1,69 @@
! { dg-do run }
program main
implicit none
integer, parameter :: n=5
character(kind=4,len=6), dimension(n,n) :: a
integer, dimension(n,n) :: v
character(kind=4,len=6), dimension(n) :: r1, r2
character(kind=4,len=6), dimension(:,:), allocatable :: a_alloc
integer, dimension(:,:), allocatable :: v_alloc
character(kind=4,len=6), parameter :: zero = achar(0,4) // achar(0,4) // achar(0,4) // achar(0,4) // achar(0,4) // achar(0,4)
integer :: i
character(kind=4,len=6),dimension(1) :: ret
logical, dimension(n,n) :: mask
logical :: smask
v = reshape([(i*i+200-17*i,i=1,n*n)],shape(v))
write (unit=a,fmt='(I6.6)') (i*i+200-17*i,i=1,n*n)
r1 = maxval(a,dim=1)
write (unit=r2,fmt='(I6.6)') maxval(v,dim=1)
if (any (r1 /= r2)) call abort
r1 = 4_'x'
write (unit=r1,fmt='(I6.6)') maxval(v,dim=1)
if (any (r1 /= r2)) call abort
r1 = 4_'y'
r1 = maxval(a,dim=2)
write (unit=r2,fmt='(I6.6)') maxval(v,dim=2)
if (any (r1 /= r2)) call abort
r1 = 4_'z'
write (unit=r1,fmt='(I6.6)') maxval(v,dim=2)
if (any (r1 /= r2)) call abort
allocate (a_alloc(0,1), v_alloc(0,1))
ret = 4_'what'
ret = maxval(a_alloc,dim=1)
if (ret(1) /= zero) call abort
r1 = 4_'qq'
r1 = maxval(a, dim=1, mask=a>4_"000200");
if (any(r1 /= zero .neqv. maxval(v,dim=1, mask=v>200) > 0)) call abort
if (any(maxval(a, dim=1, mask=a>4_"000200") /= zero .neqv. maxval(v,dim=1, mask=v>200) > 0)) call abort
r1 = 4_'rr'
r1 = maxval(a, dim=2, mask=a>4_"000200");
if (any(r1 /= zero .neqv. maxval(v,dim=2, mask=v>200) > 0)) call abort
if (any(maxval(a, dim=2, mask=a>4_"000200") /= zero .neqv. maxval(v,dim=2, mask=v>200) > 0)) call abort
mask = .true.
forall (i=1:n)
mask(i,i) = .false.
end forall
r1 = 4_'aa'
r1 = maxval(a, dim=1, mask=mask)
write(unit=r2,fmt='(I6.6)') maxval(v,dim=1, mask=mask)
if (any(r1 /= r2)) call abort
r1 = 4_'xyz'
smask = .true.
r1 = maxval(a, dim=1, mask=smask)
write (unit=r2,fmt='(I6.6)') maxval(v,dim=1)
if (any (r1 /= r2)) call abort
smask = .false.
r1 = 4_'foobar'
r1 = maxval(a, dim=1, mask=smask)
if (any(r1 /= zero)) call abort
end program main

40
gcc/testsuite/gfortran.dg/minval_char_1.f90 Normal file
View file

@ -0,0 +1,40 @@
! { dg-do run }
program main
implicit none
integer, parameter :: n=5, m=3
character(len=5), dimension(n) :: a
character(len=5), dimension(n,m) :: b
character(len=5) :: res
integer, dimension(n,m) :: v
real, dimension(n,m) :: r
integer :: i,j
logical, dimension(n,m) :: mask
character(len=5), dimension(:,:), allocatable :: empty
character(len=5) , parameter :: all_full = achar(255) // achar(255) // achar(255) // achar(255) // achar(255)
logical :: smask
write (unit=a,fmt='(I5.5)') (21-i*i+6*i,i=1,n)
res = minval(a)
if (res /= '00026') call abort
do
call random_number(r)
if (count(r<0.2) > 1) exit
end do
v = int(r * 100)
write (unit=b,fmt='(I5.5)') v
write (unit=res,fmt='(I5.5)') minval(v)
if (res /= minval(b)) call abort
smask = .true.
if (res /= minval(b, smask)) call abort
smask = .false.
if (all_full /= minval(b, smask)) call abort
mask = v < 30
write (unit=res,fmt='(I5.5)') minval(v,mask)
if (res /= minval(b, mask)) call abort
mask = .false.
if (minval(b, mask) /= all_full) call abort
allocate (empty(0:3,0))
res = minval(empty)
if (res /= all_full) call abort
end program main

42
gcc/testsuite/gfortran.dg/minval_char_2.f90 Normal file
View file

@ -0,0 +1,42 @@
! { dg-do run }
program main
implicit none
integer, parameter :: n=5, m=3
character(kind=4,len=5), dimension(n) :: a
character(kind=4,len=5), dimension(n,m) :: b
character(kind=4,len=5) :: res
integer, dimension(n,m) :: v
real, dimension(n,m) :: r
integer :: i,j
logical, dimension(n,m) :: mask
character(kind=4,len=5), dimension(:,:), allocatable :: empty
integer(kind=4), dimension(5) :: kmin = [-1, -1, -1, -1, -1]
character(kind=4,len=5) :: all_full
logical :: smask
all_full = transfer(kmin,all_full)
write (unit=a,fmt='(I5.5)') (21-i*i+6*i,i=1,n)
res = minval(a)
if (res /= 4_'00026') call abort
do
call random_number(r)
if (count(r>0.2) > 1) exit
end do
v = int(r * 100)
write (unit=b,fmt='(I5.5)') v
write (unit=res,fmt='(I5.5)') minval(v)
if (res /= minval(b)) call abort
smask = .true.
if (res /= minval(b, smask)) call abort
smask = .false.
if (all_full /= minval(b, smask)) call abort
mask = v < 30
write (unit=res,fmt='(I5.5)') minval(v,mask)
if (res /= minval(b, mask)) call abort
mask = .false.
if (minval(b, mask) /= all_full) call abort
allocate (empty(0:3,0))
res = minval(empty)
if (res /= all_full) call abort
end program main

69
gcc/testsuite/gfortran.dg/minval_char_3.f90 Normal file
View file

@ -0,0 +1,69 @@
! { dg-do run }
program main
implicit none
integer, parameter :: n=5
character(len=6), dimension(n,n) :: a
integer, dimension(n,n) :: v
character(len=6), dimension(n) :: r1, r2
character(len=6), dimension(:,:), allocatable :: a_alloc
integer, dimension(:,:), allocatable :: v_alloc
character(len=6), parameter :: all_full = achar(255) // achar(255) // achar(255) // achar(255) // achar(255) // achar(255)
integer :: i
character(len=6),dimension(1) :: ret
logical, dimension(n,n) :: mask
logical :: smask
v = reshape([(i*i+200-17*i,i=1,n*n)],shape(v))
write (unit=a,fmt='(I6.6)') (i*i+200-17*i,i=1,n*n)
r1 = minval(a,dim=1)
write (unit=r2,fmt='(I6.6)') minval(v,dim=1)
if (any (r1 /= r2)) call abort
r1 = 'x'
write (unit=r1,fmt='(I6.6)') minval(v,dim=1)
if (any (r1 /= r2)) call abort
r1 = 'y'
r1 = minval(a,dim=2)
write (unit=r2,fmt='(I6.6)') minval(v,dim=2)
if (any (r1 /= r2)) call abort
r1 = 'z'
write (unit=r1,fmt='(I6.6)') minval(v,dim=2)
if (any (r1 /= r2)) call abort
allocate (a_alloc(0,1), v_alloc(0,1))
ret = 'what'
ret = minval(a_alloc,dim=1)
if (ret(1) /= all_full) call abort
r1 = 'qq'
r1 = minval(a, dim=1, mask=a>"000200");
if (any(r1 /= all_full .neqv. minval(v,dim=1, mask=v>200) < 1000)) call abort
if (any(minval(a, dim=1, mask=a>"000200") /= all_full .neqv. minval(v,dim=1, mask=v>200) < 1000)) call abort
r1 = 'rr'
r1 = minval(a, dim=2, mask=a>"000200");
if (any(r1 /= all_full .neqv. minval(v,dim=2, mask=v>200) < 1000)) call abort
if (any(minval(a, dim=2, mask=a>"000200") /= all_full .neqv. minval(v,dim=2, mask=v>200) < 1000)) call abort
mask = .true.
forall (i=1:n)
mask(i,i) = .false.
end forall
r1 = 'aa'
r1 = minval(a, dim=1, mask=mask)
write(unit=r2,fmt='(I6.6)') minval(v,dim=1, mask=mask)
if (any(r1 /= r2)) call abort
r1 = 'xyz'
smask = .true.
r1 = minval(a, dim=1, mask=smask)
write (unit=r2,fmt='(I6.6)') minval(v,dim=1)
if (any (r1 /= r2)) call abort
smask = .false.
r1 = 'foobar'
r1 = minval(a, dim=1, mask=smask)
if (any(r1 /= all_full)) call abort
end program main

72
gcc/testsuite/gfortran.dg/minval_char_4.f90 Normal file
View file

@ -0,0 +1,72 @@
! { dg-do run }
program main
implicit none
integer, parameter :: n=5
character(len=6,kind=4), dimension(n,n) :: a
integer, dimension(n,n) :: v
character(len=6,kind=4), dimension(n) :: r1, r2
character(len=6,kind=4), dimension(:,:), allocatable :: a_alloc
integer, dimension(:,:), allocatable :: v_alloc
character(len=6,kind=4):: all_full
integer :: i
character(len=6,kind=4),dimension(1) :: ret
logical, dimension(n,n) :: mask
logical :: smask
integer(kind=4), dimension(6) :: kmin
kmin = -1
all_full = transfer(kmin,all_full)
v = reshape([(i*i+200-17*i,i=1,n*n)],shape(v))
write (unit=a,fmt='(I6.6)') (i*i+200-17*i,i=1,n*n)
r1 = minval(a,dim=1)
write (unit=r2,fmt='(I6.6)') minval(v,dim=1)
if (any (r1 /= r2)) call abort
r1 = 4_'x'
write (unit=r1,fmt='(I6.6)') minval(v,dim=1)
if (any (r1 /= r2)) call abort
r1 = 4_'y'
r1 = minval(a,dim=2)
write (unit=r2,fmt='(I6.6)') minval(v,dim=2)
if (any (r1 /= r2)) call abort
r1 = 4_'z'
write (unit=r1,fmt='(I6.6)') minval(v,dim=2)
if (any (r1 /= r2)) call abort
allocate (a_alloc(0,1), v_alloc(0,1))
ret = 4_'what'
ret = minval(a_alloc,dim=1)
if (ret(1) /= all_full) call abort
r1 = 4_'qq'
r1 = minval(a, dim=1, mask=a>4_"000200");
if (any(r1 /= all_full .neqv. minval(v,dim=1, mask=v>200) < 1000)) call abort
if (any(minval(a, dim=1, mask=a>4_"000200") /= all_full .neqv. minval(v,dim=1, mask=v>200) < 1000)) call abort
r1 = 4_'rr'
r1 = minval(a, dim=2, mask=a>4_"000200");
if (any(r1 /= all_full .neqv. minval(v,dim=2, mask=v>200) < 1000)) call abort
if (any(minval(a, dim=2, mask=a>4_"000200") /= all_full .neqv. minval(v,dim=2, mask=v>200) < 1000)) call abort
mask = .true.
forall (i=1:n)
mask(i,i) = .false.
end forall
r1 = 4_'aa'
r1 = minval(a, dim=1, mask=mask)
write(unit=r2,fmt='(I6.6)') minval(v,dim=1, mask=mask)
if (any(r1 /= r2)) call abort
r1 = 4_'xyz'
smask = .true.
r1 = minval(a, dim=1, mask=smask)
write (unit=r2,fmt='(I6.6)') minval(v,dim=1)
if (any (r1 /= r2)) call abort
smask = .false.
r1 = 4_'foobar'
r1 = minval(a, dim=1, mask=smask)
if (any(r1 /= all_full)) call abort
end program main

23
libgfortran/ChangeLog
View file

@ -1,3 +1,26 @@
2017-12-03 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/36313
* Makefile.am: Add new files for character-valued
maxval and minval.
* Makefile.in: Regenerated.
* gfortran.map: Add new functions.
* m4/iforeach-s2.m4: New file.
* m4/ifunction-s2.m4: New file.
* m4/iparm.m4: Add intitval for minval and maxval.
* m4/maxval0s.m4: New file.
* m4/maxval1s.m4: New file.
* m4/minval0s.m4: New file.
* m4/minval1s.m4: New file.
* generated/maxval0_s1.c: New file.
* generated/maxval0_s4.c: New file.
* generated/maxval1_s1.c: New file.
* generated/maxval1_s4.c: New file.
* generated/minval0_s1.c: New file.
* generated/minval0_s4.c: New file.
* generated/minval1_s1.c: New file.
* generated/minval1_s4.c: New file.
2017-12-03 Jerry DeLisle <jvdelisle@gcc.gnu.org>
Dominique d'Humieres <dominiq@lps.ens.fr>

33
libgfortran/Makefile.am
View file

@ -357,6 +357,14 @@ $(srcdir)/generated/maxval_r8.c \
$(srcdir)/generated/maxval_r10.c \
$(srcdir)/generated/maxval_r16.c
i_maxval0s_c=\
$(srcdir)/generated/maxval0_s1.c \
$(srcdir)/generated/maxval0_s4.c
i_maxval1s_c=\
$(srcdir)/generated/maxval1_s1.c \
$(srcdir)/generated/maxval1_s4.c
i_minloc0_c= \
$(srcdir)/generated/minloc0_4_i1.c \
$(srcdir)/generated/minloc0_8_i1.c \
@ -450,6 +458,14 @@ $(srcdir)/generated/minval_r8.c \
$(srcdir)/generated/minval_r10.c \
$(srcdir)/generated/minval_r16.c
i_minval0s_c=\
$(srcdir)/generated/minval0_s1.c \
$(srcdir)/generated/minval0_s4.c
i_minval1s_c=\
$(srcdir)/generated/minval1_s1.c \
$(srcdir)/generated/minval1_s4.c
i_norm2_c= \
$(srcdir)/generated/norm2_r4.c \
$(srcdir)/generated/norm2_r8.c \
@ -748,7 +764,8 @@ gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \
$(i_spread_c) selected_int_kind.inc selected_real_kind.inc kinds.h \
$(i_cshift0_c) kinds.inc c99_protos.inc fpu-target.h fpu-target.inc \
$(i_cshift1a_c) $(i_maxloc0s_c) $(i_minloc0s_c) $(i_maxloc1s_c) \
$(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c)
$(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) $(i_maxvals_c) \
$(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c)
# Machine generated specifics
gfor_built_specific_src= \
@ -973,6 +990,8 @@ I_M4_DEPS1=$(I_M4_DEPS) m4/ifunction.m4
I_M4_DEPS2=$(I_M4_DEPS) m4/ifunction_logical.m4
I_M4_DEPS3=$(I_M4_DEPS) m4/iforeach-s.m4
I_M4_DEPS4=$(I_M4_DEPS) m4/ifunction-s.m4
I_M4_DEPS5=$(I_M4_DEPS) m4/iforeach-s2.m4
I_M4_DEPS6=$(I_M4_DEPS) m4/ifunction-s2.m4
kinds.h: $(srcdir)/mk-kinds-h.sh
$(SHELL) $(srcdir)/mk-kinds-h.sh '$(FCCOMPILE)' > $@ || rm $@
@ -1039,6 +1058,12 @@ $(i_maxloc2s_c): m4/maxloc2s.m4 $(I_M4_DEPS)
$(i_maxval_c): m4/maxval.m4 $(I_M4_DEPS1)
$(M4) -Dfile=$@ -I$(srcdir)/m4 maxval.m4 > $@
$(i_maxval0s_c): m4/maxval0s.m4 $(I_M4_DEPS5)
$(M4) -Dfile=$@ -I$(srcdir)/m4 maxval0s.m4 > $@
$(i_maxval1s_c): m4/maxval1s.m4 $(I_M4_DEPS6)
$(M4) -Dfile=$@ -I$(srcdir)/m4 maxval1s.m4 > $@
$(i_minloc0_c): m4/minloc0.m4 $(I_M4_DEPS0)
$(M4) -Dfile=$@ -I$(srcdir)/m4 minloc0.m4 > $@
@ -1057,6 +1082,12 @@ $(i_minloc2s_c): m4/minloc2s.m4 $(I_M4_DEPS)
$(i_minval_c): m4/minval.m4 $(I_M4_DEPS1)
$(M4) -Dfile=$@ -I$(srcdir)/m4 minval.m4 > $@
$(i_minval0s_c): m4/minval0s.m4 $(I_M4_DEPS5)
$(M4) -Dfile=$@ -I$(srcdir)/m4 minval0s.m4 > $@
$(i_minval1s_c): m4/minval1s.m4 $(I_M4_DEPS6)
$(M4) -Dfile=$@ -I$(srcdir)/m4 minval1s.m4 > $@
$(i_product_c): m4/product.m4 $(I_M4_DEPS1)
$(M4) -Dfile=$@ -I$(srcdir)/m4 product.m4 > $@

139
libgfortran/Makefile.in
View file

@ -329,7 +329,11 @@ am__objects_41 = maxloc2_4_s1.lo maxloc2_4_s4.lo maxloc2_8_s1.lo \
maxloc2_8_s4.lo maxloc2_16_s1.lo maxloc2_16_s4.lo
am__objects_42 = minloc2_4_s1.lo minloc2_4_s4.lo minloc2_8_s1.lo \
minloc2_8_s4.lo minloc2_16_s1.lo minloc2_16_s4.lo
am__objects_43 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \
am__objects_43 = maxval0_s1.lo maxval0_s4.lo
am__objects_44 = minval0_s1.lo minval0_s4.lo
am__objects_45 = maxval1_s1.lo maxval1_s4.lo
am__objects_46 = minval1_s1.lo minval1_s4.lo
am__objects_47 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \
$(am__objects_7) $(am__objects_8) $(am__objects_9) \
$(am__objects_10) $(am__objects_11) $(am__objects_12) \
$(am__objects_13) $(am__objects_14) $(am__objects_15) \
@ -341,14 +345,16 @@ am__objects_43 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \
$(am__objects_31) $(am__objects_32) $(am__objects_33) \
$(am__objects_34) $(am__objects_35) $(am__objects_36) \
$(am__objects_37) $(am__objects_38) $(am__objects_39) \
$(am__objects_40) $(am__objects_41) $(am__objects_42)
@LIBGFOR_MINIMAL_FALSE@am__objects_44 = close.lo file_pos.lo format.lo \
$(am__objects_40) $(am__objects_41) $(am__objects_42) \
$(am__objects_43) $(am__objects_44) $(am__objects_45) \
$(am__objects_46)
@LIBGFOR_MINIMAL_FALSE@am__objects_48 = close.lo file_pos.lo format.lo \
@LIBGFOR_MINIMAL_FALSE@ inquire.lo intrinsics.lo list_read.lo \
@LIBGFOR_MINIMAL_FALSE@ lock.lo open.lo read.lo transfer.lo \
@LIBGFOR_MINIMAL_FALSE@ transfer128.lo unit.lo unix.lo write.lo \
@LIBGFOR_MINIMAL_FALSE@ fbuf.lo
am__objects_45 = size_from_kind.lo $(am__objects_44)
@LIBGFOR_MINIMAL_FALSE@am__objects_46 = access.lo c99_functions.lo \
am__objects_49 = size_from_kind.lo $(am__objects_48)
@LIBGFOR_MINIMAL_FALSE@am__objects_50 = access.lo c99_functions.lo \
@LIBGFOR_MINIMAL_FALSE@ chdir.lo chmod.lo clock.lo cpu_time.lo \
@LIBGFOR_MINIMAL_FALSE@ ctime.lo date_and_time.lo dtime.lo \
@LIBGFOR_MINIMAL_FALSE@ env.lo etime.lo execute_command_line.lo \
@ -358,19 +364,19 @@ am__objects_45 = size_from_kind.lo $(am__objects_44)
@LIBGFOR_MINIMAL_FALSE@ rename.lo stat.lo symlnk.lo \
@LIBGFOR_MINIMAL_FALSE@ system_clock.lo time.lo umask.lo \
@LIBGFOR_MINIMAL_FALSE@ unlink.lo
@IEEE_SUPPORT_TRUE@am__objects_47 = ieee_helper.lo
am__objects_48 = associated.lo abort.lo args.lo cshift0.lo eoshift0.lo \
@IEEE_SUPPORT_TRUE@am__objects_51 = ieee_helper.lo
am__objects_52 = associated.lo abort.lo args.lo cshift0.lo eoshift0.lo \
eoshift2.lo erfc_scaled.lo extends_type_of.lo fnum.lo \
ierrno.lo ishftc.lo mvbits.lo move_alloc.lo pack_generic.lo \
selected_char_kind.lo size.lo spread_generic.lo \
string_intrinsics.lo rand.lo random.lo reshape_generic.lo \
reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo \
$(am__objects_46) $(am__objects_47)
@IEEE_SUPPORT_TRUE@am__objects_49 = ieee_arithmetic.lo \
$(am__objects_50) $(am__objects_51)
@IEEE_SUPPORT_TRUE@am__objects_53 = ieee_arithmetic.lo \
@IEEE_SUPPORT_TRUE@ ieee_exceptions.lo ieee_features.lo
am__objects_50 =
am__objects_51 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
am__objects_54 =
am__objects_55 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
_abs_i4.lo _abs_i8.lo _abs_i16.lo _abs_r4.lo _abs_r8.lo \
_abs_r10.lo _abs_r16.lo _aimag_c4.lo _aimag_c8.lo \
_aimag_c10.lo _aimag_c16.lo _exp_r4.lo _exp_r8.lo _exp_r10.lo \
@ -394,19 +400,19 @@ am__objects_51 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
_conjg_c4.lo _conjg_c8.lo _conjg_c10.lo _conjg_c16.lo \
_aint_r4.lo _aint_r8.lo _aint_r10.lo _aint_r16.lo _anint_r4.lo \
_anint_r8.lo _anint_r10.lo _anint_r16.lo
am__objects_52 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \
am__objects_56 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \
_sign_r8.lo _sign_r10.lo _sign_r16.lo _dim_i4.lo _dim_i8.lo \
_dim_i16.lo _dim_r4.lo _dim_r8.lo _dim_r10.lo _dim_r16.lo \
_atan2_r4.lo _atan2_r8.lo _atan2_r10.lo _atan2_r16.lo \
_mod_i4.lo _mod_i8.lo _mod_i16.lo _mod_r4.lo _mod_r8.lo \
_mod_r10.lo _mod_r16.lo
am__objects_53 = misc_specifics.lo
am__objects_54 = $(am__objects_51) $(am__objects_52) $(am__objects_53) \
am__objects_57 = misc_specifics.lo
am__objects_58 = $(am__objects_55) $(am__objects_56) $(am__objects_57) \
dprod_r8.lo f2c_specifics.lo
am__objects_55 = $(am__objects_3) $(am__objects_43) $(am__objects_45) \
$(am__objects_48) $(am__objects_49) $(am__objects_50) \
$(am__objects_54)
@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_55)
am__objects_59 = $(am__objects_3) $(am__objects_47) $(am__objects_49) \
$(am__objects_52) $(am__objects_53) $(am__objects_54) \
$(am__objects_58)
@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_59)
@onestep_TRUE@am_libgfortran_la_OBJECTS = libgfortran_c.lo
libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS)
DEFAULT_INCLUDES = -I.@am__isrc@
@ -810,6 +816,14 @@ $(srcdir)/generated/maxval_r8.c \
$(srcdir)/generated/maxval_r10.c \
$(srcdir)/generated/maxval_r16.c
i_maxval0s_c = \
$(srcdir)/generated/maxval0_s1.c \
$(srcdir)/generated/maxval0_s4.c
i_maxval1s_c = \
$(srcdir)/generated/maxval1_s1.c \
$(srcdir)/generated/maxval1_s4.c
i_minloc0_c = \
$(srcdir)/generated/minloc0_4_i1.c \
$(srcdir)/generated/minloc0_8_i1.c \
@ -903,6 +917,14 @@ $(srcdir)/generated/minval_r8.c \
$(srcdir)/generated/minval_r10.c \
$(srcdir)/generated/minval_r16.c
i_minval0s_c = \
$(srcdir)/generated/minval0_s1.c \
$(srcdir)/generated/minval0_s4.c
i_minval1s_c = \
$(srcdir)/generated/minval1_s1.c \
$(srcdir)/generated/minval1_s4.c
i_norm2_c = \
$(srcdir)/generated/norm2_r4.c \
$(srcdir)/generated/norm2_r8.c \
@ -1201,7 +1223,8 @@ gfor_built_src = $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \
$(i_spread_c) selected_int_kind.inc selected_real_kind.inc kinds.h \
$(i_cshift0_c) kinds.inc c99_protos.inc fpu-target.h fpu-target.inc \
$(i_cshift1a_c) $(i_maxloc0s_c) $(i_minloc0s_c) $(i_maxloc1s_c) \
$(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c)
$(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) $(i_maxvals_c) \
$(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c)
# Machine generated specifics
@ -1379,6 +1402,8 @@ I_M4_DEPS1 = $(I_M4_DEPS) m4/ifunction.m4
I_M4_DEPS2 = $(I_M4_DEPS) m4/ifunction_logical.m4
I_M4_DEPS3 = $(I_M4_DEPS) m4/iforeach-s.m4
I_M4_DEPS4 = $(I_M4_DEPS) m4/ifunction-s.m4
I_M4_DEPS5 = $(I_M4_DEPS) m4/iforeach-s2.m4
I_M4_DEPS6 = $(I_M4_DEPS) m4/ifunction-s2.m4
EXTRA_DIST = $(m4_files)
all: $(BUILT_SOURCES) config.h
$(MAKE) $(AM_MAKEFLAGS) all-am
@ -1784,6 +1809,10 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxloc2_4_s4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxloc2_8_s1.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxloc2_8_s4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval0_s1.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval0_s4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval1_s1.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval1_s4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval_i1.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval_i16.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval_i2.Plo@am__quote@
@ -1867,6 +1896,10 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minloc2_4_s4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minloc2_8_s1.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minloc2_8_s4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval0_s1.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval0_s4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval1_s1.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval1_s4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval_i1.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval_i16.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minval_i2.Plo@am__quote@
@ -5612,6 +5645,62 @@ minloc2_16_s4.lo: $(srcdir)/generated/minloc2_16_s4.c
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minloc2_16_s4.lo `test -f '$(srcdir)/generated/minloc2_16_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minloc2_16_s4.c
maxval0_s1.lo: $(srcdir)/generated/maxval0_s1.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT maxval0_s1.lo -MD -MP -MF $(DEPDIR)/maxval0_s1.Tpo -c -o maxval0_s1.lo `test -f '$(srcdir)/generated/maxval0_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval0_s1.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/maxval0_s1.Tpo $(DEPDIR)/maxval0_s1.Plo
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/maxval0_s1.c' object='maxval0_s1.lo' libtool=yes @AMDEPBACKSLASH@
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o maxval0_s1.lo `test -f '$(srcdir)/generated/maxval0_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval0_s1.c
maxval0_s4.lo: $(srcdir)/generated/maxval0_s4.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT maxval0_s4.lo -MD -MP -MF $(DEPDIR)/maxval0_s4.Tpo -c -o maxval0_s4.lo `test -f '$(srcdir)/generated/maxval0_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval0_s4.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/maxval0_s4.Tpo $(DEPDIR)/maxval0_s4.Plo
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/maxval0_s4.c' object='maxval0_s4.lo' libtool=yes @AMDEPBACKSLASH@
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o maxval0_s4.lo `test -f '$(srcdir)/generated/maxval0_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval0_s4.c
minval0_s1.lo: $(srcdir)/generated/minval0_s1.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT minval0_s1.lo -MD -MP -MF $(DEPDIR)/minval0_s1.Tpo -c -o minval0_s1.lo `test -f '$(srcdir)/generated/minval0_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval0_s1.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/minval0_s1.Tpo $(DEPDIR)/minval0_s1.Plo
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/minval0_s1.c' object='minval0_s1.lo' libtool=yes @AMDEPBACKSLASH@
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minval0_s1.lo `test -f '$(srcdir)/generated/minval0_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval0_s1.c
minval0_s4.lo: $(srcdir)/generated/minval0_s4.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT minval0_s4.lo -MD -MP -MF $(DEPDIR)/minval0_s4.Tpo -c -o minval0_s4.lo `test -f '$(srcdir)/generated/minval0_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval0_s4.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/minval0_s4.Tpo $(DEPDIR)/minval0_s4.Plo
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/minval0_s4.c' object='minval0_s4.lo' libtool=yes @AMDEPBACKSLASH@
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minval0_s4.lo `test -f '$(srcdir)/generated/minval0_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval0_s4.c
maxval1_s1.lo: $(srcdir)/generated/maxval1_s1.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT maxval1_s1.lo -MD -MP -MF $(DEPDIR)/maxval1_s1.Tpo -c -o maxval1_s1.lo `test -f '$(srcdir)/generated/maxval1_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval1_s1.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/maxval1_s1.Tpo $(DEPDIR)/maxval1_s1.Plo
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/maxval1_s1.c' object='maxval1_s1.lo' libtool=yes @AMDEPBACKSLASH@
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o maxval1_s1.lo `test -f '$(srcdir)/generated/maxval1_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval1_s1.c
maxval1_s4.lo: $(srcdir)/generated/maxval1_s4.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT maxval1_s4.lo -MD -MP -MF $(DEPDIR)/maxval1_s4.Tpo -c -o maxval1_s4.lo `test -f '$(srcdir)/generated/maxval1_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval1_s4.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/maxval1_s4.Tpo $(DEPDIR)/maxval1_s4.Plo
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/maxval1_s4.c' object='maxval1_s4.lo' libtool=yes @AMDEPBACKSLASH@
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o maxval1_s4.lo `test -f '$(srcdir)/generated/maxval1_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxval1_s4.c
minval1_s1.lo: $(srcdir)/generated/minval1_s1.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT minval1_s1.lo -MD -MP -MF $(DEPDIR)/minval1_s1.Tpo -c -o minval1_s1.lo `test -f '$(srcdir)/generated/minval1_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval1_s1.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/minval1_s1.Tpo $(DEPDIR)/minval1_s1.Plo
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/minval1_s1.c' object='minval1_s1.lo' libtool=yes @AMDEPBACKSLASH@
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minval1_s1.lo `test -f '$(srcdir)/generated/minval1_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval1_s1.c
minval1_s4.lo: $(srcdir)/generated/minval1_s4.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT minval1_s4.lo -MD -MP -MF $(DEPDIR)/minval1_s4.Tpo -c -o minval1_s4.lo `test -f '$(srcdir)/generated/minval1_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval1_s4.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/minval1_s4.Tpo $(DEPDIR)/minval1_s4.Plo
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/minval1_s4.c' object='minval1_s4.lo' libtool=yes @AMDEPBACKSLASH@
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minval1_s4.lo `test -f '$(srcdir)/generated/minval1_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval1_s4.c
size_from_kind.lo: io/size_from_kind.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT size_from_kind.lo -MD -MP -MF $(DEPDIR)/size_from_kind.Tpo -c -o size_from_kind.lo `test -f 'io/size_from_kind.c' || echo '$(srcdir)/'`io/size_from_kind.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/size_from_kind.Tpo $(DEPDIR)/size_from_kind.Plo
@ -6507,6 +6596,12 @@ fpu-target.inc: fpu-target.h $(srcdir)/libgfortran.h
@MAINTAINER_MODE_TRUE@$(i_maxval_c): m4/maxval.m4 $(I_M4_DEPS1)
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 maxval.m4 > $@
@MAINTAINER_MODE_TRUE@$(i_maxval0s_c): m4/maxval0s.m4 $(I_M4_DEPS5)
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 maxval0s.m4 > $@
@MAINTAINER_MODE_TRUE@$(i_maxval1s_c): m4/maxval1s.m4 $(I_M4_DEPS6)
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 maxval1s.m4 > $@
@MAINTAINER_MODE_TRUE@$(i_minloc0_c): m4/minloc0.m4 $(I_M4_DEPS0)
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 minloc0.m4 > $@
@ -6525,6 +6620,12 @@ fpu-target.inc: fpu-target.h $(srcdir)/libgfortran.h
@MAINTAINER_MODE_TRUE@$(i_minval_c): m4/minval.m4 $(I_M4_DEPS1)
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 minval.m4 > $@
@MAINTAINER_MODE_TRUE@$(i_minval0s_c): m4/minval0s.m4 $(I_M4_DEPS5)
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 minval0s.m4 > $@
@MAINTAINER_MODE_TRUE@$(i_minval1s_c): m4/minval1s.m4 $(I_M4_DEPS6)
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 minval1s.m4 > $@
@MAINTAINER_MODE_TRUE@$(i_product_c): m4/product.m4 $(I_M4_DEPS1)
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 product.m4 > $@

258
libgfortran/generated/maxval0_s1.c Normal file
View file

@ -0,0 +1,258 @@
/* Implementation of the MAXLOC intrinsic
Copyright 2017 Free Software Foundation, Inc.
Contributed by Thomas Koenig
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <stdlib.h>
#include <string.h>
#include <assert.h>
#include <limits.h>
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)
static inline int
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
{
if (sizeof (GFC_INTEGER_1) == 1)
return memcmp (a, b, n);
else
return memcmp_char4 (a, b, n);
}
#define INITVAL 0
extern void maxval0_s1 (GFC_INTEGER_1 * restrict,
gfc_charlen_type,
gfc_array_s1 * const restrict array, gfc_charlen_type);
export_proto(maxval0_s1);
void
maxval0_s1 (GFC_INTEGER_1 * restrict ret,
gfc_charlen_type xlen,
gfc_array_s1 * const restrict array, gfc_charlen_type len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
const GFC_INTEGER_1 *base;
index_type rank;
index_type n;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
assert (xlen == len);
/* Initialize return value. */
memset (ret, INITVAL, sizeof(*ret) * len);
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
count[n] = 0;
if (extent[n] <= 0)
return;
}
base = array->base_addr;
{
const GFC_INTEGER_1 *retval;
retval = ret;
while (base)
{
do
{
/* Implementation start. */
if (compare_fcn (base, retval, len) > 0)
{
retval = base;
}
/* Implementation end. */
/* Advance to the next element. */
base += sstride[0];
}
while (++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
}
}
while (count[n] == extent[n]);
}
memcpy (ret, retval, len * sizeof (*ret));
}
}
extern void mmaxval0_s1 (GFC_INTEGER_1 * restrict,
gfc_charlen_type, gfc_array_s1 * const restrict array,
gfc_array_l1 * const restrict mask, gfc_charlen_type len);
export_proto(mmaxval0_s1);
void
mmaxval0_s1 (GFC_INTEGER_1 * const restrict ret,
gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
gfc_array_l1 * const restrict mask, gfc_charlen_type len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
const GFC_INTEGER_1 *base;
GFC_LOGICAL_1 *mbase;
int rank;
index_type n;
int mask_kind;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
assert (xlen == len);
/* Initialize return value. */
memset (ret, INITVAL, sizeof(*ret) * len);
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
mbase = mask->base_addr;
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
runtime_error ("Funny sized logical array");
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
count[n] = 0;
if (extent[n] <= 0)
return;
}
base = array->base_addr;
{
const GFC_INTEGER_1 *retval;
retval = ret;
while (base)
{
do
{
/* Implementation start. */
if (*mbase && compare_fcn (base, retval, len) > 0)
{
retval = base;
}
/* Implementation end. */
/* Advance to the next element. */
base += sstride[0];
mbase += mstride[0];
}
while (++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
mbase += mstride[n];
}
}
while (count[n] == extent[n]);
}
memcpy (ret, retval, len * sizeof (*ret));
}
}
extern void smaxval0_s1 (GFC_INTEGER_1 * restrict,
gfc_charlen_type,
gfc_array_s1 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
export_proto(smaxval0_s1);
void
smaxval0_s1 (GFC_INTEGER_1 * restrict ret,
gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
GFC_LOGICAL_4 *mask, gfc_charlen_type len)
{
if (*mask)
{
maxval0_s1 (ret, xlen, array, len);
return;
}
memset (ret, INITVAL, sizeof (*ret) * len);
}
#endif

258
libgfortran/generated/maxval0_s4.c Normal file
View file

@ -0,0 +1,258 @@
/* Implementation of the MAXLOC intrinsic
Copyright 2017 Free Software Foundation, Inc.
Contributed by Thomas Koenig
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <stdlib.h>
#include <string.h>
#include <assert.h>
#include <limits.h>
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
static inline int
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
{
if (sizeof (GFC_INTEGER_4) == 1)
return memcmp (a, b, n);
else
return memcmp_char4 (a, b, n);
}
#define INITVAL 0
extern void maxval0_s4 (GFC_INTEGER_4 * restrict,
gfc_charlen_type,
gfc_array_s4 * const restrict array, gfc_charlen_type);
export_proto(maxval0_s4);
void
maxval0_s4 (GFC_INTEGER_4 * restrict ret,
gfc_charlen_type xlen,
gfc_array_s4 * const restrict array, gfc_charlen_type len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
const GFC_INTEGER_4 *base;
index_type rank;
index_type n;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
assert (xlen == len);
/* Initialize return value. */
memset (ret, INITVAL, sizeof(*ret) * len);
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
count[n] = 0;
if (extent[n] <= 0)
return;
}
base = array->base_addr;
{
const GFC_INTEGER_4 *retval;
retval = ret;
while (base)
{
do
{
/* Implementation start. */
if (compare_fcn (base, retval, len) > 0)
{
retval = base;
}
/* Implementation end. */
/* Advance to the next element. */
base += sstride[0];
}
while (++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
}
}
while (count[n] == extent[n]);
}
memcpy (ret, retval, len * sizeof (*ret));
}
}
extern void mmaxval0_s4 (GFC_INTEGER_4 * restrict,
gfc_charlen_type, gfc_array_s4 * const restrict array,
gfc_array_l1 * const restrict mask, gfc_charlen_type len);
export_proto(mmaxval0_s4);
void
mmaxval0_s4 (GFC_INTEGER_4 * const restrict ret,
gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
gfc_array_l1 * const restrict mask, gfc_charlen_type len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
const GFC_INTEGER_4 *base;
GFC_LOGICAL_1 *mbase;
int rank;
index_type n;
int mask_kind;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
assert (xlen == len);
/* Initialize return value. */
memset (ret, INITVAL, sizeof(*ret) * len);
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
mbase = mask->base_addr;
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
runtime_error ("Funny sized logical array");
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
count[n] = 0;
if (extent[n] <= 0)
return;
}
base = array->base_addr;
{
const GFC_INTEGER_4 *retval;
retval = ret;
while (base)
{
do
{
/* Implementation start. */
if (*mbase && compare_fcn (base, retval, len) > 0)
{
retval = base;
}
/* Implementation end. */
/* Advance to the next element. */
base += sstride[0];
mbase += mstride[0];
}
while (++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
mbase += mstride[n];
}
}
while (count[n] == extent[n]);
}
memcpy (ret, retval, len * sizeof (*ret));
}
}
extern void smaxval0_s4 (GFC_INTEGER_4 * restrict,
gfc_charlen_type,
gfc_array_s4 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
export_proto(smaxval0_s4);
void
smaxval0_s4 (GFC_INTEGER_4 * restrict ret,
gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
GFC_LOGICAL_4 *mask, gfc_charlen_type len)
{
if (*mask)
{
maxval0_s4 (ret, xlen, array, len);
return;
}
memset (ret, INITVAL, sizeof (*ret) * len);
}
#endif

560
libgfortran/generated/maxval1_s1.c Normal file
View file

@ -0,0 +1,560 @@
/* Implementation of the MAXVAL intrinsic
Copyright 2017 Free Software Foundation, Inc.
Contributed by Thomas Koenig
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)
#include <string.h>
#include <assert.h>
static inline int
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
{
if (sizeof (GFC_INTEGER_1) == 1)
return memcmp (a, b, n);
else
return memcmp_char4 (a, b, n);
}
extern void maxval1_s1 (gfc_array_s1 * const restrict,
gfc_charlen_type, gfc_array_s1 * const restrict,
const index_type * const restrict, gfc_charlen_type);
export_proto(maxval1_s1);
void
maxval1_s1 (gfc_array_s1 * const restrict retarray,
gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
const index_type * const restrict pdim, gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
const GFC_INTEGER_1 * restrict base;
GFC_INTEGER_1 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int continue_loop;
assert (xlen == string_len);
/* Make dim zero based to avoid confusion. */
rank = GFC_DESCRIPTOR_RANK (array) - 1;
dim = (*pdim) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
len = GFC_DESCRIPTOR_EXTENT(array,dim);
if (len < 0)
len = 0;
delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
for (n = 0; n < dim; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] < 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
if (extent[n] < 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
* string_len;
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
return;
}
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXVAL intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (unlikely (compile_options.bounds_check))
bounds_ifunction_return ((array_t *) retarray, extent,
"return value", "MAXVAL");
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
if (extent[n] <= 0)
return;
}
base = array->base_addr;
dest = retarray->base_addr;
continue_loop = 1;
while (continue_loop)
{
const GFC_INTEGER_1 * restrict src;
src = base;
{
const GFC_INTEGER_1 *retval;
retval = base;
if (len <= 0)
memset (dest, 0, sizeof (*dest) * string_len);
else
{
for (n = 0; n < len; n++, src += delta)
{
if (compare_fcn (src, retval, string_len) > 0)
{
retval = src;
}
}
memcpy (dest, retval, sizeof (*dest) * string_len);
}
}
/* Advance to the next element. */
count[0]++;
base += sstride[0];
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
continue_loop = 0;
break;
}
else
{
count[n]++;
base += sstride[n];
dest += dstride[n];
}
}
}
}
extern void mmaxval1_s1 (gfc_array_s1 * const restrict,
gfc_charlen_type, gfc_array_s1 * const restrict,
const index_type * const restrict,
gfc_array_l1 * const restrict, gfc_charlen_type);
export_proto(mmaxval1_s1);
void
mmaxval1_s1 (gfc_array_s1 * const restrict retarray,
gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
const index_type * const restrict pdim,
gfc_array_l1 * const restrict mask,
gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_1 * restrict dest;
const GFC_INTEGER_1 * restrict base;
const GFC_LOGICAL_1 * restrict mbase;
index_type rank;
index_type dim;
index_type n;
index_type len;
index_type delta;
index_type mdelta;
int mask_kind;
assert (xlen == string_len);
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
len = GFC_DESCRIPTOR_EXTENT(array,dim);
if (len <= 0)
return;
mbase = mask->base_addr;
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
runtime_error ("Funny sized logical array");
delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
for (n = 0; n < dim; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] < 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
if (extent[n] < 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
* string_len;
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
return;
}
else
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in MAXVAL intrinsic");
if (unlikely (compile_options.bounds_check))
{
bounds_ifunction_return ((array_t *) retarray, extent,
"return value", "MAXVAL");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "MAXVAL");
}
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
if (extent[n] <= 0)
return;
}
dest = retarray->base_addr;
base = array->base_addr;
while (base)
{
const GFC_INTEGER_1 * restrict src;
const GFC_LOGICAL_1 * restrict msrc;
src = base;
msrc = mbase;
{
const GFC_INTEGER_1 *retval;
memset (dest, 0, sizeof (*dest) * string_len);
retval = dest;
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
{
if (*msrc)
{
retval = src;
break;
}
}
for (; n < len; n++, src += delta, msrc += mdelta)
{
if (*msrc && compare_fcn (src, retval, string_len) > 0)
{
retval = src;
}
}
memcpy (dest, retval, sizeof (*dest) * string_len);
}
/* Advance to the next element. */
count[0]++;
base += sstride[0];
mbase += mstride[0];
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
mbase -= mstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
mbase += mstride[n];
dest += dstride[n];
}
}
}
}
void smaxval1_s1 (gfc_array_s1 * const restrict,
gfc_charlen_type, gfc_array_s1 * const restrict,
const index_type * const restrict,
GFC_LOGICAL_4 *, gfc_charlen_type);
export_proto(smaxval1_s1);
void
smaxval1_s1 (gfc_array_s1 * const restrict retarray,
gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
const index_type * const restrict pdim,
GFC_LOGICAL_4 *mask, gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_1 * restrict dest;
index_type rank;
index_type n;
index_type dim;
if (*mask)
{
maxval1_s1 (retarray, xlen, array, pdim, string_len);
return;
}
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
for (n = 0; n < dim; n++)
{
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] <= 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
extent[n] =
GFC_DESCRIPTOR_EXTENT(array,n + 1);
if (extent[n] <= 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
* string_len;
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
return;
}
else
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXVAL intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (unlikely (compile_options.bounds_check))
{
for (n=0; n < rank; n++)
{
index_type ret_extent;
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXVAL intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
}
dest = retarray->base_addr;
while(1)
{
memset (dest, 0, sizeof (*dest) * string_len);
count[0]++;
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
dest += dstride[n];
}
}
}
}
#endif

560
libgfortran/generated/maxval1_s4.c Normal file
View file

@ -0,0 +1,560 @@
/* Implementation of the MAXVAL intrinsic
Copyright 2017 Free Software Foundation, Inc.
Contributed by Thomas Koenig
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
#include <string.h>
#include <assert.h>
static inline int
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
{
if (sizeof (GFC_INTEGER_4) == 1)
return memcmp (a, b, n);
else
return memcmp_char4 (a, b, n);
}
extern void maxval1_s4 (gfc_array_s4 * const restrict,
gfc_charlen_type, gfc_array_s4 * const restrict,
const index_type * const restrict, gfc_charlen_type);
export_proto(maxval1_s4);
void
maxval1_s4 (gfc_array_s4 * const restrict retarray,
gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
const index_type * const restrict pdim, gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
const GFC_INTEGER_4 * restrict base;
GFC_INTEGER_4 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int continue_loop;
assert (xlen == string_len);
/* Make dim zero based to avoid confusion. */
rank = GFC_DESCRIPTOR_RANK (array) - 1;
dim = (*pdim) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
len = GFC_DESCRIPTOR_EXTENT(array,dim);
if (len < 0)
len = 0;
delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
for (n = 0; n < dim; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] < 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
if (extent[n] < 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
* string_len;
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
return;
}
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXVAL intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (unlikely (compile_options.bounds_check))
bounds_ifunction_return ((array_t *) retarray, extent,
"return value", "MAXVAL");
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
if (extent[n] <= 0)
return;
}
base = array->base_addr;
dest = retarray->base_addr;
continue_loop = 1;
while (continue_loop)
{
const GFC_INTEGER_4 * restrict src;
src = base;
{
const GFC_INTEGER_4 *retval;
retval = base;
if (len <= 0)
memset (dest, 0, sizeof (*dest) * string_len);
else
{
for (n = 0; n < len; n++, src += delta)
{
if (compare_fcn (src, retval, string_len) > 0)
{
retval = src;
}
}
memcpy (dest, retval, sizeof (*dest) * string_len);
}
}
/* Advance to the next element. */
count[0]++;
base += sstride[0];
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
continue_loop = 0;
break;
}
else
{
count[n]++;
base += sstride[n];
dest += dstride[n];
}
}
}
}
extern void mmaxval1_s4 (gfc_array_s4 * const restrict,
gfc_charlen_type, gfc_array_s4 * const restrict,
const index_type * const restrict,
gfc_array_l1 * const restrict, gfc_charlen_type);
export_proto(mmaxval1_s4);
void
mmaxval1_s4 (gfc_array_s4 * const restrict retarray,
gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
const index_type * const restrict pdim,
gfc_array_l1 * const restrict mask,
gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_4 * restrict dest;
const GFC_INTEGER_4 * restrict base;
const GFC_LOGICAL_1 * restrict mbase;
index_type rank;
index_type dim;
index_type n;
index_type len;
index_type delta;
index_type mdelta;
int mask_kind;
assert (xlen == string_len);
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
len = GFC_DESCRIPTOR_EXTENT(array,dim);
if (len <= 0)
return;
mbase = mask->base_addr;
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
runtime_error ("Funny sized logical array");
delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
for (n = 0; n < dim; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] < 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
if (extent[n] < 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
* string_len;
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
return;
}
else
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in MAXVAL intrinsic");
if (unlikely (compile_options.bounds_check))
{
bounds_ifunction_return ((array_t *) retarray, extent,
"return value", "MAXVAL");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "MAXVAL");
}
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
if (extent[n] <= 0)
return;
}
dest = retarray->base_addr;
base = array->base_addr;
while (base)
{
const GFC_INTEGER_4 * restrict src;
const GFC_LOGICAL_1 * restrict msrc;
src = base;
msrc = mbase;
{
const GFC_INTEGER_4 *retval;
memset (dest, 0, sizeof (*dest) * string_len);
retval = dest;
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
{
if (*msrc)
{
retval = src;
break;
}
}
for (; n < len; n++, src += delta, msrc += mdelta)
{
if (*msrc && compare_fcn (src, retval, string_len) > 0)
{
retval = src;
}
}
memcpy (dest, retval, sizeof (*dest) * string_len);
}
/* Advance to the next element. */
count[0]++;
base += sstride[0];
mbase += mstride[0];
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
mbase -= mstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
mbase += mstride[n];
dest += dstride[n];
}
}
}
}
void smaxval1_s4 (gfc_array_s4 * const restrict,
gfc_charlen_type, gfc_array_s4 * const restrict,
const index_type * const restrict,
GFC_LOGICAL_4 *, gfc_charlen_type);
export_proto(smaxval1_s4);
void
smaxval1_s4 (gfc_array_s4 * const restrict retarray,
gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
const index_type * const restrict pdim,
GFC_LOGICAL_4 *mask, gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_4 * restrict dest;
index_type rank;
index_type n;
index_type dim;
if (*mask)
{
maxval1_s4 (retarray, xlen, array, pdim, string_len);
return;
}
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
for (n = 0; n < dim; n++)
{
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] <= 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
extent[n] =
GFC_DESCRIPTOR_EXTENT(array,n + 1);
if (extent[n] <= 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
* string_len;
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
return;
}
else
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXVAL intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (unlikely (compile_options.bounds_check))
{
for (n=0; n < rank; n++)
{
index_type ret_extent;
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXVAL intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
}
dest = retarray->base_addr;
while(1)
{
memset (dest, 0, sizeof (*dest) * string_len);
count[0]++;
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
dest += dstride[n];
}
}
}
}
#endif

258
libgfortran/generated/minval0_s1.c Normal file
View file

@ -0,0 +1,258 @@
/* Implementation of the MAXLOC intrinsic
Copyright 2017 Free Software Foundation, Inc.
Contributed by Thomas Koenig
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <stdlib.h>
#include <string.h>
#include <assert.h>
#include <limits.h>
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)
static inline int
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
{
if (sizeof (GFC_INTEGER_1) == 1)
return memcmp (a, b, n);
else
return memcmp_char4 (a, b, n);
}
#define INITVAL 255
extern void minval0_s1 (GFC_INTEGER_1 * restrict,
gfc_charlen_type,
gfc_array_s1 * const restrict array, gfc_charlen_type);
export_proto(minval0_s1);
void
minval0_s1 (GFC_INTEGER_1 * restrict ret,
gfc_charlen_type xlen,
gfc_array_s1 * const restrict array, gfc_charlen_type len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
const GFC_INTEGER_1 *base;
index_type rank;
index_type n;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
assert (xlen == len);
/* Initialize return value. */
memset (ret, INITVAL, sizeof(*ret) * len);
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
count[n] = 0;
if (extent[n] <= 0)
return;
}
base = array->base_addr;
{
const GFC_INTEGER_1 *retval;
retval = ret;
while (base)
{
do
{
/* Implementation start. */
if (compare_fcn (base, retval, len) < 0)
{
retval = base;
}
/* Implementation end. */
/* Advance to the next element. */
base += sstride[0];
}
while (++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
}
}
while (count[n] == extent[n]);
}
memcpy (ret, retval, len * sizeof (*ret));
}
}
extern void mminval0_s1 (GFC_INTEGER_1 * restrict,
gfc_charlen_type, gfc_array_s1 * const restrict array,
gfc_array_l1 * const restrict mask, gfc_charlen_type len);
export_proto(mminval0_s1);
void
mminval0_s1 (GFC_INTEGER_1 * const restrict ret,
gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
gfc_array_l1 * const restrict mask, gfc_charlen_type len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
const GFC_INTEGER_1 *base;
GFC_LOGICAL_1 *mbase;
int rank;
index_type n;
int mask_kind;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
assert (xlen == len);
/* Initialize return value. */
memset (ret, INITVAL, sizeof(*ret) * len);
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
mbase = mask->base_addr;
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
runtime_error ("Funny sized logical array");
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
count[n] = 0;
if (extent[n] <= 0)
return;
}
base = array->base_addr;
{
const GFC_INTEGER_1 *retval;
retval = ret;
while (base)
{
do
{
/* Implementation start. */
if (*mbase && compare_fcn (base, retval, len) < 0)
{
retval = base;
}
/* Implementation end. */
/* Advance to the next element. */
base += sstride[0];
mbase += mstride[0];
}
while (++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
mbase += mstride[n];
}
}
while (count[n] == extent[n]);
}
memcpy (ret, retval, len * sizeof (*ret));
}
}
extern void sminval0_s1 (GFC_INTEGER_1 * restrict,
gfc_charlen_type,
gfc_array_s1 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
export_proto(sminval0_s1);
void
sminval0_s1 (GFC_INTEGER_1 * restrict ret,
gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
GFC_LOGICAL_4 *mask, gfc_charlen_type len)
{
if (*mask)
{
minval0_s1 (ret, xlen, array, len);
return;
}
memset (ret, INITVAL, sizeof (*ret) * len);
}
#endif

258
libgfortran/generated/minval0_s4.c Normal file
View file

@ -0,0 +1,258 @@
/* Implementation of the MAXLOC intrinsic
Copyright 2017 Free Software Foundation, Inc.
Contributed by Thomas Koenig
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <stdlib.h>
#include <string.h>
#include <assert.h>
#include <limits.h>
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
static inline int
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
{
if (sizeof (GFC_INTEGER_4) == 1)
return memcmp (a, b, n);
else
return memcmp_char4 (a, b, n);
}
#define INITVAL 255
extern void minval0_s4 (GFC_INTEGER_4 * restrict,
gfc_charlen_type,
gfc_array_s4 * const restrict array, gfc_charlen_type);
export_proto(minval0_s4);
void
minval0_s4 (GFC_INTEGER_4 * restrict ret,
gfc_charlen_type xlen,
gfc_array_s4 * const restrict array, gfc_charlen_type len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
const GFC_INTEGER_4 *base;
index_type rank;
index_type n;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
assert (xlen == len);
/* Initialize return value. */
memset (ret, INITVAL, sizeof(*ret) * len);
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
count[n] = 0;
if (extent[n] <= 0)
return;
}
base = array->base_addr;
{
const GFC_INTEGER_4 *retval;
retval = ret;
while (base)
{
do
{
/* Implementation start. */
if (compare_fcn (base, retval, len) < 0)
{
retval = base;
}
/* Implementation end. */
/* Advance to the next element. */
base += sstride[0];
}
while (++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
}
}
while (count[n] == extent[n]);
}
memcpy (ret, retval, len * sizeof (*ret));
}
}
extern void mminval0_s4 (GFC_INTEGER_4 * restrict,
gfc_charlen_type, gfc_array_s4 * const restrict array,
gfc_array_l1 * const restrict mask, gfc_charlen_type len);
export_proto(mminval0_s4);
void
mminval0_s4 (GFC_INTEGER_4 * const restrict ret,
gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
gfc_array_l1 * const restrict mask, gfc_charlen_type len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
const GFC_INTEGER_4 *base;
GFC_LOGICAL_1 *mbase;
int rank;
index_type n;
int mask_kind;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
assert (xlen == len);
/* Initialize return value. */
memset (ret, INITVAL, sizeof(*ret) * len);
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
mbase = mask->base_addr;
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
runtime_error ("Funny sized logical array");
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
count[n] = 0;
if (extent[n] <= 0)
return;
}
base = array->base_addr;
{
const GFC_INTEGER_4 *retval;
retval = ret;
while (base)
{
do
{
/* Implementation start. */
if (*mbase && compare_fcn (base, retval, len) < 0)
{
retval = base;
}
/* Implementation end. */
/* Advance to the next element. */
base += sstride[0];
mbase += mstride[0];
}
while (++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
mbase += mstride[n];
}
}
while (count[n] == extent[n]);
}
memcpy (ret, retval, len * sizeof (*ret));
}
}
extern void sminval0_s4 (GFC_INTEGER_4 * restrict,
gfc_charlen_type,
gfc_array_s4 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
export_proto(sminval0_s4);
void
sminval0_s4 (GFC_INTEGER_4 * restrict ret,
gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
GFC_LOGICAL_4 *mask, gfc_charlen_type len)
{
if (*mask)
{
minval0_s4 (ret, xlen, array, len);
return;
}
memset (ret, INITVAL, sizeof (*ret) * len);
}
#endif

560
libgfortran/generated/minval1_s1.c Normal file
View file

@ -0,0 +1,560 @@
/* Implementation of the MAXVAL intrinsic
Copyright 2017 Free Software Foundation, Inc.
Contributed by Thomas Koenig
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)
#include <string.h>
#include <assert.h>
static inline int
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
{
if (sizeof (GFC_INTEGER_1) == 1)
return memcmp (a, b, n);
else
return memcmp_char4 (a, b, n);
}
extern void minval1_s1 (gfc_array_s1 * const restrict,
gfc_charlen_type, gfc_array_s1 * const restrict,
const index_type * const restrict, gfc_charlen_type);
export_proto(minval1_s1);
void
minval1_s1 (gfc_array_s1 * const restrict retarray,
gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
const index_type * const restrict pdim, gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
const GFC_INTEGER_1 * restrict base;
GFC_INTEGER_1 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int continue_loop;
assert (xlen == string_len);
/* Make dim zero based to avoid confusion. */
rank = GFC_DESCRIPTOR_RANK (array) - 1;
dim = (*pdim) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
len = GFC_DESCRIPTOR_EXTENT(array,dim);
if (len < 0)
len = 0;
delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
for (n = 0; n < dim; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] < 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
if (extent[n] < 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
* string_len;
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
return;
}
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MINVAL intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (unlikely (compile_options.bounds_check))
bounds_ifunction_return ((array_t *) retarray, extent,
"return value", "MINVAL");
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
if (extent[n] <= 0)
return;
}
base = array->base_addr;
dest = retarray->base_addr;
continue_loop = 1;
while (continue_loop)
{
const GFC_INTEGER_1 * restrict src;
src = base;
{
const GFC_INTEGER_1 *retval;
retval = base;
if (len <= 0)
memset (dest, 255, sizeof (*dest) * string_len);
else
{
for (n = 0; n < len; n++, src += delta)
{
if (compare_fcn (src, retval, string_len) < 0)
{
retval = src;
}
}
memcpy (dest, retval, sizeof (*dest) * string_len);
}
}
/* Advance to the next element. */
count[0]++;
base += sstride[0];
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
continue_loop = 0;
break;
}
else
{
count[n]++;
base += sstride[n];
dest += dstride[n];
}
}
}
}
extern void mminval1_s1 (gfc_array_s1 * const restrict,
gfc_charlen_type, gfc_array_s1 * const restrict,
const index_type * const restrict,
gfc_array_l1 * const restrict, gfc_charlen_type);
export_proto(mminval1_s1);
void
mminval1_s1 (gfc_array_s1 * const restrict retarray,
gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
const index_type * const restrict pdim,
gfc_array_l1 * const restrict mask,
gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_1 * restrict dest;
const GFC_INTEGER_1 * restrict base;
const GFC_LOGICAL_1 * restrict mbase;
index_type rank;
index_type dim;
index_type n;
index_type len;
index_type delta;
index_type mdelta;
int mask_kind;
assert (xlen == string_len);
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
len = GFC_DESCRIPTOR_EXTENT(array,dim);
if (len <= 0)
return;
mbase = mask->base_addr;
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
runtime_error ("Funny sized logical array");
delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
for (n = 0; n < dim; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] < 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
if (extent[n] < 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
* string_len;
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
return;
}
else
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in MINVAL intrinsic");
if (unlikely (compile_options.bounds_check))
{
bounds_ifunction_return ((array_t *) retarray, extent,
"return value", "MINVAL");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "MINVAL");
}
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
if (extent[n] <= 0)
return;
}
dest = retarray->base_addr;
base = array->base_addr;
while (base)
{
const GFC_INTEGER_1 * restrict src;
const GFC_LOGICAL_1 * restrict msrc;
src = base;
msrc = mbase;
{
const GFC_INTEGER_1 *retval;
memset (dest, 255, sizeof (*dest) * string_len);
retval = dest;
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
{
if (*msrc)
{
retval = src;
break;
}
}
for (; n < len; n++, src += delta, msrc += mdelta)
{
if (*msrc && compare_fcn (src, retval, string_len) < 0)
{
retval = src;
}
}
memcpy (dest, retval, sizeof (*dest) * string_len);
}
/* Advance to the next element. */
count[0]++;
base += sstride[0];
mbase += mstride[0];
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
mbase -= mstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
mbase += mstride[n];
dest += dstride[n];
}
}
}
}
void sminval1_s1 (gfc_array_s1 * const restrict,
gfc_charlen_type, gfc_array_s1 * const restrict,
const index_type * const restrict,
GFC_LOGICAL_4 *, gfc_charlen_type);
export_proto(sminval1_s1);
void
sminval1_s1 (gfc_array_s1 * const restrict retarray,
gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
const index_type * const restrict pdim,
GFC_LOGICAL_4 *mask, gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_1 * restrict dest;
index_type rank;
index_type n;
index_type dim;
if (*mask)
{
minval1_s1 (retarray, xlen, array, pdim, string_len);
return;
}
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
for (n = 0; n < dim; n++)
{
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] <= 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
extent[n] =
GFC_DESCRIPTOR_EXTENT(array,n + 1);
if (extent[n] <= 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
* string_len;
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
return;
}
else
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MINVAL intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (unlikely (compile_options.bounds_check))
{
for (n=0; n < rank; n++)
{
index_type ret_extent;
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MINVAL intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
}
dest = retarray->base_addr;
while(1)
{
memset (dest, 255, sizeof (*dest) * string_len);
count[0]++;
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
dest += dstride[n];
}
}
}
}
#endif

560
libgfortran/generated/minval1_s4.c Normal file
View file

@ -0,0 +1,560 @@
/* Implementation of the MAXVAL intrinsic
Copyright 2017 Free Software Foundation, Inc.
Contributed by Thomas Koenig
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
#include <string.h>
#include <assert.h>
static inline int
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
{
if (sizeof (GFC_INTEGER_4) == 1)
return memcmp (a, b, n);
else
return memcmp_char4 (a, b, n);
}
extern void minval1_s4 (gfc_array_s4 * const restrict,
gfc_charlen_type, gfc_array_s4 * const restrict,
const index_type * const restrict, gfc_charlen_type);
export_proto(minval1_s4);
void
minval1_s4 (gfc_array_s4 * const restrict retarray,
gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
const index_type * const restrict pdim, gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
const GFC_INTEGER_4 * restrict base;
GFC_INTEGER_4 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int continue_loop;
assert (xlen == string_len);
/* Make dim zero based to avoid confusion. */
rank = GFC_DESCRIPTOR_RANK (array) - 1;
dim = (*pdim) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
len = GFC_DESCRIPTOR_EXTENT(array,dim);
if (len < 0)
len = 0;
delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
for (n = 0; n < dim; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] < 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
if (extent[n] < 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
* string_len;
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
return;
}
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MINVAL intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (unlikely (compile_options.bounds_check))
bounds_ifunction_return ((array_t *) retarray, extent,
"return value", "MINVAL");
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
if (extent[n] <= 0)
return;
}
base = array->base_addr;
dest = retarray->base_addr;
continue_loop = 1;
while (continue_loop)
{
const GFC_INTEGER_4 * restrict src;
src = base;
{
const GFC_INTEGER_4 *retval;
retval = base;
if (len <= 0)
memset (dest, 255, sizeof (*dest) * string_len);
else
{
for (n = 0; n < len; n++, src += delta)
{
if (compare_fcn (src, retval, string_len) < 0)
{
retval = src;
}
}
memcpy (dest, retval, sizeof (*dest) * string_len);
}
}
/* Advance to the next element. */
count[0]++;
base += sstride[0];
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
continue_loop = 0;
break;
}
else
{
count[n]++;
base += sstride[n];
dest += dstride[n];
}
}
}
}
extern void mminval1_s4 (gfc_array_s4 * const restrict,
gfc_charlen_type, gfc_array_s4 * const restrict,
const index_type * const restrict,
gfc_array_l1 * const restrict, gfc_charlen_type);
export_proto(mminval1_s4);
void
mminval1_s4 (gfc_array_s4 * const restrict retarray,
gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
const index_type * const restrict pdim,
gfc_array_l1 * const restrict mask,
gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_4 * restrict dest;
const GFC_INTEGER_4 * restrict base;
const GFC_LOGICAL_1 * restrict mbase;
index_type rank;
index_type dim;
index_type n;
index_type len;
index_type delta;
index_type mdelta;
int mask_kind;
assert (xlen == string_len);
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
len = GFC_DESCRIPTOR_EXTENT(array,dim);
if (len <= 0)
return;
mbase = mask->base_addr;
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
runtime_error ("Funny sized logical array");
delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
for (n = 0; n < dim; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] < 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
if (extent[n] < 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
* string_len;
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
return;
}
else
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in MINVAL intrinsic");
if (unlikely (compile_options.bounds_check))
{
bounds_ifunction_return ((array_t *) retarray, extent,
"return value", "MINVAL");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "MINVAL");
}
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
if (extent[n] <= 0)
return;
}
dest = retarray->base_addr;
base = array->base_addr;
while (base)
{
const GFC_INTEGER_4 * restrict src;
const GFC_LOGICAL_1 * restrict msrc;
src = base;
msrc = mbase;
{
const GFC_INTEGER_4 *retval;
memset (dest, 255, sizeof (*dest) * string_len);
retval = dest;
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
{
if (*msrc)
{
retval = src;
break;
}
}
for (; n < len; n++, src += delta, msrc += mdelta)
{
if (*msrc && compare_fcn (src, retval, string_len) < 0)
{
retval = src;
}
}
memcpy (dest, retval, sizeof (*dest) * string_len);
}
/* Advance to the next element. */
count[0]++;
base += sstride[0];
mbase += mstride[0];
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
mbase -= mstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
mbase += mstride[n];
dest += dstride[n];
}
}
}
}
void sminval1_s4 (gfc_array_s4 * const restrict,
gfc_charlen_type, gfc_array_s4 * const restrict,
const index_type * const restrict,
GFC_LOGICAL_4 *, gfc_charlen_type);
export_proto(sminval1_s4);
void
sminval1_s4 (gfc_array_s4 * const restrict retarray,
gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
const index_type * const restrict pdim,
GFC_LOGICAL_4 *mask, gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_4 * restrict dest;
index_type rank;
index_type n;
index_type dim;
if (*mask)
{
minval1_s4 (retarray, xlen, array, pdim, string_len);
return;
}
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
for (n = 0; n < dim; n++)
{
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] <= 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
extent[n] =
GFC_DESCRIPTOR_EXTENT(array,n + 1);
if (extent[n] <= 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
* string_len;
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
return;
}
else
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MINVAL intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (unlikely (compile_options.bounds_check))
{
for (n=0; n < rank; n++)
{
index_type ret_extent;
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MINVAL intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
}
dest = retarray->base_addr;
while(1)
{
memset (dest, 255, sizeof (*dest) * string_len);
count[0]++;
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
dest += dstride[n];
}
}
}
}
#endif

24
libgfortran/gfortran.map
View file

@ -420,6 +420,10 @@ GFORTRAN_8 {
_gfortran_maxloc2_4_s4;
_gfortran_maxloc2_8_s1;
_gfortran_maxloc2_8_s4;
_gfortran_maxval0_s1;
_gfortran_maxval0_s4;
_gfortran_maxval1_s1;
_gfortran_maxval1_s4;
_gfortran_maxval_i16;
_gfortran_maxval_i1;
_gfortran_maxval_i2;
@ -513,6 +517,10 @@ GFORTRAN_8 {
_gfortran_minloc2_4_s4;
_gfortran_minloc2_8_s1;
_gfortran_minloc2_8_s4;
_gfortran_minval0_s1;
_gfortran_minval0_s4;
_gfortran_minval1_s1;
_gfortran_minval1_s4;
_gfortran_minval_i16;
_gfortran_minval_i1;
_gfortran_minval_i2;
@ -599,6 +607,10 @@ GFORTRAN_8 {
_gfortran_mmaxloc2_4_s4;
_gfortran_mmaxloc2_8_s1;
_gfortran_mmaxloc2_8_s4;
_gfortran_mmaxval0_s1;
_gfortran_mmaxval0_s4;
_gfortran_mmaxval1_s1;
_gfortran_mmaxval1_s4;
_gfortran_mmaxval_i16;
_gfortran_mmaxval_i1;
_gfortran_mmaxval_i2;
@ -680,6 +692,10 @@ GFORTRAN_8 {
_gfortran_mminloc2_4_s4;
_gfortran_mminloc2_8_s1;
_gfortran_mminloc2_8_s4;
_gfortran_mminval0_s1;
_gfortran_mminval0_s4;
_gfortran_mminval1_s1;
_gfortran_mminval1_s4;
_gfortran_mminval_i16;
_gfortran_mminval_i1;
_gfortran_mminval_i2;
@ -927,6 +943,10 @@ GFORTRAN_8 {
_gfortran_smaxloc2_4_s4;
_gfortran_smaxloc2_8_s1;
_gfortran_smaxloc2_8_s4;
_gfortran_smaxval0_s1;
_gfortran_smaxval0_s4;
_gfortran_smaxval1_s1;
_gfortran_smaxval1_s4;
_gfortran_smaxval_i16;
_gfortran_smaxval_i1;
_gfortran_smaxval_i2;
@ -1008,6 +1028,10 @@ GFORTRAN_8 {
_gfortran_sminloc2_4_s4;
_gfortran_sminloc2_8_s1;
_gfortran_sminloc2_8_s4;
_gfortran_sminval0_s1;
_gfortran_sminval0_s4;
_gfortran_sminval1_s1;
_gfortran_sminval1_s4;
_gfortran_sminval_i16;
_gfortran_sminval_i1;
_gfortran_sminval_i2;

222
libgfortran/m4/iforeach-s2.m4 Normal file
View file

@ -0,0 +1,222 @@
dnl Support macro file for intrinsic functions.
dnl Contains the generic sections of the array functions.
dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
dnl Distributed under the GNU GPL with exception. See COPYING for details.
define(START_FOREACH_FUNCTION,
`static inline int
compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n)
{
if (sizeof ('atype_name`) == 1)
return memcmp (a, b, n);
else
return memcmp_char4 (a, b, n);
}
#define INITVAL 'initval`
extern void 'name`'rtype_qual`_'atype_code (atype_name * restrict,
gfc_charlen_type,
atype * const restrict array, gfc_charlen_type);
export_proto(name`'rtype_qual`_'atype_code);
void
name`'rtype_qual`_'atype_code` ('atype_name` * restrict ret,
gfc_charlen_type xlen,
'atype` * const restrict array, gfc_charlen_type len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
const 'atype_name` *base;
index_type rank;
index_type n;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
assert (xlen == len);
/* Initialize return value. */
memset (ret, INITVAL, sizeof(*ret) * len);
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
count[n] = 0;
if (extent[n] <= 0)
return;
}
base = array->base_addr;
{
')dnl
define(START_FOREACH_BLOCK,
` while (base)
{
do
{
/* Implementation start. */
')dnl
define(FINISH_FOREACH_FUNCTION,
` /* Implementation end. */
/* Advance to the next element. */
base += sstride[0];
}
while (++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
}
}
while (count[n] == extent[n]);
}
memcpy (ret, retval, len * sizeof (*ret));
}
}')dnl
define(START_MASKED_FOREACH_FUNCTION,
`
extern void `m'name`'rtype_qual`_'atype_code (atype_name * restrict,
gfc_charlen_type, atype * const restrict array,
gfc_array_l1 * const restrict mask, gfc_charlen_type len);
export_proto(`m'name`'rtype_qual`_'atype_code);
void
`m'name`'rtype_qual`_'atype_code (atype_name * const restrict ret,
gfc_charlen_type xlen, atype * const restrict array,
gfc_array_l1 * const restrict mask, gfc_charlen_type len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
const atype_name *base;
GFC_LOGICAL_1 *mbase;
int rank;
index_type n;
int mask_kind;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
assert (xlen == len);
/* Initialize return value. */
memset (ret, INITVAL, sizeof(*ret) * len);
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
mbase = mask->base_addr;
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
runtime_error ("Funny sized logical array");
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
count[n] = 0;
if (extent[n] <= 0)
return;
}
base = array->base_addr;
{
')dnl
define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
define(FINISH_MASKED_FOREACH_FUNCTION,
` /* Implementation end. */
/* Advance to the next element. */
base += sstride[0];
mbase += mstride[0];
}
while (++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
mbase += mstride[n];
}
}
while (count[n] == extent[n]);
}
memcpy (ret, retval, len * sizeof (*ret));
}
}')dnl
define(FOREACH_FUNCTION,
`START_FOREACH_FUNCTION
$1
START_FOREACH_BLOCK
$2
FINISH_FOREACH_FUNCTION')dnl
define(MASKED_FOREACH_FUNCTION,
`START_MASKED_FOREACH_FUNCTION
$1
START_MASKED_FOREACH_BLOCK
$2
FINISH_MASKED_FOREACH_FUNCTION')dnl
define(SCALAR_FOREACH_FUNCTION,
`
extern void `s'name`'rtype_qual`_'atype_code (atype_name * restrict,
gfc_charlen_type,
atype * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
export_proto(`s'name`'rtype_qual`_'atype_code);
void
`s'name`'rtype_qual`_'atype_code (atype_name * restrict ret,
gfc_charlen_type xlen, atype * const restrict array,
GFC_LOGICAL_4 *mask, gfc_charlen_type len)
{
if (*mask)
{
name`'rtype_qual`_'atype_code (ret, xlen, array, len);
return;
}
memset (ret, INITVAL, sizeof (*ret) * len);
}')dnl

542
libgfortran/m4/ifunction-s2.m4 Normal file
View file

@ -0,0 +1,542 @@
dnl Support macro file for intrinsic functions.
dnl Contains the generic sections of the array functions.
dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
dnl Distributed under the GNU GPL with exception. See COPYING for details.
dnl
dnl Pass the implementation for a single section as the parameter to
dnl {MASK_}ARRAY_FUNCTION.
dnl The variables base, delta, and len describe the input section.
dnl For masked section the mask is described by mbase and mdelta.
dnl These should not be modified. The result should be stored in *dest.
dnl The names count, extent, sstride, dstride, base, dest, rank, dim
dnl retarray, array, pdim and mstride should not be used.
dnl The variable n is declared as index_type and may be used.
dnl Other variable declarations may be placed at the start of the code,
dnl The types of the array parameter and the return value are
dnl atype_name and rtype_name respectively.
dnl Execution should be allowed to continue to the end of the block.
dnl You should not return or break from the inner loop of the implementation.
dnl Care should also be taken to avoid using the names defined in iparm.m4
define(START_ARRAY_FUNCTION,
`#include <string.h>
#include <assert.h>
static inline int
compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n)
{
if (sizeof ('atype_name`) == 1)
return memcmp (a, b, n);
else
return memcmp_char4 (a, b, n);
}
extern void name`'rtype_qual`_'atype_code (rtype * const restrict,
gfc_charlen_type, atype * const restrict,
const index_type * const restrict, gfc_charlen_type);
export_proto(name`'rtype_qual`_'atype_code);
void
name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
gfc_charlen_type xlen, atype * const restrict array,
const index_type * const restrict pdim, gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
const atype_name * restrict base;
rtype_name * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int continue_loop;
assert (xlen == string_len);
/* Make dim zero based to avoid confusion. */
rank = GFC_DESCRIPTOR_RANK (array) - 1;
dim = (*pdim) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in u_name intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
len = GFC_DESCRIPTOR_EXTENT(array,dim);
if (len < 0)
len = 0;
delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
for (n = 0; n < dim; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] < 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
if (extent[n] < 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
* string_len;
retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
return;
}
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" u_name intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (unlikely (compile_options.bounds_check))
bounds_ifunction_return ((array_t *) retarray, extent,
"return value", "u_name");
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
if (extent[n] <= 0)
return;
}
base = array->base_addr;
dest = retarray->base_addr;
continue_loop = 1;
while (continue_loop)
{
const atype_name * restrict src;
src = base;
{
')dnl
define(START_ARRAY_BLOCK,
` if (len <= 0)
memset (dest, '$1`, sizeof (*dest) * string_len);
else
{
for (n = 0; n < len; n++, src += delta)
{
')dnl
define(FINISH_ARRAY_FUNCTION,
` }
'$1`
memcpy (dest, retval, sizeof (*dest) * string_len);
}
}
/* Advance to the next element. */
count[0]++;
base += sstride[0];
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
continue_loop = 0;
break;
}
else
{
count[n]++;
base += sstride[n];
dest += dstride[n];
}
}
}
}')dnl
define(START_MASKED_ARRAY_FUNCTION,
`
extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
gfc_charlen_type, atype * const restrict,
const index_type * const restrict,
gfc_array_l1 * const restrict, gfc_charlen_type);
export_proto(`m'name`'rtype_qual`_'atype_code);
void
`m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
gfc_charlen_type xlen, atype * const restrict array,
const index_type * const restrict pdim,
gfc_array_l1 * const restrict mask,
gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
rtype_name * restrict dest;
const atype_name * restrict base;
const GFC_LOGICAL_1 * restrict mbase;
index_type rank;
index_type dim;
index_type n;
index_type len;
index_type delta;
index_type mdelta;
int mask_kind;
assert (xlen == string_len);
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in u_name intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
len = GFC_DESCRIPTOR_EXTENT(array,dim);
if (len <= 0)
return;
mbase = mask->base_addr;
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
runtime_error ("Funny sized logical array");
delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
for (n = 0; n < dim; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] < 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
if (extent[n] < 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
* string_len;
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
return;
}
else
retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in u_name intrinsic");
if (unlikely (compile_options.bounds_check))
{
bounds_ifunction_return ((array_t *) retarray, extent,
"return value", "u_name");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "u_name");
}
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
if (extent[n] <= 0)
return;
}
dest = retarray->base_addr;
base = array->base_addr;
while (base)
{
const atype_name * restrict src;
const GFC_LOGICAL_1 * restrict msrc;
src = base;
msrc = mbase;
{
')dnl
define(START_MASKED_ARRAY_BLOCK,
` for (n = 0; n < len; n++, src += delta, msrc += mdelta)
{
')dnl
define(FINISH_MASKED_ARRAY_FUNCTION,
` }
memcpy (dest, retval, sizeof (*dest) * string_len);
}
/* Advance to the next element. */
count[0]++;
base += sstride[0];
mbase += mstride[0];
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n];
mbase -= mstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
mbase += mstride[n];
dest += dstride[n];
}
}
}
}')dnl
define(SCALAR_ARRAY_FUNCTION,
`
void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
gfc_charlen_type, atype * const restrict,
const index_type * const restrict,
GFC_LOGICAL_4 *, gfc_charlen_type);
export_proto(`s'name`'rtype_qual`_'atype_code);
void
`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
gfc_charlen_type xlen, atype * const restrict array,
const index_type * const restrict pdim,
GFC_LOGICAL_4 *mask, gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
rtype_name * restrict dest;
index_type rank;
index_type n;
index_type dim;
if (*mask)
{
name`'rtype_qual`_'atype_code (retarray, xlen, array, pdim, string_len);
return;
}
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in u_name intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
for (n = 0; n < dim; n++)
{
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] <= 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
extent[n] =
GFC_DESCRIPTOR_EXTENT(array,n + 1);
if (extent[n] <= 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
* string_len;
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
return;
}
else
retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" u_name intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (unlikely (compile_options.bounds_check))
{
for (n=0; n < rank; n++)
{
index_type ret_extent;
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" u_name intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
}
dest = retarray->base_addr;
while(1)
{
memset (dest, '$1`, sizeof (*dest) * string_len);
count[0]++;
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
dest += dstride[n];
}
}
}
}')dnl
define(ARRAY_FUNCTION,
`START_ARRAY_FUNCTION($1)
$2
START_ARRAY_BLOCK($1)
$3
FINISH_ARRAY_FUNCTION($4)')dnl
define(MASKED_ARRAY_FUNCTION,
`START_MASKED_ARRAY_FUNCTION
$2
START_MASKED_ARRAY_BLOCK
$3
FINISH_MASKED_ARRAY_FUNCTION')dnl

1
libgfortran/m4/iparm.m4
View file

@ -35,3 +35,4 @@ define(name, regexp(regexp(file, `[^/]*$', `\&'), `^\([^_]*\)_', `\1'))dnl
define(`upcase', `translit(`$*', `a-z', `A-Z')')dnl
define(`u_name',`regexp(upcase(name),`\([A-Z]*\)',`\1')')dnl
define(rtype_ccode,ifelse(rtype_letter,`i',rtype_kind,rtype_code))dnl
define(initval,ifelse(index(name,`maxval'),0,0,index(name,`minval'),0,255))dnl

58
libgfortran/m4/maxval0s.m4 Normal file
View file

@ -0,0 +1,58 @@
`/* Implementation of the MAXLOC intrinsic
Copyright 2017 Free Software Foundation, Inc.
Contributed by Thomas Koenig
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <stdlib.h>
#include <string.h>
#include <assert.h>
#include <limits.h>'
include(iparm.m4)dnl
include(iforeach-s2.m4)dnl
`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
FOREACH_FUNCTION(
` const atype_name *retval;
retval = ret;'
,
` if (compare_fcn (base, retval, len) > 0)
{
retval = base;
}')
MASKED_FOREACH_FUNCTION(
` const atype_name *retval;
retval = ret;'
,
` if (*mbase && compare_fcn (base, retval, len) > 0)
{
retval = base;
}')
SCALAR_FOREACH_FUNCTION
#endif

61
libgfortran/m4/maxval1s.m4 Normal file
View file

@ -0,0 +1,61 @@
`/* Implementation of the MAXVAL intrinsic
Copyright 2017 Free Software Foundation, Inc.
Contributed by Thomas Koenig
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"'
include(iparm.m4)dnl
include(ifunction-s2.m4)dnl
`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
ARRAY_FUNCTION(0,
` const atype_name *retval;
retval = base;',
` if (compare_fcn (src, retval, string_len) > 0)
{
retval = src;
}', `')
MASKED_ARRAY_FUNCTION(0,
` const atype_name *retval;
memset (dest, 0, sizeof (*dest) * string_len);
retval = dest;',
` if (*msrc)
{
retval = src;
break;
}
}
for (; n < len; n++, src += delta, msrc += mdelta)
{
if (*msrc && compare_fcn (src, retval, string_len) > 0)
{
retval = src;
}
')
SCALAR_ARRAY_FUNCTION(0)
#endif

58
libgfortran/m4/minval0s.m4 Normal file
View file

@ -0,0 +1,58 @@
`/* Implementation of the MAXLOC intrinsic
Copyright 2017 Free Software Foundation, Inc.
Contributed by Thomas Koenig
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <stdlib.h>
#include <string.h>
#include <assert.h>
#include <limits.h>'
include(iparm.m4)dnl
include(iforeach-s2.m4)dnl
`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
FOREACH_FUNCTION(
` const atype_name *retval;
retval = ret;'
,
` if (compare_fcn (base, retval, len) < 0)
{
retval = base;
}')
MASKED_FOREACH_FUNCTION(
` const atype_name *retval;
retval = ret;'
,
` if (*mbase && compare_fcn (base, retval, len) < 0)
{
retval = base;
}')
SCALAR_FOREACH_FUNCTION
#endif

61
libgfortran/m4/minval1s.m4 Normal file
View file

@ -0,0 +1,61 @@
`/* Implementation of the MAXVAL intrinsic
Copyright 2017 Free Software Foundation, Inc.
Contributed by Thomas Koenig
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"'
include(iparm.m4)dnl
include(ifunction-s2.m4)dnl
`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
ARRAY_FUNCTION(255,
` const atype_name *retval;
retval = base;',
` if (compare_fcn (src, retval, string_len) < 0)
{
retval = src;
}', `')
MASKED_ARRAY_FUNCTION(255,
` const atype_name *retval;
memset (dest, 255, sizeof (*dest) * string_len);
retval = dest;',
` if (*msrc)
{
retval = src;
break;
}
}
for (; n < len; n++, src += delta, msrc += mdelta)
{
if (*msrc && compare_fcn (src, retval, string_len) < 0)
{
retval = src;
}
')
SCALAR_ARRAY_FUNCTION(255)
#endif