aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog102
-rw-r--r--gcc/fortran/check.cc125
-rw-r--r--gcc/fortran/error.cc3
-rw-r--r--gcc/fortran/expr.cc110
-rw-r--r--gcc/fortran/gfortran.h8
-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/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/parse.cc3
-rw-r--r--gcc/fortran/primary.cc64
-rw-r--r--gcc/fortran/simplify.cc264
15 files changed, 762 insertions, 110 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f0d4e2c..e740ecc 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,105 @@
+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
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index f02a2a3..c8904df 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 (!scalar_check (c_ptr_1, 0))
+ 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))
+ 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 && !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 (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);
}
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/gfortran.h b/gcc/fortran/gfortran.h
index 4740c36..e461aa6 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
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/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/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/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)
generated by cgit v1.1 at 2025-05-31 21:45:39 +0000