re PR fortran/64104 ([F2003][IEEE] Allow IEEE functions in specification expressions)
PR fortran/64104 * expr.c (gfc_check_init_expr): Allow some IEEE functions in constant expressions. (external_spec_function): Allow some IEEE functions in specification expressions. * simplify.c (gfc_simplify_ieee_selected_real_kind): Remove. (simplify_ieee_selected_real_kind, simplify_ieee_support, matches_ieee_function_name, gfc_simplify_ieee_functions): New functions. * gfortran.h (gfc_simplify_ieee_selected_real_kind): Remove prototype. (gfc_simplify_ieee_functions): Add prototype. * gfortran.dg/ieee/ieee_8.f90: New test. From-SVN: r226723
This commit is contained in:
Francois-Xavier Coudert
François-Xavier Coudert
parent
a044d2b1b6
commit
0e360db970
6 changed files with 225 additions and 22 deletions
|
|
@ -1,3 +1,18 @@
|
|||
2015-08-07 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
||||
|
||||
PR fortran/64104
|
||||
* expr.c (gfc_check_init_expr): Allow some IEEE functions in
|
||||
constant expressions.
|
||||
(external_spec_function): Allow some IEEE functions in specification
|
||||
expressions.
|
||||
* simplify.c (gfc_simplify_ieee_selected_real_kind): Remove.
|
||||
(simplify_ieee_selected_real_kind, simplify_ieee_support,
|
||||
matches_ieee_function_name, gfc_simplify_ieee_functions): New
|
||||
functions.
|
||||
* gfortran.h (gfc_simplify_ieee_selected_real_kind): Remove
|
||||
prototype.
|
||||
(gfc_simplify_ieee_functions): Add prototype.
|
||||
|
||||
2015-08-06 Mikael Morin <mikael@gcc.gnu.org>
|
||||
|
||||
* trans.h (gfc_trans_scalar_assign): Remove fourth argument.
|
||||
|
|
|
|||
|
|
@ -2474,13 +2474,14 @@ gfc_check_init_expr (gfc_expr *e)
|
|||
gfc_intrinsic_sym* isym;
|
||||
gfc_symbol* sym = e->symtree->n.sym;
|
||||
|
||||
/* Special case for IEEE_SELECTED_REAL_KIND from the intrinsic
|
||||
module IEEE_ARITHMETIC, which is allowed in initialization
|
||||
expressions. */
|
||||
if (!strcmp(sym->name, "ieee_selected_real_kind")
|
||||
&& sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
|
||||
/* Simplify here the intrinsics from the IEEE_ARITHMETIC and
|
||||
IEEE_EXCEPTIONS modules. */
|
||||
int mod = sym->from_intmod;
|
||||
if (mod == INTMOD_NONE && sym->generic)
|
||||
mod = sym->generic->sym->from_intmod;
|
||||
if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS)
|
||||
{
|
||||
gfc_expr *new_expr = gfc_simplify_ieee_selected_real_kind (e);
|
||||
gfc_expr *new_expr = gfc_simplify_ieee_functions (e);
|
||||
if (new_expr)
|
||||
{
|
||||
gfc_replace_expr (e, new_expr);
|
||||
|
|
@ -2738,6 +2739,29 @@ external_spec_function (gfc_expr *e)
|
|||
|
||||
f = e->value.function.esym;
|
||||
|
||||
/* IEEE functions allowed are "a reference to a transformational function
|
||||
from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
|
||||
"inquiry function from the intrinsic modules IEEE_ARITHMETIC and
|
||||
IEEE_EXCEPTIONS". */
|
||||
if (f->from_intmod == INTMOD_IEEE_ARITHMETIC
|
||||
|| f->from_intmod == INTMOD_IEEE_EXCEPTIONS)
|
||||
{
|
||||
if (!strcmp (f->name, "ieee_selected_real_kind")
|
||||
|| !strcmp (f->name, "ieee_support_rounding")
|
||||
|| !strcmp (f->name, "ieee_support_flag")
|
||||
|| !strcmp (f->name, "ieee_support_halting")
|
||||
|| !strcmp (f->name, "ieee_support_datatype")
|
||||
|| !strcmp (f->name, "ieee_support_denormal")
|
||||
|| !strcmp (f->name, "ieee_support_divide")
|
||||
|| !strcmp (f->name, "ieee_support_inf")
|
||||
|| !strcmp (f->name, "ieee_support_io")
|
||||
|| !strcmp (f->name, "ieee_support_nan")
|
||||
|| !strcmp (f->name, "ieee_support_sqrt")
|
||||
|| !strcmp (f->name, "ieee_support_standard")
|
||||
|| !strcmp (f->name, "ieee_support_underflow_control"))
|
||||
goto function_allowed;
|
||||
}
|
||||
|
||||
if (f->attr.proc == PROC_ST_FUNCTION)
|
||||
{
|
||||
gfc_error ("Specification function %qs at %L cannot be a statement "
|
||||
|
|
@ -2766,6 +2790,7 @@ external_spec_function (gfc_expr *e)
|
|||
return false;
|
||||
}
|
||||
|
||||
function_allowed:
|
||||
return restricted_args (e->value.function.actual);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -2881,8 +2881,6 @@ gfc_formal_arglist *gfc_sym_get_dummy_args (gfc_symbol *);
|
|||
/* intrinsic.c -- true if working in an init-expr, false otherwise. */
|
||||
extern bool gfc_init_expr_flag;
|
||||
|
||||
gfc_expr *gfc_simplify_ieee_selected_real_kind (gfc_expr *);
|
||||
|
||||
/* Given a symbol that we have decided is intrinsic, mark it as such
|
||||
by placing it into a special module that is otherwise impossible to
|
||||
read or write. */
|
||||
|
|
@ -3245,6 +3243,7 @@ int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *);
|
|||
/* simplify.c */
|
||||
|
||||
void gfc_convert_mpz_to_signed (mpz_t, int);
|
||||
gfc_expr *gfc_simplify_ieee_functions (gfc_expr *);
|
||||
|
||||
/* trans-array.c */
|
||||
|
||||
|
|
|
|||
|
|
@ -5552,20 +5552,6 @@ gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
|
|||
}
|
||||
|
||||
|
||||
gfc_expr *
|
||||
gfc_simplify_ieee_selected_real_kind (gfc_expr *expr)
|
||||
{
|
||||
gfc_actual_arglist *arg = expr->value.function.actual;
|
||||
gfc_expr *p = arg->expr, *q = arg->next->expr,
|
||||
*rdx = arg->next->next->expr;
|
||||
|
||||
/* Currently, if IEEE is supported and this module is built, it means
|
||||
all our floating-point types conform to IEEE. Hence, we simply handle
|
||||
IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
|
||||
return gfc_simplify_selected_real_kind (p, q, rdx);
|
||||
}
|
||||
|
||||
|
||||
gfc_expr *
|
||||
gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
|
||||
{
|
||||
|
|
@ -6955,3 +6941,62 @@ gfc_simplify_compiler_version (void)
|
|||
return gfc_get_character_expr (gfc_default_character_kind,
|
||||
&gfc_current_locus, buffer, len);
|
||||
}
|
||||
|
||||
/* Simplification routines for intrinsics of IEEE modules. */
|
||||
|
||||
gfc_expr *
|
||||
simplify_ieee_selected_real_kind (gfc_expr *expr)
|
||||
{
|
||||
gfc_actual_arglist *arg = expr->value.function.actual;
|
||||
gfc_expr *p = arg->expr, *q = arg->next->expr,
|
||||
*rdx = arg->next->next->expr;
|
||||
|
||||
/* Currently, if IEEE is supported and this module is built, it means
|
||||
all our floating-point types conform to IEEE. Hence, we simply handle
|
||||
IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
|
||||
return gfc_simplify_selected_real_kind (p, q, rdx);
|
||||
}
|
||||
|
||||
gfc_expr *
|
||||
simplify_ieee_support (gfc_expr *expr)
|
||||
{
|
||||
/* We consider that if the IEEE modules are loaded, we have full support
|
||||
for flags, halting and rounding, which are the three functions
|
||||
(IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
|
||||
expressions. One day, we will need libgfortran to detect support and
|
||||
communicate it back to us, allowing for partial support. */
|
||||
|
||||
return gfc_get_logical_expr (gfc_default_logical_kind, &expr->where,
|
||||
true);
|
||||
}
|
||||
|
||||
bool
|
||||
matches_ieee_function_name (gfc_symbol *sym, const char *name)
|
||||
{
|
||||
int n = strlen(name);
|
||||
|
||||
if (!strncmp(sym->name, name, n))
|
||||
return true;
|
||||
|
||||
/* If a generic was used and renamed, we need more work to find out.
|
||||
Compare the specific name. */
|
||||
if (sym->generic && !strncmp(sym->generic->sym->name, name, n))
|
||||
return true;
|
||||
|
||||
return false;
|
||||
}
|
||||
|
||||
gfc_expr *
|
||||
gfc_simplify_ieee_functions (gfc_expr *expr)
|
||||
{
|
||||
gfc_symbol* sym = expr->symtree->n.sym;
|
||||
|
||||
if (matches_ieee_function_name(sym, "ieee_selected_real_kind"))
|
||||
return simplify_ieee_selected_real_kind (expr);
|
||||
else if (matches_ieee_function_name(sym, "ieee_support_flag")
|
||||
|| matches_ieee_function_name(sym, "ieee_support_halting")
|
||||
|| matches_ieee_function_name(sym, "ieee_support_rounding"))
|
||||
return simplify_ieee_support (expr);
|
||||
else
|
||||
return NULL;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
2015-08-07 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
||||
|
||||
PR fortran/64104
|
||||
* gfortran.dg/ieee/ieee_8.f90: New test.
|
||||
|
||||
2015-08-07 Jiong Wang <jiong.wang@arm.com>
|
||||
|
||||
* gcc.target/aarch64/noplt_1.c: Check branch type instead of relocation
|
||||
|
|
|
|||
114
gcc/testsuite/gfortran.dg/ieee/ieee_8.f90
Normal file
114
gcc/testsuite/gfortran.dg/ieee/ieee_8.f90
Normal file
|
|
@ -0,0 +1,114 @@
|
|||
! { dg-do run }
|
||||
|
||||
module foo
|
||||
use :: ieee_exceptions
|
||||
use :: ieee_arithmetic
|
||||
end module foo
|
||||
|
||||
module bar
|
||||
use foo
|
||||
use :: ieee_arithmetic, yyy => ieee_support_rounding
|
||||
use :: ieee_arithmetic, zzz => ieee_selected_real_kind
|
||||
end module
|
||||
|
||||
program test
|
||||
use :: bar
|
||||
use :: ieee_arithmetic, xxx => ieee_support_rounding
|
||||
implicit none
|
||||
|
||||
! IEEE functions allowed in constant expressions
|
||||
|
||||
integer, parameter :: n1 = ieee_selected_real_kind(0, 0)
|
||||
logical, parameter :: l1 = ieee_support_halting(ieee_overflow)
|
||||
logical, parameter :: l2 = ieee_support_flag(ieee_overflow)
|
||||
logical, parameter :: l3 = ieee_support_flag(ieee_overflow, 0.)
|
||||
logical, parameter :: l4 = ieee_support_rounding(ieee_to_zero)
|
||||
logical, parameter :: l5 = ieee_support_rounding(ieee_to_zero, 0.d0)
|
||||
|
||||
logical, parameter :: l6 = xxx(ieee_to_zero, 0.d0)
|
||||
logical, parameter :: l7 = yyy(ieee_to_zero, 0.d0)
|
||||
integer, parameter :: n2 = zzz(0, 0)
|
||||
|
||||
call gee(8, ieee_to_zero, ieee_overflow)
|
||||
|
||||
end
|
||||
|
||||
! IEEE functions allowed in specification expressions
|
||||
|
||||
subroutine gee(n, rounding, flag)
|
||||
use :: bar
|
||||
implicit none
|
||||
|
||||
integer :: n
|
||||
type(ieee_round_type) :: rounding
|
||||
type(ieee_flag_type) :: flag
|
||||
|
||||
character(len=ieee_selected_real_kind(n)) :: s1
|
||||
character(len=ieee_selected_real_kind(n,2*n)) :: s2
|
||||
character(len=ieee_selected_real_kind(n,2*n,2)) :: s3
|
||||
|
||||
character(len=merge(4,2,ieee_support_rounding(rounding))) :: s4
|
||||
character(len=merge(4,2,ieee_support_rounding(rounding, 0.d0))) :: s5
|
||||
|
||||
character(len=merge(4,2,ieee_support_flag(flag))) :: s6
|
||||
character(len=merge(4,2,ieee_support_flag(flag, 0.))) :: s7
|
||||
|
||||
character(len=merge(4,2,ieee_support_halting(flag))) :: s8
|
||||
|
||||
character(len=merge(4,2,ieee_support_datatype())) :: s9
|
||||
character(len=merge(4,2,ieee_support_datatype(0.))) :: s10
|
||||
|
||||
character(len=merge(4,2,ieee_support_denormal())) :: s11
|
||||
character(len=merge(4,2,ieee_support_denormal(0.))) :: s12
|
||||
|
||||
character(len=merge(4,2,ieee_support_divide())) :: s13
|
||||
character(len=merge(4,2,ieee_support_divide(0.))) :: s14
|
||||
|
||||
character(len=merge(4,2,ieee_support_inf())) :: s15
|
||||
character(len=merge(4,2,ieee_support_inf(0.))) :: s16
|
||||
|
||||
character(len=merge(4,2,ieee_support_io())) :: s17
|
||||
character(len=merge(4,2,ieee_support_io(0.))) :: s18
|
||||
|
||||
character(len=merge(4,2,ieee_support_nan())) :: s19
|
||||
character(len=merge(4,2,ieee_support_nan(0.))) :: s20
|
||||
|
||||
character(len=merge(4,2,ieee_support_sqrt())) :: s21
|
||||
character(len=merge(4,2,ieee_support_sqrt(0.))) :: s22
|
||||
|
||||
character(len=merge(4,2,ieee_support_standard())) :: s23
|
||||
character(len=merge(4,2,ieee_support_standard(0.))) :: s24
|
||||
|
||||
character(len=merge(4,2,ieee_support_underflow_control())) :: s25
|
||||
character(len=merge(4,2,ieee_support_underflow_control(0.))) :: s26
|
||||
|
||||
! Now, check that runtime values match compile-time constants
|
||||
! (for those that are allowed)
|
||||
|
||||
integer, parameter :: x1 = ieee_selected_real_kind(8)
|
||||
integer, parameter :: x2 = ieee_selected_real_kind(8,2*8)
|
||||
integer, parameter :: x3 = ieee_selected_real_kind(8,2*8,2)
|
||||
|
||||
integer, parameter :: x4 = merge(4,2,ieee_support_rounding(rounding))
|
||||
integer, parameter :: x5 = merge(4,2,ieee_support_rounding(rounding, 0.d0))
|
||||
|
||||
integer, parameter :: x6 = merge(4,2,ieee_support_flag(ieee_overflow))
|
||||
integer, parameter :: x7 = merge(4,2,ieee_support_flag(ieee_overflow, 0.))
|
||||
|
||||
integer, parameter :: x8 = merge(4,2,ieee_support_halting(ieee_overflow))
|
||||
|
||||
if (len(s1) /= x1) call abort
|
||||
if (len(s2) /= x2) call abort
|
||||
if (len(s3) /= x3) call abort
|
||||
|
||||
if (len(s4) /= x4) call abort
|
||||
if (len(s5) /= x5) call abort
|
||||
|
||||
if (len(s6) /= x6) call abort
|
||||
if (len(s7) /= x7) call abort
|
||||
|
||||
if (len(s8) /= x8) call abort
|
||||
|
||||
end subroutine
|
||||
|
||||
! { dg-final { cleanup-modules "foo bar" } }
|
||||
Loading…
Add table
Reference in a new issue