On Tue, Jan 08, 2019 at 10:27:25PM +0100, Thomas Koenig wrote:
> Hi Steve,
>
> > Well, that was quick. Moving code around is problematic.
>
> Thanks for checking. The patch is OK for trunk.
>
Thanks. I decided to see if long term approach would work.
It almost does. The attached patch put ieee_selected_real_kind
into the table of intrinsic functions. It automatically gets
us a generic routine with argument chekcing and simplification.
This just works:
program foo
use ieee_arithmetic, only : ieee_selected_real_kind
integer, parameter :: n = ieee_selected_real_kind(6_2)
i = 6
print *, n, ieee_selected_real_kind(6_8), ieee_selected_real_kind(i)
end program foo
Now, the downside. I can't finesse rename on USE. This does not
work, and I'm stuck at the moment.
subroutine bar
use ieee_arithmetic, only : isrk => ieee_selected_real_kind
integer, parameter :: n = isrk(6)
i = 6
print *, n, isrk(6), isrk(i)
end subroutine bar
If anyone has an idea, I would be quite happy to hear about it.
--
Steve
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c (revision 268106)
+++ gcc/fortran/check.c (working copy)
@@ -4426,6 +4426,59 @@ gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r
bool
+gfc_check_ieee_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
+{
+ gfc_intrinsic_sym *sym;
+
+ sym = gfc_find_function ("ieee_selected_real_kind");
+ if (!sym->ieee)
+ {
+ gfc_warning_now (0, "check: whoops at %C");
+ return false;
+ }
+
+ if (p == NULL && r == NULL
+ && !gfc_notify_std (GFC_STD_F2008, "%qs with neither %<P%> nor %<R%> "
+ "argument at %L", gfc_current_intrinsic,
+ gfc_current_intrinsic_where))
+ return false;
+
+ if (p)
+ {
+ if (!type_check (p, 0, BT_INTEGER))
+ return false;
+
+ if (!scalar_check (p, 0))
+ return false;
+ }
+
+ if (r)
+ {
+ if (!type_check (r, 1, BT_INTEGER))
+ return false;
+
+ if (!scalar_check (r, 1))
+ return false;
+ }
+
+ if (radix)
+ {
+ if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with "
+ "RADIX argument at %L", gfc_current_intrinsic,
+ &radix->where))
+ return false;
+
+ if (!type_check (radix, 1, BT_INTEGER))
+ return false;
+
+ if (!scalar_check (radix, 1))
+ return false;
+ }
+
+ return true;
+}
+
+bool
gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
{
if (!type_check (x, 0, BT_REAL))
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 268106)
+++ gcc/fortran/gfortran.h (working copy)
@@ -592,7 +592,7 @@ enum gfc_isym_id
GFC_ISYM_SPREAD,
GFC_ISYM_SQRT,
GFC_ISYM_SRAND,
- GFC_ISYM_SR_KIND,
+ GFC_ISYM_SR_KIND, GFC_ISYM_IEEE_SR_KIND,
GFC_ISYM_STAT,
GFC_ISYM_STOPPED_IMAGES,
GFC_ISYM_STORAGE_SIZE,
@@ -2071,7 +2071,7 @@ typedef struct gfc_intrinsic_sym
gfc_typespec ts;
unsigned elemental:1, inquiry:1, transformational:1, pure:1,
generic:1, specific:1, actual_ok:1, noreturn:1, conversion:1,
- from_module:1, vararg:1;
+ from_module:1, vararg:1, ieee:1;
int standard;
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c (revision 268106)
+++ gcc/fortran/intrinsic.c (working copy)
@@ -2891,6 +2891,15 @@ add_functions (void)
make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95);
+ add_sym_3 ("ieee_selected_real_kind", GFC_ISYM_IEEE_SR_KIND,
+ CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+ gfc_check_ieee_selected_real_kind,
+ gfc_simplify_ieee_selected_real_kind, NULL,
+ p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL,
+ "radix", BT_INTEGER, di, OPTIONAL);
+
+ make_generic ("ieee_selected_real_kind", GFC_ISYM_IEEE_SR_KIND, GFC_STD_F95);
+
add_sym_2 ("set_exponent", GFC_ISYM_SET_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_set_exponent, gfc_simplify_set_exponent,
gfc_resolve_set_exponent,
Index: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h (revision 268106)
+++ gcc/fortran/intrinsic.h (working copy)
@@ -150,6 +150,8 @@ bool gfc_check_secnds (gfc_expr *);
bool gfc_check_selected_char_kind (gfc_expr *);
bool gfc_check_selected_int_kind (gfc_expr *);
bool gfc_check_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_ieee_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *);
+
bool gfc_check_set_exponent (gfc_expr *, gfc_expr *);
bool gfc_check_shape (gfc_expr *, gfc_expr *);
bool gfc_check_shift (gfc_expr *, gfc_expr *);
@@ -397,6 +399,8 @@ gfc_expr *gfc_simplify_scan (gfc_expr *, gfc_expr *, g
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_expr *gfc_simplify_ieee_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 *, gfc_expr *);
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 268106)
+++ gcc/fortran/module.c (working copy)
@@ -5401,6 +5401,12 @@ read_module (void)
if (u->found)
continue;
+ /* Special case for ieee_selected_real_kind, which doesn't actually
+ appear in module. */
+ if (strcmp(module_name, "ieee_arithmetic") == 0
+ && strcmp(u->use_name, "ieee_selected_real_kind") == 0)
+ continue;
+
if (u->op == INTRINSIC_NONE)
{
gfc_error ("Symbol %qs referenced at %L not found in module %qs",
@@ -7020,7 +7026,13 @@ gfc_use_module (gfc_use_list *module)
&& gfc_notify_std (GFC_STD_F2003,
"IEEE_ARITHMETIC module at %C"))
{
+ gfc_intrinsic_sym *sym;
+
current_intmod = INTMOD_IEEE_ARITHMETIC;
+
+ /* Mark functions in intrinsic function table as ieee. */
+ sym = gfc_find_function ("ieee_selected_real_kind");
+ sym->ieee = 1;
}
}
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (revision 268106)
+++ gcc/fortran/simplify.c (working copy)
@@ -7079,6 +7079,84 @@ gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr
gfc_expr *
+gfc_simplify_ieee_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *rdx)
+{
+ bool saw_p, saw_r, saw_radix;
+ int i, kind, precision, radix, range;
+ locus *loc = &gfc_current_locus;
+ gfc_intrinsic_sym *sym;
+
+ sym = gfc_find_function ("ieee_selected_real_kind");
+ if (!sym->ieee)
+ {
+ gfc_warning (0, "simplify: whoops at %C");
+ return NULL;
+ }
+
+ precision = range = radix = 0;
+
+ if (p)
+ {
+ if (p->expr_type != EXPR_CONSTANT || gfc_extract_int (p, &precision))
+ return NULL;
+ loc = &p->where;
+ }
+
+ if (r)
+ {
+ if (r->expr_type != EXPR_CONSTANT || gfc_extract_int (r, &range))
+ return NULL;
+
+ if (!loc)
+ loc = &r->where;
+ }
+
+ if (rdx)
+ {
+ if (rdx->expr_type != EXPR_CONSTANT || gfc_extract_int (rdx, &radix))
+ return NULL;
+
+ if (!loc)
+ loc = &rdx->where;
+ }
+
+ kind = INT_MAX;
+ saw_p = saw_r = saw_radix = false;
+
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ {
+ if (gfc_real_kinds[i].precision >= precision)
+ saw_p = true;
+
+ if (gfc_real_kinds[i].range >= range)
+ saw_r = true;
+
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
+ saw_radix = true;
+
+ if (saw_p && saw_r && saw_radix && gfc_real_kinds[i].kind < kind)
+ kind = gfc_real_kinds[i].kind;
+ }
+
+ if (kind == INT_MAX)
+ {
+ if (saw_radix && saw_r && !saw_p)
+ kind = -1;
+ else if (saw_radix && saw_p && !saw_r)
+ kind = -2;
+ else if (saw_radix && !saw_p && !saw_r)
+ kind = -3;
+ else if (saw_radix)
+ kind = -4;
+ else
+ kind = -5;
+ }
+
+ return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
+}
+
+
+gfc_expr *
gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
{
gfc_expr *result;
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (revision 268106)
+++ gcc/fortran/trans-intrinsic.c (working copy)
@@ -9521,6 +9521,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * e
break;
case GFC_ISYM_SR_KIND:
+ case GFC_ISYM_IEEE_SR_KIND:
gfc_conv_intrinsic_sr_kind (se, expr);
break;
Index: libgfortran/ieee/ieee_arithmetic.F90
===================================================================
--- libgfortran/ieee/ieee_arithmetic.F90 (revision 268106)
+++ libgfortran/ieee/ieee_arithmetic.F90 (working copy)
@@ -732,7 +732,6 @@ REM_MACRO(4,4,4)
! Public declarations for contained procedures
public :: IEEE_GET_ROUNDING_MODE, IEEE_SET_ROUNDING_MODE
public :: IEEE_GET_UNDERFLOW_MODE, IEEE_SET_UNDERFLOW_MODE
- public :: IEEE_SELECTED_REAL_KIND
! IEEE_SUPPORT_ROUNDING
@@ -830,21 +829,6 @@ contains
implicit none
type(IEEE_ROUND_TYPE), intent(in) :: X, Y
res = (X%hidden /= Y%hidden)
- end function
-
-
- ! IEEE_SELECTED_REAL_KIND
-
- integer function IEEE_SELECTED_REAL_KIND (P, R, RADIX) result(res)
- implicit none
- integer, intent(in), optional :: P, R, RADIX
-
- ! Currently, if IEEE is supported and this module is built, it means
- ! all our floating-point types conform to IEEE. Hence, we simply call
- ! SELECTED_REAL_KIND.
-
- res = SELECTED_REAL_KIND (P, R, RADIX)
-
end function
