+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.
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);
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 "
return false;
}
+function_allowed:
return restricted_args (e->value.function.actual);
}
/* 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. */
/* simplify.c */
void gfc_convert_mpz_to_signed (mpz_t, int);
+gfc_expr *gfc_simplify_ieee_functions (gfc_expr *);
/* trans-array.c */
}
-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)
{
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;
+}
+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
--- /dev/null
+! { 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" } }
projects / gcc.git / commitdiff