aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog197
-rw-r--r--gcc/fortran/check.cc186
-rw-r--r--gcc/fortran/data.cc8
-rw-r--r--gcc/fortran/error.cc3
-rw-r--r--gcc/fortran/expr.cc110
-rw-r--r--gcc/fortran/f95-lang.cc3
-rw-r--r--gcc/fortran/gfortran.h14
-rw-r--r--gcc/fortran/interface.cc9
-rw-r--r--gcc/fortran/intrinsic.cc93
-rw-r--r--gcc/fortran/intrinsic.h11
-rw-r--r--gcc/fortran/intrinsic.texi550
-rw-r--r--gcc/fortran/io.cc6
-rw-r--r--gcc/fortran/iresolve.cc8
-rw-r--r--gcc/fortran/mathbuiltins.def63
-rw-r--r--gcc/fortran/misc.cc3
-rw-r--r--gcc/fortran/options.cc4
-rw-r--r--gcc/fortran/parse.cc3
-rw-r--r--gcc/fortran/primary.cc64
-rw-r--r--gcc/fortran/resolve.cc25
-rw-r--r--gcc/fortran/simplify.cc264
-rw-r--r--gcc/fortran/trans-array.cc12
-rw-r--r--gcc/fortran/trans-expr.cc26
-rw-r--r--gcc/fortran/trans-openmp.cc20
-rw-r--r--gcc/fortran/trans-types.cc5
24 files changed, 1455 insertions, 232 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8b82b20..9a5ffb9 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,200 @@
+2025-06-19 Mikael Morin <mikael@gcc.gnu.org>
+
+ PR fortran/120713
+ * trans-array.cc (gfc_trans_deferred_array): Statically
+ initialize deferred length variable for SAVEd character arrays.
+
+2025-06-18 Harald Anlauf <anlauf@gmx.de>
+
+ PR fortran/82480
+ * check.cc (gfc_check_fstat): Extend checks to INTENT(OUT) arguments.
+ (gfc_check_fstat_sub): Likewise.
+ (gfc_check_stat): Likewise.
+ (gfc_check_stat_sub): Likewise.
+ * intrinsic.texi: Adjust documentation.
+
+2025-06-16 Harald Anlauf <anlauf@gmx.de>
+
+ PR fortran/51961
+ * resolve.cc (conformable_arrays): Use modified rank check when
+ MOLD= expression is given.
+
+2025-06-12 Yuao Ma <c8ef@outlook.com>
+ Steven G. Kargl <kargl@gcc.gnu.org>
+
+ PR fortran/113152
+ * intrinsic.texi: Document new half-revolution trigonometric
+ functions. Reorder doc for atand.
+
+2025-06-06 Tobias Burnus <tburnus@baylibre.com>
+ Sandra Loosemore <sloosemore@baylibre.com>
+
+ * f95-lang.cc (ATTR_PURE_NOTHROW_LIST): Define.
+ * trans-expr.cc (get_builtin_fn): Handle omp_get_num_devices
+ and omp_get_intrinsic_device.
+ * gfortran.h (gfc_option_t): Add disable_omp_... for them.
+ * options.cc (gfc_handle_option): Handle them with
+ -fno-builtin-.
+
+2025-06-04 Andre Vehreschild <vehre@gcc.gnu.org>
+
+ PR fortran/120483
+ * trans-expr.cc (gfc_conv_substring): Use pointer arithmetic on
+ static allocatable char arrays.
+
+2025-06-03 Harald Anlauf <anlauf@gmx.de>
+
+ PR fortran/99838
+ * data.cc (gfc_assign_data_value): For a new initializer use the
+ location from the constructor as fallback.
+
+2025-05-30 Harald Anlauf <anlauf@gmx.de>
+
+ PR fortran/102599
+ PR fortran/114022
+ * expr.cc (simplify_complex_array_inquiry_ref): Helper function for
+ simplification of inquiry references (%re/%im) of constant complex
+ arrays.
+ (find_inquiry_ref): Use it for handling %re/%im inquiry references
+ of complex arrays.
+ (scalarize_intrinsic_call): Fix frontend memleak.
+ * primary.cc (gfc_match_varspec): When the reference is NULL, the
+ previous simplification has succeeded in evaluating inquiry
+ references also of arrays.
+
+2025-05-30 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/120355
+ * interface.cc (compare_parameter): If the global function has a
+ result clause, take typespec from there for the comparison against
+ the dummy argument.
+
+2025-05-30 Julian Brown <julian@codesourcery.com>
+ Tobias Burnus <tburnus@baylibre.com>
+
+ * parse.cc (tree.h, fold-const.h, tree-hash-traits.h): Add includes
+ (for additions to omp-general.h).
+
+2025-05-29 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ PR fortran/120049
+ * check.cc(check_c_ptr_2): Rephrase error message
+ for clarity.
+
+2025-05-28 Tobias Burnus <tburnus@baylibre.com>
+
+ PR fortran/113152
+ * simplify.cc (gfc_simplify_cospi, gfc_simplify_sinpi): Avoid using
+ mpfr_fmod_ui in the MPFR < 4.2.0 version.
+
+2025-05-28 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ PR fortran/119856
+ * io.cc: Set missing comma error checks to STD_STD_LEGACY.
+
+2025-05-28 Yuao Ma <c8ef@outlook.com>
+ Steven G. Kargl <kargl@gcc.gnu.org>
+
+ PR fortran/113152
+ * gfortran.h (enum gfc_isym_id): Add new enum.
+ * intrinsic.cc (add_functions): Register new intrinsics. Changing the call
+ from gfc_resolve_trigd{,2} to gfc_resolve_trig{,2}.
+ * intrinsic.h (gfc_simplify_acospi, gfc_simplify_asinpi,
+ gfc_simplify_asinpi, gfc_simplify_atanpi, gfc_simplify_atan2pi,
+ gfc_simplify_cospi, gfc_simplify_sinpi, gfc_simplify_tanpi): New.
+ (gfc_resolve_trig): Rename from gfc_resolve_trigd.
+ (gfc_resolve_trig2): Rename from gfc_resolve_trigd2.
+ * iresolve.cc (gfc_resolve_trig): Rename from gfc_resolve_trigd.
+ (gfc_resolve_trig2): Rename from gfc_resolve_trigd2.
+ * mathbuiltins.def: Add 7 new math builtins and re-align.
+ * simplify.cc (gfc_simplify_acos, gfc_simplify_asin,
+ gfc_simplify_acosd, gfc_simplify_asind): Revise error message.
+ (gfc_simplify_acospi, gfc_simplify_asinpi,
+ gfc_simplify_asinpi, gfc_simplify_atanpi, gfc_simplify_atan2pi,
+ gfc_simplify_cospi, gfc_simplify_sinpi, gfc_simplify_tanpi): New.
+
+2025-05-27 Harald Anlauf <anlauf@gmx.de>
+
+ PR fortran/101735
+ * primary.cc (gfc_match_varspec): Correct order of logic.
+
+2025-05-27 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ PR fortran/120049
+ * check.cc (gfc_check_c_associated): Use new helper functions.
+ Only call check_c_ptr_1 if optional c_ptr_2 tests succeed.
+ (check_c_ptr_1): Handle only c_ptr_1 checks.
+ (check_c_ptr_2): Expand checks for c_ptr_2 and handle cases
+ where there is no derived pointer in the gfc_expr and check
+ the inmod_sym_id only if it exists.
+ * misc.cc (gfc_typename): Handle the case for BT_VOID rather
+ than throw an internal error.
+
+2025-05-27 Harald Anlauf <anlauf@gmx.de>
+
+ PR fortran/101735
+ * expr.cc (find_inquiry_ref): If an inquiry reference applies to
+ a substring, use that, and calculate substring length if needed.
+ * primary.cc (extend_ref): Also handle attaching to end of
+ reference chain for appending.
+ (gfc_match_varspec): Discrimate between arrays of character and
+ substrings of them. If a substring is taken from a character
+ component of a derived type, get the proper typespec so that
+ inquiry references work correctly.
+ (gfc_match_rvalue): Handle corner case where we hit a seemingly
+ dangling '%' and missed an inquiry reference. Try another match.
+
+2025-05-27 David Malcolm <dmalcolm@redhat.com>
+
+ PR other/116792
+ * error.cc (gfc_diagnostic_start_span): Update for diagnostic.h
+ changes.
+
+2025-05-19 Harald Anlauf <anlauf@gmx.de>
+
+ PR fortran/120099
+ * trans-types.cc (gfc_return_by_reference): Intrinsic functions
+ returning complex numbers may return their result by reference
+ with -ff2c.
+
+2025-05-15 Harald Anlauf <anlauf@gmx.de>
+
+ PR fortran/85750
+ * resolve.cc (resolve_symbol): Reorder conditions when to apply
+ default-initializers.
+
+2025-05-15 Tobias Burnus <tburnus@baylibre.com>
+
+ * trans-openmp.cc (gfc_omp_deep_mapping_do): Handle SSA_NAME if
+ a def_stmt is available.
+
+2025-05-14 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/120139
+ * dump-parse-tree.cc (get_c_type_name): If no constant
+ size of an array exists, output an asterisk.
+
+2025-05-14 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/120107
+ * dump-parse-tree.cc (write_type): Do not dump non-interoperable
+ types.
+
+2025-05-14 Tobias Burnus <tburnus@baylibre.com>
+
+ PR fortran/120225
+ * simplify.cc (gfc_simplify_cotand): Fix used argument in
+ mpfr_tanu call.
+
+2025-05-14 Tobias Burnus <tburnus@baylibre.com>
+
+ PR fortran/120225
+ * simplify.cc: Include "trigd_fe.inc" only with MPFR < 4.2.0.
+ (rad2deg, rad2deg): Only define if MPFR < 4.2.0.
+ (gfc_simplify_acosd, gfc_simplify_asind, gfc_simplify_atand,
+ gfc_simplify_atan2d, gfc_simplify_cosd, gfc_simplify_tand,
+ gfc_simplify_cotand): Use mpfr_...u functions with MPFR >= 4.2.0.
+
2025-05-13 Yuao Ma <c8ef@outlook.com>
Steven G. Kargl <kargl@gcc.gnu.org>
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index f02a2a3..838d523 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -5952,49 +5952,110 @@ gfc_check_c_sizeof (gfc_expr *arg)
}
-bool
-gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
+/* Helper functions check_c_ptr_1 and check_c_ptr_2
+ used in gfc_check_c_associated. */
+
+static inline
+bool check_c_ptr_1 (gfc_expr *c_ptr_1)
{
- if (c_ptr_1)
- {
- if (c_ptr_1->expr_type == EXPR_FUNCTION && c_ptr_1->ts.type == BT_VOID)
- return true;
+ if ((c_ptr_1->ts.type == BT_VOID)
+ && (c_ptr_1->expr_type == EXPR_FUNCTION))
+ return true;
- if (c_ptr_1->ts.type != BT_DERIVED
- || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
- || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
- && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
- {
- gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
- "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
- return false;
- }
- }
+ if (c_ptr_1->ts.type != BT_DERIVED
+ || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
+ || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
+ && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
+ goto check_1_error;
+
+ if ((c_ptr_1->ts.type == BT_DERIVED)
+ && (c_ptr_1->expr_type == EXPR_STRUCTURE)
+ && (c_ptr_1->ts.u.derived->intmod_sym_id
+ == ISOCBINDING_NULL_FUNPTR))
+ goto check_1_error;
- if (!scalar_check (c_ptr_1, 0))
+ if (scalar_check (c_ptr_1, 0))
+ return true;
+ else
+ /* Return since the check_1_error message may not apply here. */
return false;
- if (c_ptr_2)
- {
- if (c_ptr_2->expr_type == EXPR_FUNCTION && c_ptr_2->ts.type == BT_VOID)
- return true;
+check_1_error:
- if (c_ptr_2->ts.type != BT_DERIVED
- || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
- || (c_ptr_1->ts.u.derived->intmod_sym_id
- != c_ptr_2->ts.u.derived->intmod_sym_id))
+ gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
+ "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
+ return false;
+}
+
+static inline
+bool check_c_ptr_2 (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
+{
+ switch (c_ptr_2->ts.type)
+ {
+ case BT_VOID:
+ if (c_ptr_2->expr_type == EXPR_FUNCTION)
{
- gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
- "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where,
- gfc_typename (&c_ptr_1->ts), gfc_typename (&c_ptr_2->ts));
- return false;
+ if ((c_ptr_1->ts.type == BT_DERIVED)
+ && c_ptr_1->expr_type == EXPR_STRUCTURE
+ && (c_ptr_1->ts.u.derived->intmod_sym_id
+ == ISOCBINDING_FUNPTR))
+ goto check_2_error;
}
- }
+ break;
+
+ case BT_DERIVED:
+ if ((c_ptr_2->expr_type == EXPR_STRUCTURE)
+ && (c_ptr_2->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR)
+ && (c_ptr_1->ts.type == BT_VOID)
+ && (c_ptr_1->expr_type == EXPR_FUNCTION))
+ return scalar_check (c_ptr_2, 1);
+
+ if ((c_ptr_2->expr_type == EXPR_STRUCTURE)
+ && (c_ptr_1->ts.type == BT_VOID)
+ && (c_ptr_1->expr_type == EXPR_FUNCTION))
+ goto check_2_error;
+
+ if (c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING)
+ goto check_2_error;
+
+ if (c_ptr_1->ts.type == BT_DERIVED
+ && (c_ptr_1->ts.u.derived->intmod_sym_id
+ != c_ptr_2->ts.u.derived->intmod_sym_id))
+ goto check_2_error;
+ break;
+
+ default:
+ goto check_2_error;
+ }
- if (c_ptr_2 && !scalar_check (c_ptr_2, 1))
+ if (scalar_check (c_ptr_2, 1))
+ return true;
+ else
+ /* Return since the check_2_error message may not apply here. */
return false;
- return true;
+check_2_error:
+
+ gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
+ "same type as C_PTR_1, found %s instead of %s", &c_ptr_2->where,
+ gfc_typename (&c_ptr_2->ts), gfc_typename (&c_ptr_1->ts));
+
+ return false;
+ }
+
+
+bool
+gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
+{
+ if (c_ptr_2)
+ {
+ if (check_c_ptr_2 (c_ptr_1, c_ptr_2))
+ return check_c_ptr_1 (c_ptr_1);
+ else
+ return false;
+ }
+ else
+ return check_c_ptr_1 (c_ptr_1);
}
@@ -6446,7 +6507,7 @@ gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_exp
bool
-gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
+gfc_check_fstat (gfc_expr *unit, gfc_expr *values)
{
if (!type_check (unit, 0, BT_INTEGER))
return false;
@@ -6454,11 +6515,17 @@ gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
if (!scalar_check (unit, 0))
return false;
- if (!type_check (array, 1, BT_INTEGER)
+ if (!type_check (values, 1, BT_INTEGER)
|| !kind_value_check (unit, 0, gfc_default_integer_kind))
return false;
- if (!array_check (array, 1))
+ if (!array_check (values, 1))
+ return false;
+
+ if (!variable_check (values, 1, false))
+ return false;
+
+ if (!array_size_check (values, 1, 13))
return false;
return true;
@@ -6466,19 +6533,9 @@ gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
bool
-gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
+gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *values, gfc_expr *status)
{
- if (!type_check (unit, 0, BT_INTEGER))
- return false;
-
- if (!scalar_check (unit, 0))
- return false;
-
- if (!type_check (array, 1, BT_INTEGER)
- || !kind_value_check (array, 1, gfc_default_integer_kind))
- return false;
-
- if (!array_check (array, 1))
+ if (!gfc_check_fstat (unit, values))
return false;
if (status == NULL)
@@ -6491,6 +6548,9 @@ gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
if (!scalar_check (status, 2))
return false;
+ if (!variable_check (status, 2, false))
+ return false;
+
return true;
}
@@ -6528,18 +6588,24 @@ gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
bool
-gfc_check_stat (gfc_expr *name, gfc_expr *array)
+gfc_check_stat (gfc_expr *name, gfc_expr *values)
{
if (!type_check (name, 0, BT_CHARACTER))
return false;
if (!kind_value_check (name, 0, gfc_default_character_kind))
return false;
- if (!type_check (array, 1, BT_INTEGER)
- || !kind_value_check (array, 1, gfc_default_integer_kind))
+ if (!type_check (values, 1, BT_INTEGER)
+ || !kind_value_check (values, 1, gfc_default_integer_kind))
+ return false;
+
+ if (!array_check (values, 1))
+ return false;
+
+ if (!variable_check (values, 1, false))
return false;
- if (!array_check (array, 1))
+ if (!array_size_check (values, 1, 13))
return false;
return true;
@@ -6547,30 +6613,24 @@ gfc_check_stat (gfc_expr *name, gfc_expr *array)
bool
-gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
+gfc_check_stat_sub (gfc_expr *name, gfc_expr *values, gfc_expr *status)
{
- if (!type_check (name, 0, BT_CHARACTER))
- return false;
- if (!kind_value_check (name, 0, gfc_default_character_kind))
- return false;
-
- if (!type_check (array, 1, BT_INTEGER)
- || !kind_value_check (array, 1, gfc_default_integer_kind))
- return false;
-
- if (!array_check (array, 1))
+ if (!gfc_check_stat (name, values))
return false;
if (status == NULL)
return true;
if (!type_check (status, 2, BT_INTEGER)
- || !kind_value_check (array, 1, gfc_default_integer_kind))
+ || !kind_value_check (status, 2, gfc_default_integer_kind))
return false;
if (!scalar_check (status, 2))
return false;
+ if (!variable_check (status, 2, false))
+ return false;
+
return true;
}
diff --git a/gcc/fortran/data.cc b/gcc/fortran/data.cc
index 5c83f69..a438c26 100644
--- a/gcc/fortran/data.cc
+++ b/gcc/fortran/data.cc
@@ -593,7 +593,13 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
{
/* Point the container at the new expression. */
if (last_con == NULL)
- symbol->value = expr;
+ {
+ symbol->value = expr;
+ /* For a new initializer use the location from the
+ constructor as fallback. */
+ if (!GFC_LOCUS_IS_SET(expr->where) && con != NULL)
+ symbol->value->where = con->where;
+ }
else
last_con->expr = expr;
}
diff --git a/gcc/fortran/error.cc b/gcc/fortran/error.cc
index f89d41d..004a4b2 100644
--- a/gcc/fortran/error.cc
+++ b/gcc/fortran/error.cc
@@ -618,9 +618,10 @@ gfc_diagnostic_text_starter (diagnostic_text_output_format &text_output,
static void
gfc_diagnostic_start_span (const diagnostic_location_print_policy &loc_policy,
- pretty_printer *pp,
+ to_text &sink,
expanded_location exploc)
{
+ pretty_printer *pp = get_printer (sink);
const bool colorize = pp_show_color (pp);
char *locus_prefix
= gfc_diagnostic_build_locus_prefix (loc_policy, exploc, colorize);
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 92a9ebd..b0495b7 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -1838,6 +1838,55 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp)
}
+/* Simplify inquiry references (%re/%im) of constant complex arrays.
+ Used by find_inquiry_ref. */
+
+static gfc_expr *
+simplify_complex_array_inquiry_ref (gfc_expr *p, inquiry_type inquiry)
+{
+ gfc_expr *e, *r, *result;
+ gfc_constructor_base base;
+ gfc_constructor *c;
+
+ if ((inquiry != INQUIRY_RE && inquiry != INQUIRY_IM)
+ || p->expr_type != EXPR_ARRAY
+ || p->ts.type != BT_COMPLEX
+ || p->rank <= 0
+ || p->value.constructor == NULL
+ || !gfc_is_constant_array_expr (p))
+ return NULL;
+
+ /* Simplify array sections. */
+ gfc_simplify_expr (p, 0);
+
+ result = gfc_get_array_expr (BT_REAL, p->ts.kind, &p->where);
+ result->rank = p->rank;
+ result->shape = gfc_copy_shape (p->shape, p->rank);
+
+ base = p->value.constructor;
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+ {
+ e = c->expr;
+ if (e->expr_type != EXPR_CONSTANT)
+ goto fail;
+
+ r = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+ if (inquiry == INQUIRY_RE)
+ mpfr_set (r->value.real, mpc_realref (e->value.complex), GFC_RND_MODE);
+ else
+ mpfr_set (r->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
+
+ gfc_constructor_append_expr (&result->value.constructor, r, &e->where);
+ }
+
+ return result;
+
+fail:
+ gfc_free_expr (result);
+ return NULL;
+}
+
+
/* Pull an inquiry result out of an expression. */
static bool
@@ -1846,7 +1895,9 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
gfc_ref *ref;
gfc_ref *inquiry = NULL;
gfc_ref *inquiry_head;
+ gfc_ref *ref_ss = NULL;
gfc_expr *tmp;
+ bool nofail = false;
tmp = gfc_copy_expr (p);
@@ -1862,6 +1913,9 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
{
inquiry = ref->next;
ref->next = NULL;
+ if (ref->type == REF_SUBSTRING)
+ ref_ss = ref;
+ break;
}
}
@@ -1891,6 +1945,28 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
goto cleanup;
+ /* Inquire length of substring? */
+ if (ref_ss)
+ {
+ if (ref_ss->u.ss.start->expr_type == EXPR_CONSTANT
+ && ref_ss->u.ss.end->expr_type == EXPR_CONSTANT)
+ {
+ HOST_WIDE_INT istart, iend, length;
+ istart = gfc_mpz_get_hwi (ref_ss->u.ss.start->value.integer);
+ iend = gfc_mpz_get_hwi (ref_ss->u.ss.end->value.integer);
+
+ if (istart <= iend)
+ length = iend - istart + 1;
+ else
+ length = 0;
+ *newp = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, length);
+ break;
+ }
+ else
+ goto cleanup;
+ }
+
if (tmp->ts.u.cl->length
&& tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT)
*newp = gfc_copy_expr (tmp->ts.u.cl->length);
@@ -1921,24 +1997,50 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
break;
case INQUIRY_RE:
- if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT)
+ if (tmp->ts.type != BT_COMPLEX)
goto cleanup;
if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C"))
goto cleanup;
+ if (tmp->expr_type == EXPR_ARRAY)
+ {
+ *newp = simplify_complex_array_inquiry_ref (tmp, INQUIRY_RE);
+ if (*newp != NULL)
+ {
+ nofail = true;
+ break;
+ }
+ }
+
+ if (tmp->expr_type != EXPR_CONSTANT)
+ goto cleanup;
+
*newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
mpfr_set ((*newp)->value.real,
mpc_realref (tmp->value.complex), GFC_RND_MODE);
break;
case INQUIRY_IM:
- if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT)
+ if (tmp->ts.type != BT_COMPLEX)
goto cleanup;
if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C"))
goto cleanup;
+ if (tmp->expr_type == EXPR_ARRAY)
+ {
+ *newp = simplify_complex_array_inquiry_ref (tmp, INQUIRY_IM);
+ if (*newp != NULL)
+ {
+ nofail = true;
+ break;
+ }
+ }
+
+ if (tmp->expr_type != EXPR_CONSTANT)
+ goto cleanup;
+
*newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
mpfr_set ((*newp)->value.real,
mpc_imagref (tmp->value.complex), GFC_RND_MODE);
@@ -1951,7 +2053,7 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
if (!(*newp))
goto cleanup;
- else if ((*newp)->expr_type != EXPR_CONSTANT)
+ else if ((*newp)->expr_type != EXPR_CONSTANT && !nofail)
{
gfc_free_expr (*newp);
goto cleanup;
@@ -2523,7 +2625,7 @@ scalarize_intrinsic_call (gfc_expr *e, bool init_flag)
rank[n] = a->expr->rank;
else
rank[n] = 1;
- ctor = gfc_constructor_copy (a->expr->value.constructor);
+ ctor = a->expr->value.constructor;
args[n] = gfc_constructor_first (ctor);
}
else
diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc
index 1f09553..bb4ce6d 100644
--- a/gcc/fortran/f95-lang.cc
+++ b/gcc/fortran/f95-lang.cc
@@ -564,7 +564,7 @@ gfc_builtin_function (tree decl)
return decl;
}
-/* So far we need just these 10 attribute types. */
+/* So far we need just these 12 attribute types. */
#define ATTR_NULL 0
#define ATTR_LEAF_LIST (ECF_LEAF)
#define ATTR_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF)
@@ -580,6 +580,7 @@ gfc_builtin_function (tree decl)
#define ATTR_COLD_NORETURN_NOTHROW_LEAF_LIST \
(ECF_COLD | ECF_NORETURN | \
ECF_NOTHROW | ECF_LEAF)
+#define ATTR_PURE_NOTHROW_LIST (ECF_PURE | ECF_NOTHROW)
static void
gfc_define_builtin (const char *name, tree type, enum built_in_function code,
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 4740c36..f73b5f9 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -721,6 +721,14 @@ enum gfc_isym_id
remains compatible. */
GFC_ISYM_SU_KIND,
GFC_ISYM_UINT,
+
+ GFC_ISYM_ACOSPI,
+ GFC_ISYM_ASINPI,
+ GFC_ISYM_ATANPI,
+ GFC_ISYM_ATAN2PI,
+ GFC_ISYM_COSPI,
+ GFC_ISYM_SINPI,
+ GFC_ISYM_TANPI,
};
enum init_local_logical
@@ -3294,8 +3302,10 @@ typedef struct
int flag_init_logical;
int flag_init_character;
char flag_init_character_value;
- bool disable_omp_is_initial_device;
- bool disable_acc_on_device;
+ bool disable_omp_is_initial_device:1;
+ bool disable_omp_get_initial_device:1;
+ bool disable_omp_get_num_devices:1;
+ bool disable_acc_on_device:1;
int fpe;
int fpe_summary;
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 753f589..b854292 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -2547,7 +2547,14 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
}
else if (formal->attr.function)
{
- if (!gfc_compare_types (&global_asym->ts,
+ gfc_typespec ts;
+
+ if (global_asym->result)
+ ts = global_asym->result->ts;
+ else
+ ts = global_asym->ts;
+
+ if (!gfc_compare_types (&ts,
&formal->ts))
{
gfc_error ("Type mismatch at %L passing global "
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 908e1da..9e07627 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -3452,37 +3452,37 @@ add_functions (void)
add_sym_1 ("acosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dr, GFC_STD_F2023,
- gfc_check_fn_r, gfc_simplify_acosd, gfc_resolve_trigd,
+ gfc_check_fn_r, gfc_simplify_acosd, gfc_resolve_trig,
x, BT_REAL, dr, REQUIRED);
make_generic ("acosd", GFC_ISYM_ACOSD, GFC_STD_F2023);
add_sym_1 ("dacosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dd, GFC_STD_GNU,
- gfc_check_fn_d, gfc_simplify_acosd, gfc_resolve_trigd,
+ gfc_check_fn_d, gfc_simplify_acosd, gfc_resolve_trig,
x, BT_REAL, dd, REQUIRED);
add_sym_1 ("asind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dr, GFC_STD_F2023,
- gfc_check_fn_r, gfc_simplify_asind, gfc_resolve_trigd,
+ gfc_check_fn_r, gfc_simplify_asind, gfc_resolve_trig,
x, BT_REAL, dr, REQUIRED);
make_generic ("asind", GFC_ISYM_ASIND, GFC_STD_F2023);
add_sym_1 ("dasind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dd, GFC_STD_GNU,
- gfc_check_fn_d, gfc_simplify_asind, gfc_resolve_trigd,
+ gfc_check_fn_d, gfc_simplify_asind, gfc_resolve_trig,
x, BT_REAL, dd, REQUIRED);
add_sym_1 ("atand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dr, GFC_STD_F2023,
- gfc_check_fn_r, gfc_simplify_atand, gfc_resolve_trigd,
+ gfc_check_fn_r, gfc_simplify_atand, gfc_resolve_trig,
x, BT_REAL, dr, REQUIRED);
/* Two-argument version of atand, equivalent to atan2d. */
add_sym_2 ("atand", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dr, GFC_STD_F2023,
- gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trigd2,
+ gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trig2,
y, BT_REAL, dr, REQUIRED,
x, BT_REAL, dr, REQUIRED);
@@ -3490,12 +3490,12 @@ add_functions (void)
add_sym_1 ("datand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dd, GFC_STD_GNU,
- gfc_check_fn_d, gfc_simplify_atand, gfc_resolve_trigd,
+ gfc_check_fn_d, gfc_simplify_atand, gfc_resolve_trig,
x, BT_REAL, dd, REQUIRED);
add_sym_2 ("atan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dr, GFC_STD_F2023,
- gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trigd2,
+ gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trig2,
y, BT_REAL, dr, REQUIRED,
x, BT_REAL, dr, REQUIRED);
@@ -3503,78 +3503,78 @@ add_functions (void)
add_sym_2 ("datan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dd, GFC_STD_GNU,
- gfc_check_datan2, gfc_simplify_atan2d, gfc_resolve_trigd2,
+ gfc_check_datan2, gfc_simplify_atan2d, gfc_resolve_trig2,
y, BT_REAL, dd, REQUIRED,
x, BT_REAL, dd, REQUIRED);
add_sym_1 ("cosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dr, GFC_STD_F2023,
- gfc_check_fn_r, gfc_simplify_cosd, gfc_resolve_trigd,
+ gfc_check_fn_r, gfc_simplify_cosd, gfc_resolve_trig,
x, BT_REAL, dr, REQUIRED);
make_generic ("cosd", GFC_ISYM_COSD, GFC_STD_F2023);
add_sym_1 ("dcosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dd, GFC_STD_GNU,
- gfc_check_fn_d, gfc_simplify_cosd, gfc_resolve_trigd,
+ gfc_check_fn_d, gfc_simplify_cosd, gfc_resolve_trig,
x, BT_REAL, dd, REQUIRED);
add_sym_1 ("cotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dr, GFC_STD_GNU,
- gfc_check_fn_rc2008, gfc_simplify_cotan, gfc_resolve_trigd,
+ gfc_check_fn_rc2008, gfc_simplify_cotan, gfc_resolve_trig,
x, BT_REAL, dr, REQUIRED);
add_sym_1 ("dcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dd, GFC_STD_GNU,
- gfc_check_fn_d, gfc_simplify_cotan, gfc_resolve_trigd,
+ gfc_check_fn_d, gfc_simplify_cotan, gfc_resolve_trig,
x, BT_REAL, dd, REQUIRED);
add_sym_1 ("ccotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES,
BT_COMPLEX, dz, GFC_STD_GNU,
- NULL, gfc_simplify_cotan, gfc_resolve_trigd,
+ NULL, gfc_simplify_cotan, gfc_resolve_trig,
x, BT_COMPLEX, dz, REQUIRED);
add_sym_1 ("zcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES,
BT_COMPLEX, dd, GFC_STD_GNU,
- NULL, gfc_simplify_cotan, gfc_resolve_trigd,
+ NULL, gfc_simplify_cotan, gfc_resolve_trig,
x, BT_COMPLEX, dd, REQUIRED);
make_generic ("cotan", GFC_ISYM_COTAN, GFC_STD_GNU);
add_sym_1 ("cotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dr, GFC_STD_GNU,
- gfc_check_fn_r, gfc_simplify_cotand, gfc_resolve_trigd,
+ gfc_check_fn_r, gfc_simplify_cotand, gfc_resolve_trig,
x, BT_REAL, dr, REQUIRED);
add_sym_1 ("dcotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dd, GFC_STD_GNU,
- gfc_check_fn_d, gfc_simplify_cotand, gfc_resolve_trigd,
+ gfc_check_fn_d, gfc_simplify_cotand, gfc_resolve_trig,
x, BT_REAL, dd, REQUIRED);
make_generic ("cotand", GFC_ISYM_COTAND, GFC_STD_GNU);
add_sym_1 ("sind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dr, GFC_STD_F2023,
- gfc_check_fn_r, gfc_simplify_sind, gfc_resolve_trigd,
+ gfc_check_fn_r, gfc_simplify_sind, gfc_resolve_trig,
x, BT_REAL, dr, REQUIRED);
make_generic ("sind", GFC_ISYM_SIND, GFC_STD_F2023);
add_sym_1 ("dsind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dd, GFC_STD_GNU,
- gfc_check_fn_d, gfc_simplify_sind, gfc_resolve_trigd,
+ gfc_check_fn_d, gfc_simplify_sind, gfc_resolve_trig,
x, BT_REAL, dd, REQUIRED);
add_sym_1 ("tand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dr, GFC_STD_F2023,
- gfc_check_fn_r, gfc_simplify_tand, gfc_resolve_trigd,
+ gfc_check_fn_r, gfc_simplify_tand, gfc_resolve_trig,
x, BT_REAL, dr, REQUIRED);
make_generic ("tand", GFC_ISYM_TAND, GFC_STD_F2023);
add_sym_1 ("dtand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES,
BT_REAL, dd, GFC_STD_GNU,
- gfc_check_fn_d, gfc_simplify_tand, gfc_resolve_trigd,
+ gfc_check_fn_d, gfc_simplify_tand, gfc_resolve_trig,
x, BT_REAL, dd, REQUIRED);
/* The following function is internally used for coarray libray functions.
@@ -3590,6 +3590,57 @@ add_functions (void)
REQUIRED, val, BT_INTEGER, di, REQUIRED, i, BT_INTEGER, di,
REQUIRED);
make_from_module ();
+
+ /* The half-cycle trigonometric functions were added by Fortran 2023. */
+
+ add_sym_1 ("acospi", GFC_ISYM_ACOSPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
+ GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_acospi,
+ gfc_resolve_trig, x, BT_REAL, dr, REQUIRED);
+
+ make_generic ("acospi", GFC_ISYM_ACOSPI, GFC_STD_F2023);
+
+ add_sym_1 ("asinpi", GFC_ISYM_ASINPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
+ GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_asinpi,
+ gfc_resolve_trig, x, BT_REAL, dr, REQUIRED);
+
+ make_generic ("asinpi", GFC_ISYM_ASINPI, GFC_STD_F2023);
+
+ add_sym_1 ("atanpi", GFC_ISYM_ATANPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
+ GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_atanpi,
+ gfc_resolve_trig, x, BT_REAL, dr, REQUIRED);
+
+ /* Two-argument version of atanpi, equivalent to atan2pi. */
+ add_sym_2 ("atanpi", GFC_ISYM_ATAN2PI, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
+ dr, GFC_STD_F2023, gfc_check_atan2, gfc_simplify_atan2pi,
+ gfc_resolve_trig2, y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr,
+ REQUIRED);
+
+ make_generic ("atanpi", GFC_ISYM_ATANPI, GFC_STD_F2023);
+
+ add_sym_2 ("atan2pi", GFC_ISYM_ATAN2PI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL,
+ dr, GFC_STD_F2023, gfc_check_atan2, gfc_simplify_atan2pi,
+ gfc_resolve_trig2, y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr,
+ REQUIRED);
+
+ make_generic ("atan2pi", GFC_ISYM_ATAN2PI, GFC_STD_F2023);
+
+ add_sym_1 ("cospi", GFC_ISYM_COSPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
+ GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_cospi,
+ gfc_resolve_trig, x, BT_REAL, dr, REQUIRED);
+
+ make_generic ("cospi", GFC_ISYM_COSPI, GFC_STD_F2023);
+
+ add_sym_1 ("sinpi", GFC_ISYM_SINPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
+ GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_sinpi,
+ gfc_resolve_trig, x, BT_REAL, dr, REQUIRED);
+
+ make_generic ("sinpi", GFC_ISYM_SINPI, GFC_STD_F2023);
+
+ add_sym_1 ("tanpi", GFC_ISYM_TANPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
+ GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_tanpi,
+ gfc_resolve_trig, x, BT_REAL, dr, REQUIRED);
+
+ make_generic ("tanpi", GFC_ISYM_TANPI, GFC_STD_F2023);
}
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 767792c..fd54588 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -246,6 +246,7 @@ gfc_expr *gfc_simplify_achar (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_acos (gfc_expr *);
gfc_expr *gfc_simplify_acosd (gfc_expr *);
gfc_expr *gfc_simplify_acosh (gfc_expr *);
+gfc_expr *gfc_simplify_acospi (gfc_expr *);
gfc_expr *gfc_simplify_adjustl (gfc_expr *);
gfc_expr *gfc_simplify_adjustr (gfc_expr *);
gfc_expr *gfc_simplify_aimag (gfc_expr *);
@@ -259,11 +260,14 @@ gfc_expr *gfc_simplify_and (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_any (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_asin (gfc_expr *);
gfc_expr *gfc_simplify_asinh (gfc_expr *);
+gfc_expr *gfc_simplify_asinpi (gfc_expr *);
gfc_expr *gfc_simplify_atan (gfc_expr *);
gfc_expr *gfc_simplify_atand (gfc_expr *);
gfc_expr *gfc_simplify_atanh (gfc_expr *);
+gfc_expr *gfc_simplify_atanpi (gfc_expr *);
gfc_expr *gfc_simplify_atan2 (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_atan2d (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_atan2pi (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_bessel_j0 (gfc_expr *);
gfc_expr *gfc_simplify_bessel_j1 (gfc_expr *);
gfc_expr *gfc_simplify_bessel_jn (gfc_expr *, gfc_expr *);
@@ -288,6 +292,7 @@ gfc_expr *gfc_simplify_conjg (gfc_expr *);
gfc_expr *gfc_simplify_cos (gfc_expr *);
gfc_expr *gfc_simplify_cosd (gfc_expr *);
gfc_expr *gfc_simplify_cosh (gfc_expr *);
+gfc_expr *gfc_simplify_cospi (gfc_expr *);
gfc_expr *gfc_simplify_cotan (gfc_expr *);
gfc_expr *gfc_simplify_cotand (gfc_expr *);
gfc_expr *gfc_simplify_count (gfc_expr *, gfc_expr *, gfc_expr *);
@@ -421,6 +426,7 @@ gfc_expr *gfc_simplify_shiftr (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_sin (gfc_expr *);
gfc_expr *gfc_simplify_sind (gfc_expr *);
gfc_expr *gfc_simplify_sinh (gfc_expr *);
+gfc_expr *gfc_simplify_sinpi (gfc_expr *);
gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_sizeof (gfc_expr *);
gfc_expr *gfc_simplify_storage_size (gfc_expr *, gfc_expr *);
@@ -432,6 +438,7 @@ gfc_expr *gfc_simplify_sum (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_tan (gfc_expr *);
gfc_expr *gfc_simplify_tand (gfc_expr *);
gfc_expr *gfc_simplify_tanh (gfc_expr *);
+gfc_expr *gfc_simplify_tanpi (gfc_expr *);
gfc_expr *gfc_simplify_this_image (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_tiny (gfc_expr *);
gfc_expr *gfc_simplify_trailz (gfc_expr *);
@@ -631,8 +638,8 @@ void gfc_resolve_time (gfc_expr *);
void gfc_resolve_time8 (gfc_expr *);
void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_transpose (gfc_expr *, gfc_expr *);
-void gfc_resolve_trigd (gfc_expr *, gfc_expr *);
-void gfc_resolve_trigd2 (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_trig (gfc_expr *, gfc_expr *);
+void gfc_resolve_trig2 (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_trim (gfc_expr *, gfc_expr *);
void gfc_resolve_ttynam (gfc_expr *, gfc_expr *);
void gfc_resolve_ubound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 48c2d60..3103da3 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -24,15 +24,22 @@ Some basic guidelines for editing this document:
@tex
\gdef\acosd{\mathop{\rm acosd}\nolimits}
-\gdef\asind{\mathop{\rm asind}\nolimits}
-\gdef\atand{\mathop{\rm atand}\nolimits}
-\gdef\acos{\mathop{\rm acos}\nolimits}
-\gdef\asin{\mathop{\rm asin}\nolimits}
-\gdef\atan{\mathop{\rm atan}\nolimits}
\gdef\acosh{\mathop{\rm acosh}\nolimits}
+\gdef\acospi{\mathop{\rm acospi}\nolimits}
+\gdef\acos{\mathop{\rm acos}\nolimits}
+\gdef\asind{\mathop{\rm asind}\nolimits}
\gdef\asinh{\mathop{\rm asinh}\nolimits}
+\gdef\asinpi{\mathop{\rm asinpi}\nolimits}
+\gdef\asin{\mathop{\rm asin}\nolimits}
+\gdef\atan2pi{\mathop{\rm atan2pi}\nolimits}
+\gdef\atand{\mathop{\rm atand}\nolimits}
\gdef\atanh{\mathop{\rm atanh}\nolimits}
+\gdef\atanpi{\mathop{\rm atanpi}\nolimits}
+\gdef\atan{\mathop{\rm atan}\nolimits}
\gdef\cosd{\mathop{\rm cosd}\nolimits}
+\gdef\cospi{\mathop{\rm cospi}\nolimits}
+\gdef\sinpi{\mathop{\rm sinpi}\nolimits}
+\gdef\tanpi{\mathop{\rm tanpi}\nolimits}
@end tex
@@ -49,6 +56,7 @@ Some basic guidelines for editing this document:
* @code{ACOS}: ACOS, Arccosine function
* @code{ACOSD}: ACOSD, Arccosine function, degrees
* @code{ACOSH}: ACOSH, Inverse hyperbolic cosine function
+* @code{ACOSPI}: ACOSPI, Circular arc cosine function
* @code{ADJUSTL}: ADJUSTL, Left adjust a string
* @code{ADJUSTR}: ADJUSTR, Right adjust a string
* @code{AIMAG}: AIMAG, Imaginary part of complex number
@@ -62,12 +70,15 @@ Some basic guidelines for editing this document:
* @code{ASIN}: ASIN, Arcsine function
* @code{ASIND}: ASIND, Arcsine function, degrees
* @code{ASINH}: ASINH, Inverse hyperbolic sine function
+* @code{ASINPI}: ASINPI, Circular arc sine function
* @code{ASSOCIATED}: ASSOCIATED, Status of a pointer or pointer/target pair
* @code{ATAN}: ATAN, Arctangent function
-* @code{ATAND}: ATAND, Arctangent function, degrees
* @code{ATAN2}: ATAN2, Arctangent function
* @code{ATAN2D}: ATAN2D, Arctangent function, degrees
+* @code{ATAN2PI}: ATAN2PI, Circular arc tangent function
+* @code{ATAND}: ATAND, Arctangent function, degrees
* @code{ATANH}: ATANH, Inverse hyperbolic tangent function
+* @code{ATANPI}: ATANPI, Circular arc tangent function
* @code{ATOMIC_ADD}: ATOMIC_ADD, Atomic ADD operation
* @code{ATOMIC_AND}: ATOMIC_AND, Atomic bitwise AND operation
* @code{ATOMIC_CAS}: ATOMIC_CAS, Atomic compare and swap
@@ -116,6 +127,7 @@ Some basic guidelines for editing this document:
* @code{COS}: COS, Cosine function
* @code{COSD}: COSD, Cosine function, degrees
* @code{COSH}: COSH, Hyperbolic cosine function
+* @code{COSPI}: COSPI, Circular cosine function
* @code{COTAN}: COTAN, Cotangent function
* @code{COTAND}: COTAND, Cotangent function, degrees
* @code{COUNT}: COUNT, Count occurrences of TRUE in an array
@@ -296,6 +308,7 @@ Some basic guidelines for editing this document:
* @code{SIN}: SIN, Sine function
* @code{SIND}: SIND, Sine function, degrees
* @code{SINH}: SINH, Hyperbolic sine function
+* @code{SINPI}: SINPI, Circular sine function
* @code{SIZE}: SIZE, Function to determine the size of an array
* @code{SIZEOF}: SIZEOF, Determine the size in bytes of an expression
* @code{SLEEP}: SLEEP, Sleep for the specified number of seconds
@@ -312,6 +325,7 @@ Some basic guidelines for editing this document:
* @code{TAN}: TAN, Tangent function
* @code{TAND}: TAND, Tangent function, degrees
* @code{TANH}: TANH, Hyperbolic tangent function
+* @code{TANPI}: TANPI, Circular tangent function
* @code{TEAM_NUMBER}: TEAM_NUMBER, Retrieve team id of given team
* @code{THIS_IMAGE}: THIS_IMAGE, Cosubscript index of this image
* @code{TIME}: TIME, Time function
@@ -754,6 +768,62 @@ Inverse function: @*
+@node ACOSPI
+@section @code{ACOSPI} --- Circular arc cosine function
+@fnindex ACOSPI
+@cindex trigonometric function, cosine, inverse
+
+@table @asis
+@item @emph{Description}:
+@code{ACOSPI(X)} computes @math{ \acos(x) / \pi}, which is a measure
+of an angle in half-revolutions.
+
+@item @emph{Standard}:
+Fortran 2023
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ACOSPI(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL} with @math{-1 \leq x \leq 1}.
+@end multitable
+
+@item @emph{Return value}:
+The return value has the same type and kind as @var{X}.
+It is expressed in half-revolutions and satisfies
+@math{ 0 \leq \acospi (x) \leq 1}.
+
+@item @emph{Example}:
+@smallexample
+program test_acospi
+ implicit none
+ real, parameter :: x = 0.123, y(3) = [0.123, 0.45, 0.8]
+ real, parameter :: a = acospi(x), b(3) = acospi(y)
+ call foo(x, y)
+contains
+ subroutine foo(u, v)
+ real, intent(in) :: u, v(:)
+ real :: f, g(size(v))
+ f = acospi(u)
+ g = acospi(v)
+ if (abs(a - f) > 8 * epsilon(f)) stop 1
+ if (any(abs(g - b) > 8 * epsilon(f))) stop 2
+ end subroutine foo
+end program test_acospi
+@end smallexample
+
+@item @emph{See also}:
+@ref{ASINPI} @*
+@ref{ATAN2PI} @*
+@ref{ATANPI} @*
+@end table
+
+
+
@node ADJUSTL
@section @code{ADJUSTL} --- Left adjust a string
@fnindex ADJUSTL
@@ -1469,6 +1539,62 @@ Inverse function: @*
+@node ASINPI
+@section @code{ASINPI} --- Circular arc sine function
+@fnindex ASINPI
+@cindex trigonometric function, sine, inverse
+
+@table @asis
+@item @emph{Description}:
+@code{ASINPI(X)} computes @math{ \asin(x) / \pi}, which is a measure
+of an angle in half-revolutions.
+
+@item @emph{Standard}:
+Fortran 2023
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ASINPI(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL} with @math{-1 \leq x \leq 1}.
+@end multitable
+
+@item @emph{Return value}:
+The return value has the same type and kind as @var{X}.
+It is expressed in half-revolutions and satisfies
+@math{ -0.5 \leq \asinpi (x) \leq 0.5}.
+
+@item @emph{Example}:
+@smallexample
+program test_asinpi
+ implicit none
+ real, parameter :: x = 0.123, y(3) = [0.123, 0.45, 0.8]
+ real, parameter :: a = asinpi(x), b(3) = asinpi(y)
+ call foo(x, y)
+contains
+ subroutine foo(u, v)
+ real, intent(in) :: u, v(:)
+ real :: f, g(size(v))
+ f = asinpi(u)
+ g = asinpi(v)
+ if (abs(a - f) > 8 * epsilon(f)) stop 1
+ if (any(abs(g - b) > 8 * epsilon(f))) stop 2
+ end subroutine foo
+end program test_asinpi
+@end smallexample
+
+@item @emph{See also}:
+@ref{ACOSPI} @*
+@ref{ATAN2PI} @*
+@ref{ATANPI} @*
+@end table
+
+
+
@node ASSOCIATED
@section @code{ASSOCIATED} --- Status of a pointer or pointer/target pair
@fnindex ASSOCIATED
@@ -1608,68 +1734,6 @@ Degrees function: @*
-@node ATAND
-@section @code{ATAND} --- Arctangent function, degrees
-@fnindex ATAND
-@fnindex DATAND
-@cindex trigonometric function, tangent, inverse, degrees
-@cindex tangent, inverse, degrees
-
-@table @asis
-@item @emph{Synopsis}:
-@multitable @columnfractions .80
-@item @code{RESULT = ATAND(X)}
-@item @code{RESULT = ATAND(Y, X)}
-@end multitable
-
-@item @emph{Description}:
-@code{ATAND(X)} computes the arctangent of @var{X} in degrees (inverse of
-@ref{TAND}).
-
-@item @emph{Class}:
-Elemental function
-
-@item @emph{Arguments}:
-@multitable @columnfractions .15 .70
-@item @var{X} @tab The type shall be @code{REAL}.
-@item @var{Y} @tab The type and kind type parameter shall be the same as @var{X}.
-@end multitable
-
-@item @emph{Return value}:
-The return value is of the same type and kind as @var{X}.
-If @var{Y} is present, the result is identical to @code{ATAN2D(Y, X)}.
-Otherwise, the result is in degrees and lies in the range
-@math{-90 \leq \atand(x) \leq 90}.
-
-@item @emph{Example}:
-@smallexample
-program test_atand
- real(8) :: x = 2.866_8
- real(4) :: x1 = 1.e0_4, y1 = 0.5e0_4
- x = atand(x)
- x1 = atand(y1, x1)
-end program test_atand
-@end smallexample
-
-@item @emph{Specific names}:
-@multitable @columnfractions .23 .23 .20 .30
-@headitem Name @tab Argument @tab Return type @tab Standard
-@item @code{ATAND(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 2023
-@item @code{DATAND(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension
-@end multitable
-
-@item @emph{Standard}:
-Fortran 2023
-
-@item @emph{See also}:
-Inverse function: @*
-@ref{TAND} @*
-Radians function: @*
-@ref{ATAN}
-@end table
-
-
-
@node ATAN2
@section @code{ATAN2} --- Arctangent function
@fnindex ATAN2
@@ -1798,6 +1862,117 @@ Radians function: @*
@ref{ATAN2}
@end table
+
+
+@node ATAN2PI
+@section @code{ATAN2PI} --- Circular arc tangent function
+@fnindex ATAN2PI
+@cindex trigonometric function, tangent, inverse
+
+@table @asis
+@item @emph{Description}:
+@code{ATAN2PI(Y, X)} computes @math{ {\rm {atan2}}(y, x) / \pi},
+and provides a measure of an angle in half-revolutions within
+the proper quadrant.
+
+@item @emph{Standard}:
+Fortran 2023
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = ATAN2PI(Y, X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{Y} @tab The type shall be @code{REAL}.
+@item @var{X} @tab The type and kind type parameter shall be the
+same as @var{Y}. If @var{Y} is zero, then @var{X} shall be nonzero.
+@end multitable
+
+@item @emph{Return value}:
+The return value has the same type and kind type parameter as @var{Y}
+and satisfies @math{-1 \leq {\rm {atan2}}(y, x) / \pi \leq 1}.
+
+@item @emph{Example}:
+@smallexample
+program test_atan2pi
+ real(kind=4) :: x = 1.e0_4, y = 0.5e0_4
+ x = atan2pi(y, x)
+end program test_atan2pi
+@end smallexample
+
+@item @emph{See also}:
+@ref{ACOSPI} @*
+@ref{ASINPI} @*
+@ref{ATANPI} @*
+@end table
+
+
+
+@node ATAND
+@section @code{ATAND} --- Arctangent function, degrees
+@fnindex ATAND
+@fnindex DATAND
+@cindex trigonometric function, tangent, inverse, degrees
+@cindex tangent, inverse, degrees
+
+@table @asis
+@item @emph{Synopsis}:
+@multitable @columnfractions .80
+@item @code{RESULT = ATAND(X)}
+@item @code{RESULT = ATAND(Y, X)}
+@end multitable
+
+@item @emph{Description}:
+@code{ATAND(X)} computes the arctangent of @var{X} in degrees (inverse of
+@ref{TAND}).
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}.
+@item @var{Y} @tab The type and kind type parameter shall be the same as @var{X}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and kind as @var{X}.
+If @var{Y} is present, the result is identical to @code{ATAN2D(Y, X)}.
+Otherwise, the result is in degrees and lies in the range
+@math{-90 \leq \atand(x) \leq 90}.
+
+@item @emph{Example}:
+@smallexample
+program test_atand
+ real(8) :: x = 2.866_8
+ real(4) :: x1 = 1.e0_4, y1 = 0.5e0_4
+ x = atand(x)
+ x1 = atand(y1, x1)
+end program test_atand
+@end smallexample
+
+@item @emph{Specific names}:
+@multitable @columnfractions .23 .23 .20 .30
+@headitem Name @tab Argument @tab Return type @tab Standard
+@item @code{ATAND(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 2023
+@item @code{DATAND(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension
+@end multitable
+
+@item @emph{Standard}:
+Fortran 2023
+
+@item @emph{See also}:
+Inverse function: @*
+@ref{TAND} @*
+Radians function: @*
+@ref{ATAN}
+@end table
+
+
+
@node ATANH
@section @code{ATANH} --- Inverse hyperbolic tangent function
@fnindex ATANH
@@ -1851,6 +2026,70 @@ Inverse function: @*
+@node ATANPI
+@section @code{ATANPI} --- Circular arc tangent function
+@fnindex ATANPI
+@cindex trigonometric function, tangent, inverse
+
+@table @asis
+@item @emph{Description}:
+@code{ATANPI(X)} computes @math{ \atan(x) / \pi}.
+@code{ATANPI(Y, X)} computes @math{ {\rm atan2}(y, x) / \pi}.
+These provide a measure of an angle in half-revolutions.
+
+@item @emph{Standard}:
+Fortran 2023
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = ATANPI(X)}
+@item @code{RESULT = ATANPI(Y, X)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{Y} @tab The type shall be @code{REAL}.
+@item @var{X} @tab If @var{Y} appears, @var{X} shall have the same type
+and kind as @var{Y}. If @var{Y} is zero, then @var{X} shall not be zero.
+If @var{Y} does not appear in a function reference, then @var{X} shall be
+@code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value has the same type and kind as @var{X}.
+It is expressed in half-revolutions and satisfies
+@math{ -0.5 \leq \atanpi (x) \leq 0.5}.
+
+@item @emph{Example}:
+@smallexample
+program test_atanpi
+ implicit none
+ real, parameter :: x = 0.123, y(3) = [0.123, 0.45, 0.8]
+ real, parameter :: a = atanpi(x), b(3) = atanpi(y)
+ call foo(x, y)
+contains
+ subroutine foo(u, v)
+ real, intent(in) :: u, v(:)
+ real :: f, g(size(v))
+ f = atanpi(u)
+ g = atanpi(v)
+ if (abs(a - f) > 8 * epsilon(f)) stop 1
+ if (any(abs(g - b) > 8 * epsilon(f))) stop 2
+ end subroutine foo
+end program test_atanpi
+@end smallexample
+
+@item @emph{See also}:
+@ref{ACOSPI} @*
+@ref{ASINPI} @*
+@ref{ATAN2PI} @*
+@end table
+
+
+
@node ATOMIC_ADD
@section @code{ATOMIC_ADD} --- Atomic ADD operation
@fnindex ATOMIC_ADD
@@ -4391,6 +4630,57 @@ Inverse function: @*
+@node COSPI
+@section @code{COSPI} --- Circular cosine function
+@fnindex COSPI
+@cindex trigonometric function, cosine
+@cindex cosine
+
+@table @asis
+@item @emph{Description}:
+@code{COSPI(X)} computes @math{\cos(\pi x)} without performing
+an explicit multiplication by @math{\pi}. This is achieved
+through argument reduction where @math{ x = n + r } with
+@math{n} an integer and @math{0 \leq r \le 1}.
+Due to the
+properties of floating-point arithmetic, the useful range
+for @var{X} is defined by
+@code{ABS(X) <= REAL(2,KIND(X))**DIGITS(X)}.
+
+@item @emph{Standard}:
+Fortran 2023
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = COSPI(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and kind as @var{X}.
+The result is in half-revolutions and satisfies
+@math{ -1 \leq \cospi (x) \leq 1}.
+
+@item @emph{Example}:
+@smallexample
+program test_cospi
+ real :: x = 0.0
+ x = cospi(x)
+end program test_cospi
+@end smallexample
+
+@item @emph{See also}:
+@ref{ACOSPI} @*
+@ref{COS} @*
+@end table
+
+
+
@node COTAN
@section @code{COTAN} --- Cotangent function
@fnindex COTAN
@@ -6711,9 +7001,11 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{UNIT} @tab An open I/O unit number of type @code{INTEGER}.
-@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
-@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0
-on success and a system specific error code otherwise.
+@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(13)}
+of the default kind.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}
+of the default kind.
+Returns 0 on success and a system specific error code otherwise.
@end multitable
@item @emph{Example}:
@@ -10016,8 +10308,10 @@ Subroutine, function
@multitable @columnfractions .15 .70
@item @var{NAME} @tab The type shall be @code{CHARACTER} of the default
kind, a valid path within the file system.
-@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
-@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}.
+@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(13)}
+of the default kind.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}
+of the default kind.
Returns 0 on success and a system specific error code otherwise.
@end multitable
@@ -13677,6 +13971,57 @@ a GNU extension
+@node SINPI
+@section @code{SINPI} --- Circular sine function
+@fnindex SINPI
+@cindex trigonometric function, sine
+@cindex sine
+
+@table @asis
+@item @emph{Description}:
+@code{SINPI(X)} computes @math{\sin(\pi x)} without performing
+an explicit multiplication by @math{\pi}. This is achieved
+through argument reduction where @math{ |x| = n + r } with
+@math{n} an integer and @math{0 \leq r \le 1}.
+Due to the
+properties of floating-point arithmetic, the useful range
+for @var{X} is defined by
+@code{ABS(X) <= REAL(2,KIND(X))**DIGITS(X)}.
+
+@item @emph{Standard}:
+Fortran 2023
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = SINPI(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and kind as @var{X}.
+The result is in half-revolutions and satisfies
+@math{ -1 \leq \sinpi (x) \leq 1}.
+
+@item @emph{Example}:
+@smallexample
+program test_sinpi
+ real :: x = 0.0
+ x = sinpi(x)
+end program test_sinpi
+@end smallexample
+
+@item @emph{See also}:
+@ref{ASINPI} @*
+@ref{SIN} @*
+@end table
+
+
+
@node SIZE
@section @code{SIZE} --- Determine the size of an array
@fnindex SIZE
@@ -14050,6 +14395,8 @@ The elements that are obtained and stored in the array @code{VALUES}:
Not all these elements are relevant on all systems.
If an element is not relevant, it is returned as 0.
+If the value of an element would overflow the range of default integer,
+a -1 is returned instead.
This intrinsic is provided in both subroutine and function forms; however,
only one form can be used in any given program unit.
@@ -14061,9 +14408,11 @@ Subroutine, function
@multitable @columnfractions .15 .70
@item @var{NAME} @tab The type shall be @code{CHARACTER}, of the
default kind and a valid path within the file system.
-@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
-@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0
-on success and a system specific error code otherwise.
+@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(13)}
+of the default kind.
+@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER}
+of the default kind.
+Returns 0 on success and a system specific error code otherwise.
@end multitable
@item @emph{Example}:
@@ -14574,6 +14923,55 @@ Fortran 2018 and later.
+@node TANPI
+@section @code{TANPI} --- Circular tangent function
+@fnindex TANPI
+@cindex trigonometric function, tangent
+@cindex tangent
+
+@table @asis
+@item @emph{Description}:
+@code{TANPI(X)} computes @math{\tan(\pi x)} without performing
+an explicit multiplication by @math{\pi}. This is achieved
+through argument reduction where @math{ |x| = n + r } with
+@math{n} an integer and @math{0 \leq r \le 1}.
+Due to the
+properties of floating-point arithmetic, the useful range
+for @var{X} is defined by
+@code{ABS(X) <= REAL(2,KIND(X))**DIGITS(X)}.
+
+@item @emph{Standard}:
+Fortran 2023
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = TANPI(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The type shall be @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of the same type and kind as @var{X}.
+
+@item @emph{Example}:
+@smallexample
+program test_tanpi
+ real :: x = 0.0
+ x = tanpi(x)
+end program test_tanpi
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATANPI} @*
+@ref{TAN} @*
+@end table
+
+
+
@node THIS_IMAGE
@section @code{THIS_IMAGE} --- Function that returns the cosubscript index of this image
@fnindex THIS_IMAGE
diff --git a/gcc/fortran/io.cc b/gcc/fortran/io.cc
index b5c9d33..7466d8f 100644
--- a/gcc/fortran/io.cc
+++ b/gcc/fortran/io.cc
@@ -1228,7 +1228,8 @@ between_desc:
default:
if (mode != MODE_FORMAT)
format_locus.nextc += format_string_pos - 1;
- if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus))
+ if (!gfc_notify_std (GFC_STD_LEGACY,
+ "Missing comma in FORMAT string at %L", &format_locus))
return false;
/* If we do not actually return a failure, we need to unwind this
before the next round. */
@@ -1290,7 +1291,8 @@ extension_optional_comma:
default:
if (mode != MODE_FORMAT)
format_locus.nextc += format_string_pos;
- if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus))
+ if (!gfc_notify_std (GFC_STD_LEGACY,
+ "Missing comma in FORMAT string at %L", &format_locus))
return false;
/* If we do not actually return a failure, we need to unwind this
before the next round. */
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 6930e2c..1001309 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -3435,13 +3435,12 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
}
-
-/* Resolve the degree trigonometric functions. This amounts to setting
+/* Resolve the trigonometric functions. This amounts to setting
the function return type-spec from its argument and building a
library function names of the form _gfortran_sind_r4. */
void
-gfc_resolve_trigd (gfc_expr *f, gfc_expr *x)
+gfc_resolve_trig (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name
@@ -3450,9 +3449,8 @@ gfc_resolve_trigd (gfc_expr *f, gfc_expr *x)
gfc_type_abi_kind (&x->ts));
}
-
void
-gfc_resolve_trigd2 (gfc_expr *f, gfc_expr *y, gfc_expr *x)
+gfc_resolve_trig2 (gfc_expr *f, gfc_expr *y, gfc_expr *x)
{
f->ts = y->ts;
f->value.function.name
diff --git a/gcc/fortran/mathbuiltins.def b/gcc/fortran/mathbuiltins.def
index 2d475a2..bdc9058 100644
--- a/gcc/fortran/mathbuiltins.def
+++ b/gcc/fortran/mathbuiltins.def
@@ -23,34 +23,41 @@ along with GCC; see the file COPYING3. If not see
Use DEFINE_MATH_BUILTIN_C if the complex versions of the builtin are
also available. */
-DEFINE_MATH_BUILTIN_C (ACOS, "acos", 0)
-DEFINE_MATH_BUILTIN_C (ACOSH, "acosh", 0)
-DEFINE_MATH_BUILTIN_C (ASIN, "asin", 0)
-DEFINE_MATH_BUILTIN_C (ASINH, "asinh", 0)
-DEFINE_MATH_BUILTIN_C (ATAN, "atan", 0)
-DEFINE_MATH_BUILTIN_C (ATANH, "atanh", 0)
-DEFINE_MATH_BUILTIN (ATAN2, "atan2", 1)
-DEFINE_MATH_BUILTIN_C (COS, "cos", 0)
-DEFINE_MATH_BUILTIN_C (COSH, "cosh", 0)
-DEFINE_MATH_BUILTIN_C (EXP, "exp", 0)
-DEFINE_MATH_BUILTIN_C (LOG, "log", 0)
-DEFINE_MATH_BUILTIN_C (LOG10, "log10", 0)
-DEFINE_MATH_BUILTIN_C (SIN, "sin", 0)
-DEFINE_MATH_BUILTIN_C (SINH, "sinh", 0)
-DEFINE_MATH_BUILTIN_C (SQRT, "sqrt", 0)
-DEFINE_MATH_BUILTIN_C (TAN, "tan", 0)
-DEFINE_MATH_BUILTIN_C (TANH, "tanh", 0)
-DEFINE_MATH_BUILTIN (J0, "j0", 0)
-DEFINE_MATH_BUILTIN (J1, "j1", 0)
-DEFINE_MATH_BUILTIN (JN, "jn", 5)
-DEFINE_MATH_BUILTIN (Y0, "y0", 0)
-DEFINE_MATH_BUILTIN (Y1, "y1", 0)
-DEFINE_MATH_BUILTIN (YN, "yn", 5)
-DEFINE_MATH_BUILTIN (ERF, "erf", 0)
-DEFINE_MATH_BUILTIN (ERFC, "erfc", 0)
-DEFINE_MATH_BUILTIN (TGAMMA,"tgamma", 0)
-DEFINE_MATH_BUILTIN (LGAMMA,"lgamma", 0)
-DEFINE_MATH_BUILTIN (HYPOT, "hypot", 1)
+DEFINE_MATH_BUILTIN_C (ACOS, "acos", 0)
+DEFINE_MATH_BUILTIN_C (ACOSH, "acosh", 0)
+DEFINE_MATH_BUILTIN (ACOSPI, "acospi", 0)
+DEFINE_MATH_BUILTIN_C (ASIN, "asin", 0)
+DEFINE_MATH_BUILTIN_C (ASINH, "asinh", 0)
+DEFINE_MATH_BUILTIN (ASINPI, "asinpi", 0)
+DEFINE_MATH_BUILTIN_C (ATAN, "atan", 0)
+DEFINE_MATH_BUILTIN (ATAN2, "atan2", 1)
+DEFINE_MATH_BUILTIN (ATAN2PI, "atan2pi", 1)
+DEFINE_MATH_BUILTIN_C (ATANH, "atanh", 0)
+DEFINE_MATH_BUILTIN (ATANPI, "atanpi", 0)
+DEFINE_MATH_BUILTIN_C (COS, "cos", 0)
+DEFINE_MATH_BUILTIN_C (COSH, "cosh", 0)
+DEFINE_MATH_BUILTIN (COSPI, "cospi", 0)
+DEFINE_MATH_BUILTIN (ERF, "erf", 0)
+DEFINE_MATH_BUILTIN (ERFC, "erfc", 0)
+DEFINE_MATH_BUILTIN_C (EXP, "exp", 0)
+DEFINE_MATH_BUILTIN (HYPOT, "hypot", 1)
+DEFINE_MATH_BUILTIN (J0, "j0", 0)
+DEFINE_MATH_BUILTIN (J1, "j1", 0)
+DEFINE_MATH_BUILTIN (JN, "jn", 5)
+DEFINE_MATH_BUILTIN (LGAMMA, "lgamma", 0)
+DEFINE_MATH_BUILTIN_C (LOG, "log", 0)
+DEFINE_MATH_BUILTIN_C (LOG10, "log10", 0)
+DEFINE_MATH_BUILTIN_C (SIN, "sin", 0)
+DEFINE_MATH_BUILTIN_C (SINH, "sinh", 0)
+DEFINE_MATH_BUILTIN (SINPI, "sinpi", 0)
+DEFINE_MATH_BUILTIN_C (SQRT, "sqrt", 0)
+DEFINE_MATH_BUILTIN_C (TAN, "tan", 0)
+DEFINE_MATH_BUILTIN_C (TANH, "tanh", 0)
+DEFINE_MATH_BUILTIN (TANPI, "tanpi", 0)
+DEFINE_MATH_BUILTIN (TGAMMA, "tgamma", 0)
+DEFINE_MATH_BUILTIN (Y0, "y0", 0)
+DEFINE_MATH_BUILTIN (Y1, "y1", 0)
+DEFINE_MATH_BUILTIN (YN, "yn", 5)
/* OTHER_BUILTIN (CODE, NAME, PROTOTYPE_TYPE, CONST)
For floating-point builtins that do not directly correspond to a
diff --git a/gcc/fortran/misc.cc b/gcc/fortran/misc.cc
index 893c40f..b8bdf75 100644
--- a/gcc/fortran/misc.cc
+++ b/gcc/fortran/misc.cc
@@ -214,6 +214,9 @@ gfc_typename (gfc_typespec *ts, bool for_hash)
case BT_UNKNOWN:
strcpy (buffer, "UNKNOWN");
break;
+ case BT_VOID:
+ strcpy (buffer, "VOID");
+ break;
default:
gfc_internal_error ("gfc_typename(): Undefined type");
}
diff --git a/gcc/fortran/options.cc b/gcc/fortran/options.cc
index ddddc1c..d3c9066 100644
--- a/gcc/fortran/options.cc
+++ b/gcc/fortran/options.cc
@@ -883,6 +883,10 @@ gfc_handle_option (size_t scode, const char *arg, HOST_WIDE_INT value,
return false; /* Not supported. */
if (!strcmp ("omp_is_initial_device", arg))
gfc_option.disable_omp_is_initial_device = true;
+ else if (!strcmp ("omp_get_initial_device", arg))
+ gfc_option.disable_omp_get_initial_device = true;
+ else if (!strcmp ("omp_get_num_devices", arg))
+ gfc_option.disable_omp_get_num_devices = true;
else if (!strcmp ("acc_on_device", arg))
gfc_option.disable_acc_on_device = true;
else
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 538eb65..8d4ca39 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -27,6 +27,9 @@ along with GCC; see the file COPYING3. If not see
#include "match.h"
#include "parse.h"
#include "tree-core.h"
+#include "tree.h"
+#include "fold-const.h"
+#include "tree-hash-traits.h"
#include "omp-general.h"
/* Current statement label. Zero means no statement label. Because new_st
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index ec4e135..f0e1fef 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2102,10 +2102,18 @@ extend_ref (gfc_expr *primary, gfc_ref *tail)
{
if (primary->ref == NULL)
primary->ref = tail = gfc_get_ref ();
+ else if (tail == NULL)
+ {
+ /* Set tail to end of reference chain. */
+ for (gfc_ref *ref = primary->ref; ref; ref = ref->next)
+ if (ref->next == NULL)
+ {
+ tail = ref;
+ break;
+ }
+ }
else
{
- if (tail == NULL)
- gfc_internal_error ("extend_ref(): Bad tail");
tail->next = gfc_get_ref ();
tail = tail->next;
}
@@ -2302,9 +2310,22 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
gfc_array_spec *as;
bool coarray_only = sym->attr.codimension && !sym->attr.dimension
&& sym->ts.type == BT_CHARACTER;
+ gfc_ref *ref, *strarr = NULL;
tail = extend_ref (primary, tail);
- tail->type = REF_ARRAY;
+ if (sym->ts.type == BT_CHARACTER && tail->type == REF_SUBSTRING)
+ {
+ gcc_assert (sym->attr.dimension);
+ /* Find array reference for substrings of character arrays. */
+ for (ref = primary->ref; ref && ref->next; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->next->type == REF_SUBSTRING)
+ {
+ strarr = ref;
+ break;
+ }
+ }
+ else
+ tail->type = REF_ARRAY;
/* In EQUIVALENCE, we don't know yet whether we are seeing
an array, character variable or array of character
@@ -2317,7 +2338,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
else
as = sym->as;
- m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag, as ? as->corank : 0,
+ ref = strarr ? strarr : tail;
+ m = gfc_match_array_ref (&ref->u.ar, as, equiv_flag, as ? as->corank : 0,
coarray_only);
if (m != MATCH_YES)
return m;
@@ -2483,6 +2505,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
{
bool t;
gfc_symtree *tbp;
+ gfc_typespec *ts = &primary->ts;
m = gfc_match_name (name);
if (m == MATCH_NO)
@@ -2490,8 +2513,18 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
if (m != MATCH_YES)
return MATCH_ERROR;
+ /* For derived type components find typespec of ultimate component. */
+ if (ts->type == BT_DERIVED && primary->ref)
+ {
+ for (gfc_ref *ref = primary->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT && ref->u.c.component)
+ ts = &ref->u.c.component->ts;
+ }
+ }
+
intrinsic = false;
- if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED)
+ if (ts->type != BT_CLASS && ts->type != BT_DERIVED)
{
inquiry = is_inquiry_ref (name, &tmp);
if (inquiry)
@@ -2564,7 +2597,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
return MATCH_ERROR;
}
else if (tmp->u.i == INQUIRY_LEN
- && primary->ts.type != BT_CHARACTER)
+ && ts->type != BT_CHARACTER)
{
gfc_error ("The LEN part_ref at %C must be applied "
"to a CHARACTER expression");
@@ -2659,6 +2692,11 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
primary->ref = tmp;
else
{
+ /* Find end of reference chain if inquiry reference and tail not
+ set. */
+ if (tail == NULL && inquiry && tmp)
+ tail = extend_ref (primary, tail);
+
/* Set by the for loop below for the last component ref. */
gcc_assert (tail != NULL);
tail->next = tmp;
@@ -2678,6 +2716,9 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
if (primary->expr_type == EXPR_CONSTANT)
goto check_done;
+ if (primary->ref == NULL)
+ goto check_done;
+
switch (tmp->u.i)
{
case INQUIRY_RE:
@@ -2828,6 +2869,7 @@ check_substring:
if (substring)
primary->ts.u.cl = NULL;
+ gfc_gobble_whitespace ();
if (gfc_peek_ascii_char () == '(')
{
gfc_error_now ("Unexpected array/substring ref at %C");
@@ -4271,6 +4313,16 @@ gfc_match_rvalue (gfc_expr **result)
return MATCH_ERROR;
}
+ /* Scan for possible inquiry references. */
+ if (m == MATCH_YES
+ && e->expr_type == EXPR_VARIABLE
+ && gfc_peek_ascii_char () == '%')
+ {
+ m = gfc_match_varspec (e, 0, false, false);
+ if (m == MATCH_NO)
+ m = MATCH_YES;
+ }
+
if (m == MATCH_YES)
{
e->where = where;
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index bf1aa70..5413d8f 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -8740,8 +8740,25 @@ static bool
conformable_arrays (gfc_expr *e1, gfc_expr *e2)
{
gfc_ref *tail;
+ bool scalar;
+
for (tail = e2->ref; tail && tail->next; tail = tail->next);
+ /* If MOLD= is present and is not scalar, and the allocate-object has an
+ explicit-shape-spec, the ranks need not agree. This may be unintended,
+ so let's emit a warning if -Wsurprising is given. */
+ scalar = !tail || tail->type == REF_COMPONENT;
+ if (e1->mold && e1->rank > 0
+ && (scalar || (tail->type == REF_ARRAY && tail->u.ar.type != AR_FULL)))
+ {
+ if (scalar || (tail->u.ar.as && e1->rank != tail->u.ar.as->rank))
+ gfc_warning (OPT_Wsurprising, "Allocate-object at %L has rank %d "
+ "but MOLD= expression at %L has rank %d",
+ &e2->where, scalar ? 0 : tail->u.ar.as->rank,
+ &e1->where, e1->rank);
+ return true;
+ }
+
/* First compare rank. */
if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank))
|| (!tail && e1->rank != e2->rank))
@@ -18059,16 +18076,16 @@ skip_interfaces:
|| (a->dummy && !a->pointer && a->intent == INTENT_OUT
&& sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))
apply_default_init (sym);
+ else if (a->function && !a->pointer && !a->allocatable && !a->use_assoc
+ && sym->result)
+ /* Default initialization for function results. */
+ apply_default_init (sym->result);
else if (a->function && sym->result && a->access != ACCESS_PRIVATE
&& (sym->ts.u.derived->attr.alloc_comp
|| sym->ts.u.derived->attr.pointer_comp))
/* Mark the result symbol to be referenced, when it has allocatable
components. */
sym->result->attr.referenced = 1;
- else if (a->function && !a->pointer && !a->allocatable && !a->use_assoc
- && sym->result)
- /* Default initialization for function results. */
- apply_default_init (sym->result);
}
if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 1927097..b25cd2c 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -885,7 +885,8 @@ gfc_simplify_acos (gfc_expr *x)
if (mpfr_cmp_si (x->value.real, 1) > 0
|| mpfr_cmp_si (x->value.real, -1) < 0)
{
- gfc_error ("Argument of ACOS at %L must be between -1 and 1",
+ gfc_error ("Argument of ACOS at %L must be within the closed "
+ "interval [-1, 1]",
&x->where);
return &gfc_bad_expr;
}
@@ -1162,7 +1163,8 @@ gfc_simplify_asin (gfc_expr *x)
if (mpfr_cmp_si (x->value.real, 1) > 0
|| mpfr_cmp_si (x->value.real, -1) < 0)
{
- gfc_error ("Argument of ASIN at %L must be between -1 and 1",
+ gfc_error ("Argument of ASIN at %L must be within the closed "
+ "interval [-1, 1]",
&x->where);
return &gfc_bad_expr;
}
@@ -1213,8 +1215,9 @@ gfc_simplify_acosd (gfc_expr *x)
if (mpfr_cmp_si (x->value.real, 1) > 0
|| mpfr_cmp_si (x->value.real, -1) < 0)
{
- gfc_error ("Argument of ACOSD at %L must be between -1 and 1",
- &x->where);
+ gfc_error (
+ "Argument of ACOSD at %L must be within the closed interval [-1, 1]",
+ &x->where);
return &gfc_bad_expr;
}
@@ -1243,8 +1246,9 @@ gfc_simplify_asind (gfc_expr *x)
if (mpfr_cmp_si (x->value.real, 1) > 0
|| mpfr_cmp_si (x->value.real, -1) < 0)
{
- gfc_error ("Argument of ASIND at %L must be between -1 and 1",
- &x->where);
+ gfc_error (
+ "Argument of ASIND at %L must be within the closed interval [-1, 1]",
+ &x->where);
return &gfc_bad_expr;
}
@@ -1383,7 +1387,7 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
{
- gfc_error ("If first argument of ATAN2 at %L is zero, then the "
+ gfc_error ("If the first argument of ATAN2 at %L is zero, then the "
"second argument must not be zero", &y->where);
return &gfc_bad_expr;
}
@@ -1962,7 +1966,7 @@ gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x)
if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
{
- gfc_error ("If first argument of ATAN2D at %L is zero, then the "
+ gfc_error ("If the first argument of ATAN2D at %L is zero, then the "
"second argument must not be zero", &y->where);
return &gfc_bad_expr;
}
@@ -2151,6 +2155,250 @@ gfc_simplify_cosh (gfc_expr *x)
return range_check (result, "COSH");
}
+gfc_expr *
+gfc_simplify_acospi (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0)
+ {
+ gfc_error (
+ "Argument of ACOSPI at %L must be within the closed interval [-1, 1]",
+ &x->where);
+ return &gfc_bad_expr;
+ }
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0)
+ mpfr_acospi (result->value.real, x->value.real, GFC_RND_MODE);
+#else
+ mpfr_t pi, tmp;
+ mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL);
+ mpfr_const_pi (pi, GFC_RND_MODE);
+ mpfr_acos (tmp, x->value.real, GFC_RND_MODE);
+ mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE);
+ mpfr_clears (pi, tmp, NULL);
+#endif
+
+ return result;
+}
+
+gfc_expr *
+gfc_simplify_asinpi (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0)
+ {
+ gfc_error (
+ "Argument of ASINPI at %L must be within the closed interval [-1, 1]",
+ &x->where);
+ return &gfc_bad_expr;
+ }
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0)
+ mpfr_asinpi (result->value.real, x->value.real, GFC_RND_MODE);
+#else
+ mpfr_t pi, tmp;
+ mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL);
+ mpfr_const_pi (pi, GFC_RND_MODE);
+ mpfr_asin (tmp, x->value.real, GFC_RND_MODE);
+ mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE);
+ mpfr_clears (pi, tmp, NULL);
+#endif
+
+ return result;
+}
+
+gfc_expr *
+gfc_simplify_atanpi (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0)
+ mpfr_atanpi (result->value.real, x->value.real, GFC_RND_MODE);
+#else
+ mpfr_t pi, tmp;
+ mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL);
+ mpfr_const_pi (pi, GFC_RND_MODE);
+ mpfr_atan (tmp, x->value.real, GFC_RND_MODE);
+ mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE);
+ mpfr_clears (pi, tmp, NULL);
+#endif
+
+ return range_check (result, "ATANPI");
+}
+
+gfc_expr *
+gfc_simplify_atan2pi (gfc_expr *y, gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
+ {
+ gfc_error ("If the first argument of ATAN2PI at %L is zero, then the "
+ "second argument must not be zero",
+ &y->where);
+ return &gfc_bad_expr;
+ }
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0)
+ mpfr_atan2pi (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
+#else
+ mpfr_t pi, tmp;
+ mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL);
+ mpfr_const_pi (pi, GFC_RND_MODE);
+ mpfr_atan2 (tmp, y->value.real, x->value.real, GFC_RND_MODE);
+ mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE);
+ mpfr_clears (pi, tmp, NULL);
+#endif
+
+ return range_check (result, "ATAN2PI");
+}
+
+gfc_expr *
+gfc_simplify_cospi (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0)
+ mpfr_cospi (result->value.real, x->value.real, GFC_RND_MODE);
+#else
+ mpfr_t cs, n, r, two;
+ int s;
+
+ mpfr_inits2 (2 * mpfr_get_prec (x->value.real), cs, n, r, two, NULL);
+
+ mpfr_abs (r, x->value.real, GFC_RND_MODE);
+ mpfr_modf (n, r, r, GFC_RND_MODE);
+
+ if (mpfr_cmp_d (r, 0.5) == 0)
+ {
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+ return result;
+ }
+
+ mpfr_set_ui (two, 2, GFC_RND_MODE);
+ mpfr_fmod (cs, n, two, GFC_RND_MODE);
+ s = mpfr_cmp_ui (cs, 0) == 0 ? 1 : -1;
+
+ mpfr_const_pi (cs, GFC_RND_MODE);
+ mpfr_mul (cs, cs, r, GFC_RND_MODE);
+ mpfr_cos (cs, cs, GFC_RND_MODE);
+ mpfr_mul_si (result->value.real, cs, s, GFC_RND_MODE);
+
+ mpfr_clears (cs, n, r, two, NULL);
+#endif
+
+ return range_check (result, "COSPI");
+}
+
+gfc_expr *
+gfc_simplify_sinpi (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0)
+ mpfr_sinpi (result->value.real, x->value.real, GFC_RND_MODE);
+#else
+ mpfr_t sn, n, r, two;
+ int s;
+
+ mpfr_inits2 (2 * mpfr_get_prec (x->value.real), sn, n, r, two, NULL);
+
+ mpfr_abs (r, x->value.real, GFC_RND_MODE);
+ mpfr_modf (n, r, r, GFC_RND_MODE);
+
+ if (mpfr_cmp_d (r, 0.0) == 0)
+ {
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+ return result;
+ }
+
+ mpfr_set_ui (two, 2, GFC_RND_MODE);
+ mpfr_fmod (sn, n, two, GFC_RND_MODE);
+ s = mpfr_cmp_si (x->value.real, 0) < 0 ? -1 : 1;
+ s *= mpfr_cmp_ui (sn, 0) == 0 ? 1 : -1;
+
+ mpfr_const_pi (sn, GFC_RND_MODE);
+ mpfr_mul (sn, sn, r, GFC_RND_MODE);
+ mpfr_sin (sn, sn, GFC_RND_MODE);
+ mpfr_mul_si (result->value.real, sn, s, GFC_RND_MODE);
+
+ mpfr_clears (sn, n, r, two, NULL);
+#endif
+
+ return range_check (result, "SINPI");
+}
+
+gfc_expr *
+gfc_simplify_tanpi (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0)
+ mpfr_tanpi (result->value.real, x->value.real, GFC_RND_MODE);
+#else
+ mpfr_t tn, n, r;
+ int s;
+
+ mpfr_inits2 (2 * mpfr_get_prec (x->value.real), tn, n, r, NULL);
+
+ mpfr_abs (r, x->value.real, GFC_RND_MODE);
+ mpfr_modf (n, r, r, GFC_RND_MODE);
+
+ if (mpfr_cmp_d (r, 0.0) == 0)
+ {
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+ return result;
+ }
+
+ s = mpfr_cmp_si (x->value.real, 0) < 0 ? -1 : 1;
+
+ mpfr_const_pi (tn, GFC_RND_MODE);
+ mpfr_mul (tn, tn, r, GFC_RND_MODE);
+ mpfr_tan (tn, tn, GFC_RND_MODE);
+ mpfr_mul_si (result->value.real, tn, s, GFC_RND_MODE);
+
+ mpfr_clears (tn, n, r, NULL);
+#endif
+
+ return range_check (result, "TANPI");
+}
gfc_expr *
gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 9606131..3d27443 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -12067,8 +12067,16 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
&& !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
{
if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy)
- gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
- build_zero_cst (TREE_TYPE (sym->ts.u.cl->backend_decl)));
+ {
+ tree len_expr = sym->ts.u.cl->backend_decl;
+ tree init_val = build_zero_cst (TREE_TYPE (len_expr));
+ if (VAR_P (len_expr)
+ && sym->attr.save
+ && !DECL_INITIAL (len_expr))
+ DECL_INITIAL (len_expr) = init_val;
+ else
+ gfc_add_modify (&init, len_expr, init_val);
+ }
gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
gfc_trans_vla_type_sizes (sym, &init);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 8d9448e..c8a2076 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -2782,9 +2782,11 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
start.expr = gfc_evaluate_now (start.expr, &se->pre);
/* Change the start of the string. */
- if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
- || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
- && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
+ if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
+ || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
+ && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
+ || (POINTER_TYPE_P (TREE_TYPE (se->expr))
+ && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE))
tmp = se->expr;
else
tmp = build_fold_indirect_ref_loc (input_location,
@@ -2795,6 +2797,14 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
se->expr = gfc_build_addr_expr (type, tmp);
}
+ else if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+ {
+ tree diff;
+ diff = fold_build2 (MINUS_EXPR, size_type_node, start.expr,
+ build_one_cst (size_type_node));
+ se->expr
+ = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp, diff);
+ }
}
/* Length = end + 1 - start. */
@@ -4625,6 +4635,16 @@ get_builtin_fn (gfc_symbol * sym)
&& !strcmp (sym->name, "omp_is_initial_device"))
return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE);
+ if (!gfc_option.disable_omp_get_initial_device
+ && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
+ && !strcmp (sym->name, "omp_get_initial_device"))
+ return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE);
+
+ if (!gfc_option.disable_omp_get_num_devices
+ && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
+ && !strcmp (sym->name, "omp_get_num_devices"))
+ return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES);
+
if (!gfc_option.disable_acc_on_device
&& flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL
&& !strcmp (sym->name, "acc_on_device_h"))
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 0b8150f..2a48d4a 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -2478,6 +2478,26 @@ gfc_omp_deep_mapping_do (bool is_cnt, const gimple *ctx, tree clause,
else
while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF)
tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
+ if (TREE_CODE (tmp) == MEM_REF)
+ tmp = TREE_OPERAND (tmp, 0);
+ if (TREE_CODE (tmp) == SSA_NAME)
+ {
+ gimple *def_stmt = SSA_NAME_DEF_STMT (tmp);
+ if (gimple_code (def_stmt) == GIMPLE_ASSIGN)
+ {
+ tmp = gimple_assign_rhs1 (def_stmt);
+ if (poly)
+ {
+ tmp = TYPE_FIELDS (type);
+ type = TREE_TYPE (tmp);
+ }
+ else
+ while (TREE_CODE (tmp) == COMPONENT_REF
+ || TREE_CODE (tmp) == ARRAY_REF)
+ tmp = TREE_OPERAND (tmp,
+ TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
+ }
+ }
/* If the clause argument is nonallocatable, skip is-allocate check. */
if (GFC_DECL_GET_SCALAR_ALLOCATABLE (tmp)
|| GFC_DECL_GET_SCALAR_POINTER (tmp)
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index f898075..e15b1bb 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -3231,13 +3231,14 @@ gfc_return_by_reference (gfc_symbol * sym)
/* Possibly return complex numbers by reference for g77 compatibility.
We don't do this for calls to intrinsics (as the library uses the
- -fno-f2c calling convention), nor for calls to functions which always
+ -fno-f2c calling convention) except for calls to specific wrappers
+ (_gfortran_f2c_specific_*), nor for calls to functions which always
require an explicit interface, as no compatibility problems can
arise there. */
if (flag_f2c && sym->ts.type == BT_COMPLEX
&& !sym->attr.pointer
&& !sym->attr.allocatable
- && !sym->attr.intrinsic && !sym->attr.always_explicit)
+ && !sym->attr.always_explicit)
return 1;
return 0;
generated by cgit v1.1 at 2025-07-01 08:23:49 +0000