2010-06-24 Tobias Burnus <burnus@net-b.de>
* intrinsic.h (gfc_check_selected_real_kind,
gfc_simplify_selected_real_kind): Update prototypes.
* intrinsic.c (add_functions): Add radix support to
selected_real_kind.
* check.c (gfc_check_selected_real_kind): Ditto.
* simplify.c (gfc_simplify_selected_real_kind): Ditto.
* trans-decl.c (gfc_build_intrinsic_function_decls):
Change call from selected_real_kind to selected_real_kind2008.
* intrinsic.texi (SELECTED_REAL_KIND): Update for radix.
(PRECISION, RANGE, RADIX): Add cross @refs.
2010-06-24 Tobias Burnus <burnus@net-b.de>
* intrinsics/selected_real_kind.f90
(_gfortran_selected_real_kind2008): Add function.
(_gfortran_selected_real_kind): Stub which calls
_gfortran_selected_real_kind2008.
* gfortran.map (GFORTRAN_1.4): Add
_gfortran_selected_real_kind2008.
* mk-srk-inc.sh: Save also RADIX.
2010-06-24 Tobias Burnus <burnus@net-b.de>
* selected_real_kind_2.f90: New.
* selected_real_kind_3.f90: New.
===================================================================
@@ -126,7 +126,7 @@ gfc_try gfc_check_second_sub (gfc_expr *
gfc_try gfc_check_secnds (gfc_expr *);
gfc_try gfc_check_selected_char_kind (gfc_expr *);
gfc_try gfc_check_selected_int_kind (gfc_expr *);
-gfc_try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *);
+gfc_try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_set_exponent (gfc_expr *, gfc_expr *);
gfc_try gfc_check_shape (gfc_expr *);
gfc_try gfc_check_size (gfc_expr *, gfc_expr *, gfc_expr *);
@@ -322,7 +322,7 @@ gfc_expr *gfc_simplify_scale (gfc_expr *
gfc_expr *gfc_simplify_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_selected_char_kind (gfc_expr *);
gfc_expr *gfc_simplify_selected_int_kind (gfc_expr *);
-gfc_expr *gfc_simplify_selected_real_kind (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_set_exponent (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_sign (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_shape (gfc_expr *);
===================================================================
@@ -2375,10 +2375,11 @@ add_functions (void)
make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95);
- add_sym_2 ("selected_real_kind", GFC_ISYM_SR_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di,
+ add_sym_3 ("selected_real_kind", GFC_ISYM_SR_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_F95, gfc_check_selected_real_kind,
gfc_simplify_selected_real_kind, NULL,
- p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL);
+ p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL,
+ "radix", BT_INTEGER, di, OPTIONAL);
make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95);
===================================================================
@@ -2920,15 +2920,13 @@ gfc_check_selected_int_kind (gfc_expr *r
gfc_try
-gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
+gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
{
- if (p == NULL && r == NULL)
- {
- gfc_error ("Missing arguments to %s intrinsic at %L",
- gfc_current_intrinsic, gfc_current_intrinsic_where);
-
- return FAILURE;
- }
+ if (p == NULL && r == NULL
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SELECTED_REAL_KIND with"
+ " neither 'P' nor 'R' argument at %L",
+ gfc_current_intrinsic_where) == FAILURE)
+ return FAILURE;
if (p)
{
@@ -2948,6 +2946,20 @@ gfc_check_selected_real_kind (gfc_expr *
return FAILURE;
}
+ if (radix)
+ {
+ if (type_check (radix, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (radix, 1) == FAILURE)
+ return FAILURE;
+
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: '%s' intrinsic with "
+ "RADIX argument at %L", gfc_current_intrinsic,
+ &radix->where) == FAILURE)
+ return FAILURE;
+ }
+
return SUCCESS;
}
===================================================================
@@ -4589,9 +4589,11 @@ gfc_simplify_selected_int_kind (gfc_expr
gfc_expr *
-gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
+gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
{
- int range, precision, i, kind, found_precision, found_range;
+ int range, precision, radix, i, kind, found_precision, found_range,
+ found_radix;
+ locus *loc = &gfc_current_locus;
if (p == NULL)
precision = 0;
@@ -4600,6 +4602,7 @@ gfc_simplify_selected_real_kind (gfc_exp
if (p->expr_type != EXPR_CONSTANT
|| gfc_extract_int (p, &precision) != NULL)
return NULL;
+ loc = &p->where;
}
if (q == NULL)
@@ -4609,11 +4612,27 @@ gfc_simplify_selected_real_kind (gfc_exp
if (q->expr_type != EXPR_CONSTANT
|| gfc_extract_int (q, &range) != NULL)
return NULL;
+
+ if (!loc)
+ loc = &q->where;
+ }
+
+ if (rdx == NULL)
+ radix = 0;
+ else
+ {
+ if (rdx->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (rdx, &radix) != NULL)
+ return NULL;
+
+ if (!loc)
+ loc = &rdx->where;
}
kind = INT_MAX;
found_precision = 0;
found_range = 0;
+ found_radix = 0;
for (i = 0; gfc_real_kinds[i].kind != 0; i++)
{
@@ -4623,23 +4642,30 @@ gfc_simplify_selected_real_kind (gfc_exp
if (gfc_real_kinds[i].range >= range)
found_range = 1;
+ if (gfc_real_kinds[i].radix >= radix)
+ found_radix = 1;
+
if (gfc_real_kinds[i].precision >= precision
- && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
+ && gfc_real_kinds[i].range >= range
+ && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
kind = gfc_real_kinds[i].kind;
}
if (kind == INT_MAX)
{
- kind = 0;
-
- if (!found_precision)
+ if (found_radix && found_range && !found_precision)
kind = -1;
- if (!found_range)
- kind -= 2;
+ else if (found_radix && found_precision && !found_range)
+ kind = -2;
+ else if (found_radix && !found_precision && !found_range)
+ kind = -3;
+ else if (found_radix)
+ kind = -4;
+ else
+ kind = -5;
}
- return gfc_get_int_expr (gfc_default_integer_kind,
- p ? &p->where : &q->where, kind);
+ return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
}
===================================================================
@@ -2612,9 +2612,10 @@ gfc_build_intrinsic_function_decls (void
gfor_fndecl_sr_kind =
gfc_build_library_function_decl (get_identifier
- (PREFIX("selected_real_kind")),
- gfc_int4_type_node, 2,
- pvoid_type_node, pvoid_type_node);
+ (PREFIX("selected_real_kind2008")),
+ gfc_int4_type_node, 3,
+ pvoid_type_node, pvoid_type_node,
+ pvoid_type_node);
/* Power functions. */
{
===================================================================
@@ -8716,6 +8716,9 @@ Inquiry function
The return value is of type @code{INTEGER} and of the default integer
kind.
+@item @emph{See also}:
+@ref{SELECTED_REAL_KIND}, @ref{RANGE}
+
@item @emph{Example}:
@smallexample
program prec_and_range
@@ -8861,6 +8864,9 @@ Inquiry function
The return value is a scalar of type @code{INTEGER} and of the default
integer kind.
+@item @emph{See also}:
+@ref{SELECTED_REAL_KIND}
+
@item @emph{Example}:
@smallexample
program test_radix
@@ -9098,6 +9104,9 @@ or @code{COMPLEX}.
The return value is of type @code{INTEGER} and of the default integer
kind.
+@item @emph{See also}:
+@ref{SELECTED_REAL_KIND}, @ref{PRECISION}
+
@item @emph{Example}:
See @code{PRECISION} for an example.
@end table
@@ -9676,45 +9685,58 @@ end program large_integers
@fnindex SELECTED_REAL_KIND
@cindex real kind
@cindex kind, real
+@cindex radix, real
@table @asis
@item @emph{Description}:
@code{SELECTED_REAL_KIND(P,R)} returns the kind value of a real data type
-with decimal precision of at least @code{P} digits and exponent
-range greater at least @code{R}.
+with decimal precision of at least @code{P} digits, exponent range greater
+at least @code{R}, and with a radix of @code{RADIX}.
@item @emph{Standard}:
-Fortran 95 and later
+Fortran 95 and later, with @code{RADIX} Fortran 2008 or later
@item @emph{Class}:
Transformational function
@item @emph{Syntax}:
-@code{RESULT = SELECTED_REAL_KIND([P, R])}
+@code{RESULT = SELECTED_REAL_KIND([P, R, RADIX])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{P} @tab (Optional) shall be a scalar and of type @code{INTEGER}.
@item @var{R} @tab (Optional) shall be a scalar and of type @code{INTEGER}.
+@item @var{RADIX} @tab (Optional) shall be a scalar and of type @code{INTEGER}.
@end multitable
-At least one argument shall be present.
+Before Fortran 2008, at least one of the arguments @var{R} or @var{P} shall
+be present; since Fortran 2008, they are assumed to be zero if absent.
@item @emph{Return value}:
@code{SELECTED_REAL_KIND} returns the value of the kind type parameter of
-a real data type with decimal precision of at least @code{P} digits and a
-decimal exponent range of at least @code{R}. If more than one real data
-type meet the criteria, the kind of the data type with the smallest
-decimal precision is returned. If no real data type matches the criteria,
-the result is
+a real data type with decimal precision of at least @code{P} digits, a
+decimal exponent range of at least @code{R}, and with the requested
+@code{RADIX}. If the @code{RADIX} parameter is absent, real kinds with
+any radix can be returned. If more than one real data type meet the
+criteria, the kind of the data type with the smallest decimal precision
+is returned. If no real data type matches the criteria, the result is
@table @asis
@item -1 if the processor does not support a real data type with a
-precision greater than or equal to @code{P}
+precision greater than or equal to @code{P}, but the @code{R} and
+@code{RADIX} requirements can be fulfilled
@item -2 if the processor does not support a real type with an exponent
-range greater than or equal to @code{R}
-@item -3 if neither is supported.
+range greater than or equal to @code{R}, but @code{P} and @code{RADIX}
+are fulfillable
+@item -3 if @code{RADIX} but not @code{P} and @code{R} requirements
+are fulfillable
+@item -4 if @code{RADIX} and either @code{P} or @code{R} requirements
+are fulfillable
+@item -5 if there is no real type with the given @code{RADIX}
@end table
+@item @emph{See also}:
+@ref{PRECISION}, @ref{RANGE}, @ref{RADIX}
+
@item @emph{Example}:
@smallexample
program real_kinds
===================================================================
@@ -22,7 +22,7 @@ echo " type (real_info), parameter :: r
i=0
for k in $kinds; do
# echo -n is not portable
- str=" real_info ($k, precision(0.0_$k), range(0.0_$k))"
+ str=" real_info ($k, precision(0.0_$k), range(0.0_$k), radix(0.0_$k))"
i=`expr $i + 1`
if [ $i -lt $c ]; then
echo "$str, &"
===================================================================
@@ -1106,6 +1106,7 @@ GFORTRAN_1.3 {
GFORTRAN_1.4 {
global:
_gfortran_error_stop_numeric;
+ _gfortran_selected_real_kind2008;
} GFORTRAN_1.3;
F2C_1.0 {
===================================================================
@@ -1,7 +1,7 @@
-! Copyright 2003, 2004, 2009 Free Software Foundation, Inc.
+! Copyright 2003, 2004, 2009, 2010 Free Software Foundation, Inc.
! Contributed by Kejia Zhao <kejia_zh@yahoo.com.cn>
!
-!This file is part of the GNU Fortran 95 runtime library (libgfortran).
+!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
@@ -22,43 +22,74 @@
!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
!<http://www.gnu.org/licenses/>.
-function _gfortran_selected_real_kind (p, r)
+function _gfortran_selected_real_kind2008 (p, r, rdx)
implicit none
- integer, optional, intent (in) :: p, r
- integer :: _gfortran_selected_real_kind
- integer :: i, p2, r2
- logical :: found_p, found_r
+ integer, optional, intent (in) :: p, r, rdx
+ integer :: _gfortran_selected_real_kind2008
+ integer :: i, p2, r2, radix2
+ logical :: found_p, found_r, found_radix
! Real kind_precision_range table
type :: real_info
integer :: kind
integer :: precision
integer :: range
+ integer :: radix
end type real_info
include "selected_real_kind.inc"
- _gfortran_selected_real_kind = 0
+ _gfortran_selected_real_kind2008 = 0
p2 = 0
r2 = 0
+ radix2 = 0
found_p = .false.
found_r = .false.
+ found_radix = .false.
if (present (p)) p2 = p
if (present (r)) r2 = r
+ if (present (rdx)) radix2 = rdx
! Assumes each type has a greater precision and range than previous one.
do i = 1, c
if (p2 <= real_infos (i) % precision) found_p = .true.
if (r2 <= real_infos (i) % range) found_r = .true.
- if (found_p .and. found_r) then
- _gfortran_selected_real_kind = real_infos (i) % kind
+ if (radix2 <= real_infos (i) % radix) found_radix = .true.
+
+ if (p2 <= real_infos (i) % precision &
+ .and. r2 <= real_infos (i) % range &
+ .and. radix2 <= real_infos (i) % radix) then
+ _gfortran_selected_real_kind2008 = real_infos (i) % kind
return
end if
end do
- if (.not. (found_p)) _gfortran_selected_real_kind = _gfortran_selected_real_kind - 1
- if (.not. (found_r)) _gfortran_selected_real_kind = _gfortran_selected_real_kind - 2
+ if (found_radix .and. found_r .and. .not. found_p) then
+ _gfortran_selected_real_kind2008 = -1
+ elseif (found_radix .and. found_p .and. .not. found_r) then
+ _gfortran_selected_real_kind2008 = -2
+ elseif (found_radix .and. .not. found_p .and. .not. found_r) then
+ _gfortran_selected_real_kind2008 = -3
+ elseif (found_radix) then
+ _gfortran_selected_real_kind2008 = -4
+ else
+ _gfortran_selected_real_kind2008 = -5
+ end if
+end function _gfortran_selected_real_kind2008
+
+function _gfortran_selected_real_kind (p, r)
+ implicit none
+ integer, optional, intent (in) :: p, r
+ integer :: _gfortran_selected_real_kind
+
+ interface
+ function _gfortran_selected_real_kind2008 (p, r, rdx)
+ implicit none
+ integer, optional, intent (in) :: p, r, rdx
+ integer :: _gfortran_selected_real_kind2008
+ end function _gfortran_selected_real_kind2008
+ end interface
- return
+ _gfortran_selected_real_kind = _gfortran_selected_real_kind2008 (p, r)
end function
===================================================================
@@ -0,0 +1,32 @@
+! { dg-do run }
+! { dg-options "-std=f2008 -fall-intrinsics" }
+!
+
+integer :: p, r, rdx
+
+! Compile-time version
+
+if (selected_real_kind(radix=2) /= 4) call should_not_fail()
+if (selected_real_kind(radix=4) /= -5) call should_not_fail()
+if (selected_real_kind(precision(0.0),range(0.0),radix(0.0)) /= kind(0.0)) &
+ call should_not_fail()
+if (selected_real_kind(precision(0.0d0),range(0.0d0),radix(0.0d0)) /= kind(0.0d0)) &
+ call should_not_fail()
+
+! Run-time version
+
+rdx = 2
+if (selected_real_kind(radix=rdx) /= 4) call abort()
+rdx = 4
+if (selected_real_kind(radix=rdx) /= -5) call abort()
+
+rdx = radix(0.0)
+p = precision(0.0)
+r = range(0.0)
+if (selected_real_kind(p,r,rdx) /= kind(0.0)) call abort()
+
+rdx = radix(0.0d0)
+p = precision(0.0d0)
+r = range(0.0d0)
+if (selected_real_kind(p,r,rdx) /= kind(0.0d0)) call abort()
+end
===================================================================
@@ -0,0 +1,6 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+print *, selected_real_kind(p=precision(0.0),radix=2) ! { dg-error "Fortran 2008" }
+print *, selected_real_kind() ! { dg-error "neither 'P' nor 'R' argument" }
+end