intrinsic.h (gfc_check_selected_real_kind, [...]): Update prototypes.

2010-06-25  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-25  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-25  Tobias Burnus  <burnus@net-b.de>

        * selected_real_kind_2.f90: New.
        * selected_real_kind_3.f90: New.

From-SVN: r161411

gcc/fortran/ChangeLog

@@ -1,3 +1,16 @@
+2010-06-25  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-25  Tobias Burnus  <burnus@net-b.de>
 
 	* decl.c (gfc_match_entry): Mark ENTRY as GFC_STD_F2008_OBS.

gcc/fortran/check.c

@@ -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)
+  if (p == NULL && r == NULL
-    {
+      && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SELECTED_REAL_KIND with"
-      gfc_error ("Missing arguments to %s intrinsic at %L",
+			 " neither 'P' nor 'R' argument at %L",
-		 gfc_current_intrinsic, gfc_current_intrinsic_where);
+			 gfc_current_intrinsic_where) == FAILURE)
-
+    return FAILURE;
-      return FAILURE;
-    }
 
   if (p)
     {
@@ -2948,6 +2946,20 @@ gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
 	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;
 }
 

gcc/fortran/intrinsic.c

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

gcc/fortran/intrinsic.h

@@ -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_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 *);

gcc/fortran/intrinsic.texi

@@ -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
+with decimal precision of at least @code{P} digits, exponent range of
-range greater at least @code{R}. 
+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
+a real data type with decimal precision of at least @code{P} digits, a
-decimal exponent range of at least @code{R}. If more than one real data
+decimal exponent range of at least @code{R}, and with the requested
-type meet the criteria, the kind of the data type with the smallest
+@code{RADIX}. If the @code{RADIX} parameter is absent, real kinds with
-decimal precision is returned. If no real data type matches the criteria,
+any radix can be returned. If more than one real data type meet the
-the result is
+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}
+range greater than or equal to @code{R}, but @code{P} and @code{RADIX}
-@item -3 if neither is supported.
+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

gcc/fortran/simplify.c

@@ -4589,9 +4589,11 @@ gfc_simplify_selected_int_kind (gfc_expr *e)
 
 
 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_expr *p, gfc_expr *q)
       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_expr *p, gfc_expr *q)
       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_expr *p, gfc_expr *q)
       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_radix && found_range && !found_precision)
-
-      if (!found_precision)
 	kind = -1;
-      if (!found_range)
+      else if (found_radix && found_precision && !found_range)
-	kind -= 2;
+	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,
+  return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
-			   p ? &p->where : &q->where, kind);
 }
 
 

gcc/fortran/trans-decl.c

@@ -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")),
+					(PREFIX("selected_real_kind2008")),
-                                     gfc_int4_type_node, 2,
+				     gfc_int4_type_node, 3,
-                                     pvoid_type_node, pvoid_type_node);
+				     pvoid_type_node, pvoid_type_node,
+				     pvoid_type_node);
 
   /* Power functions.  */
   {

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2010-06-25  Tobias Burnus  <burnus@net-b.de>
+
+	* selected_real_kind_2.f90: New.
+	* selected_real_kind_3.f90: New.
+
 2010-06-25  Tobias Burnus  <burnus@net-b.de>
 
 	* gfortran.dg/entry_19.f90: New.

gcc/testsuite/gfortran.dg/selected_real_kind_2.f90

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

gcc/testsuite/gfortran.dg/selected_real_kind_3.f90

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

libgfortran/ChangeLog

@@ -1,3 +1,13 @@
+2010-06-25  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-25  Tobias Burnus  <burnus@net-b.de>
 
 	* runtime/compile_options.c (init_compile_options): Update

libgfortran/gfortran.map

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

libgfortran/intrinsics/selected_real_kind.f90

@@ -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, optional, intent (in) :: p, r, rdx
-  integer :: _gfortran_selected_real_kind
+  integer :: _gfortran_selected_real_kind2008
-  integer :: i, p2, r2
+  integer :: i, p2, r2, radix2
-  logical :: found_p, found_r
+  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
+    if (radix2 <= real_infos (i) % radix) found_radix = .true.
-      _gfortran_selected_real_kind = real_infos (i) % kind
+
+    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 (found_radix .and. found_r .and. .not. found_p) then
-  if (.not. (found_r)) _gfortran_selected_real_kind = _gfortran_selected_real_kind - 2
+    _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
 
-  return
+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
+
+  _gfortran_selected_real_kind = _gfortran_selected_real_kind2008 (p, r)
 end function

libgfortran/mk-srk-inc.sh

@@ -22,7 +22,7 @@ echo "  type (real_info), parameter :: real_infos(c) = (/ &"
 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, &"