Skip to content

R
riscv-gcc-1
Commit 0ac74254 by Thomas Koenig
Options

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

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
parent af5ad1e2
Showing with 2086 additions and 11 deletions
gcc/fortran/ChangeLog
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
......
gcc/fortran/check.c
......@@ -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;
......
gcc/fortran/iresolve.c
......@@ -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);
}
......
gcc/fortran/trans-intrinsic.c
......@@ -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);
......
gcc/testsuite/ChangeLog
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
......
gcc/testsuite/gfortran.dg/maxval_char_1.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/maxval_char_2.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/maxval_char_3.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/maxval_char_4.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/minval_char_1.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/minval_char_2.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/minval_char_3.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/minval_char_4.f90 0 → 100644
! { 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
libgfortran/ChangeLog
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>
......
libgfortran/Makefile.am
......@@ -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 > $@
......
libgfortran/generated/maxval0_s1.c 0 → 100644
/* 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
libgfortran/generated/maxval0_s4.c 0 → 100644
/* 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
libgfortran/generated/minval0_s1.c 0 → 100644
/* 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
libgfortran/generated/minval0_s4.c 0 → 100644
/* 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
libgfortran/gfortran.map
......@@ -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;
......
libgfortran/m4/iforeach-s2.m4 0 → 100644
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
libgfortran/m4/iparm.m4
......@@ -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
libgfortran/m4/maxval0s.m4 0 → 100644
`/* 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
libgfortran/m4/maxval1s.m4 0 → 100644
`/* 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
libgfortran/m4/minval0s.m4 0 → 100644
`/* 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
libgfortran/m4/minval1s.m4 0 → 100644
`/* 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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment