From 01349049e8a5e3d82ea0344c7628024a7c936a3a Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Fri, 25 Jun 2010 21:40:37 +0200 Subject: [PATCH] intrinsic.h (gfc_check_selected_real_kind, [...]): Update prototypes. 2010-06-25 Tobias Burnus * 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 * 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 * selected_real_kind_2.f90: New. * selected_real_kind_3.f90: New. From-SVN: r161411 --- gcc/fortran/ChangeLog | 13 +++++ gcc/fortran/check.c | 28 ++++++--- gcc/fortran/intrinsic.c | 5 +- gcc/fortran/intrinsic.h | 4 +- gcc/fortran/intrinsic.texi | 48 +++++++++++----- gcc/fortran/simplify.c | 46 +++++++++++---- gcc/fortran/trans-decl.c | 7 ++- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/selected_real_kind_2.f90 | 32 +++++++++++ .../gfortran.dg/selected_real_kind_3.f90 | 6 ++ libgfortran/ChangeLog | 10 ++++ libgfortran/gfortran.map | 1 + libgfortran/intrinsics/selected_real_kind.f90 | 57 ++++++++++++++----- libgfortran/mk-srk-inc.sh | 2 +- 14 files changed, 212 insertions(+), 52 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/selected_real_kind_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/selected_real_kind_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index cb551de6d1e..c09de2161c8 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2010-06-25 Tobias Burnus + + * 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 * decl.c (gfc_match_entry): Mark ENTRY as GFC_STD_F2008_OBS. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 81f3e24847b..34527172431 100644 --- a/gcc/fortran/check.c +++ b/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) - { - 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 *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; } diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index e5463a1a74f..833fd30beb1 100644 --- a/gcc/fortran/intrinsic.c +++ b/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); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index a2cd55a87a9..919f09e90b4 100644 --- a/gcc/fortran/intrinsic.h +++ b/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 *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index a24ad91cc2d..06c6793b2c4 100644 --- a/gcc/fortran/intrinsic.texi +++ b/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 -range greater at least @code{R}. +with decimal precision of at least @code{P} digits, exponent range of +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 diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 743c4632986..7356625cf41 100644 --- a/gcc/fortran/simplify.c +++ b/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_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); } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index d75a195924c..1c7226c41e6 100644 --- a/gcc/fortran/trans-decl.c +++ b/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")), - 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. */ { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f06c7a11b42..8365f765322 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2010-06-25 Tobias Burnus + + * selected_real_kind_2.f90: New. + * selected_real_kind_3.f90: New. + 2010-06-25 Tobias Burnus * gfortran.dg/entry_19.f90: New. diff --git a/gcc/testsuite/gfortran.dg/selected_real_kind_2.f90 b/gcc/testsuite/gfortran.dg/selected_real_kind_2.f90 new file mode 100644 index 00000000000..cf73520f930 --- /dev/null +++ b/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 diff --git a/gcc/testsuite/gfortran.dg/selected_real_kind_3.f90 b/gcc/testsuite/gfortran.dg/selected_real_kind_3.f90 new file mode 100644 index 00000000000..d24d877acfe --- /dev/null +++ b/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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 129841b1f59..3c2c75cd1b1 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,13 @@ +2010-06-25 Tobias Burnus + + * 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 * runtime/compile_options.c (init_compile_options): Update diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index 3e854eb0eae..ce5aa77b02d 100644 --- a/libgfortran/gfortran.map +++ b/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 { diff --git a/libgfortran/intrinsics/selected_real_kind.f90 b/libgfortran/intrinsics/selected_real_kind.f90 index ea3b46aabdd..92708d7205f 100644 --- a/libgfortran/intrinsics/selected_real_kind.f90 +++ b/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 ! -!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 !. -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 - 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 diff --git a/libgfortran/mk-srk-inc.sh b/libgfortran/mk-srk-inc.sh index 10c428f02d6..402441ce6f2 100755 --- a/libgfortran/mk-srk-inc.sh +++ b/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, &"