aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog74
-rw-r--r--gcc/fortran/gfortran.h1
-rw-r--r--gcc/fortran/intrinsic.texi2
-rw-r--r--gcc/fortran/parse.cc28
-rw-r--r--gcc/fortran/parse.h3
-rw-r--r--gcc/fortran/primary.cc35
-rw-r--r--gcc/fortran/resolve.cc50
-rw-r--r--gcc/fortran/symbol.cc79
-rw-r--r--gcc/fortran/trans-array.cc8
-rw-r--r--gcc/fortran/trans-intrinsic.cc8
10 files changed, 251 insertions, 37 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index cee5ef4..bee1d2b 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,77 @@
+2025-11-04 Harald Anlauf <anlauf@gmx.de>
+
+ PR fortran/122564
+ * resolve.cc (resolve_locality_spec): Delete temporary hash_set.
+
+2025-11-04 Paul-Antoine Arras <parras@baylibre.com>
+
+ PR fortran/122369
+ PR fortran/122508
+ * gfortran.h (gfc_rebind_label): Declare new function.
+ * parse.cc (parse_omp_metadirective_body): Rebind labels to the outer
+ region. Maintain a vector of metadirective regions.
+ (gfc_parse_file): Initialise it.
+ * parse.h (GFC_PARSE_H): Declare it.
+ * symbol.cc (gfc_get_st_label): Look for existing labels in outer
+ metadirective regions.
+ (gfc_rebind_label): Define new function.
+ (gfc_define_st_label): Accept duplicate labels in metadirective body.
+ (gfc_reference_st_label): Accept shared DO termination labels in
+ metadirective body.
+
+2025-11-03 Steve Kargl <kargls@comcast.net>
+
+ PR fortran/122513
+ * resolve.cc (check_default_none_expr): Do not allow an
+ iterator in a locality spec. Allow a named constant to be
+ used within the loop.
+
+2025-11-01 Harald Anlauf <anlauf@gmx.de>
+
+ PR fortran/78640
+ * resolve.cc (resolve_fl_procedure): Check function result of a
+ pure function against F2018:C1585.
+
+2025-10-31 Yuao Ma <c8ef@outlook.com>
+
+ * intrinsic.texi: Fix typo.
+ * trans-intrinsic.cc (conv_intrinsic_atomic_cas): Remove unreachable
+ code.
+
+2025-10-31 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/122452
+ * primary.cc (gfc_match_rvalue): Give priority to specific
+ procedures in a generic interface with the same name as a
+ PDT template. If found, use as the procedure instead of the
+ constructor generated from the PDT template.
+
+2025-10-30 Mikael Morin <mikael@gcc.gnu.org>
+
+ * trans-array.cc: Cleanup obsolete comment.
+
+2025-10-29 Yuao Ma <c8ef@outlook.com>
+
+ * trans-expr.cc (gfc_conv_gfc_desc_to_cfi_desc): Remove unreachable
+ code.
+
+2025-10-29 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/122165
+ * primary.cc (gfc_match_varspec): If the previous component ref
+ was a type specification parameter, a type inquiry ref cannot
+ follow.
+
+2025-10-29 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/122433
+ PR fortran/122434
+ * decl.cc (gfc_get_pdt_instance): Prevent a PDT component of
+ the same type as the template from being converted into an
+ instance.
+ * resolve.cc (gfc_impure_variable): The result of a pure
+ function is a valid allocate object since it is pure.
+
2025-10-28 Yuao Ma <c8ef@outlook.com>
PR fortran/122342
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 19473df..f1c4db2 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3760,6 +3760,7 @@ gfc_st_label *gfc_get_st_label (int);
void gfc_free_st_label (gfc_st_label *);
void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *);
bool gfc_reference_st_label (gfc_st_label *, gfc_sl_type);
+gfc_st_label *gfc_rebind_label (gfc_st_label *, int);
gfc_namespace *gfc_get_namespace (gfc_namespace *, int);
gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 9012c2a..b2d1e45 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -2239,7 +2239,7 @@ is different, the value is converted to the kind of @var{ATOM}.
program atomic
use iso_fortran_env
logical(atomic_logical_kind) :: atom[*], prev
- call atomic_cas (atom[1], prev, .false., .true.))
+ call atomic_cas (atom[1], prev, .false., .true.)
end program atomic
@end smallexample
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index b29f690..f987f46 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -60,6 +60,7 @@ bool gfc_in_omp_metadirective_body;
/* Each metadirective body in the translation unit is given a unique
number, used to ensure that labels in the body have unique names. */
int gfc_omp_metadirective_region_count;
+vec<int> gfc_omp_metadirective_region_stack;
/* TODO: Re-order functions to kill these forward decls. */
static void check_statement_label (gfc_statement);
@@ -6542,6 +6543,9 @@ parse_omp_metadirective_body (gfc_statement omp_st)
gfc_in_omp_metadirective_body = true;
gfc_omp_metadirective_region_count++;
+ gfc_omp_metadirective_region_stack.safe_push (
+ gfc_omp_metadirective_region_count);
+
switch (variant->stmt)
{
case_omp_structured_block:
@@ -6603,6 +6607,28 @@ parse_omp_metadirective_body (gfc_statement omp_st)
*variant->code = *gfc_state_stack->head;
pop_state ();
+ gfc_omp_metadirective_region_stack.pop ();
+ int outer_omp_metadirective_region
+ = gfc_omp_metadirective_region_stack.last ();
+
+ /* Rebind labels in the last statement -- which is the first statement
+ past the end of the metadirective body -- to the outer region. */
+ if (gfc_statement_label)
+ gfc_statement_label = gfc_rebind_label (gfc_statement_label,
+ outer_omp_metadirective_region);
+ if ((new_st.op == EXEC_READ || new_st.op == EXEC_WRITE)
+ && new_st.ext.dt->format_label
+ && new_st.ext.dt->format_label != &format_asterisk)
+ new_st.ext.dt->format_label
+ = gfc_rebind_label (new_st.ext.dt->format_label,
+ outer_omp_metadirective_region);
+ if (new_st.label1)
+ new_st.label1
+ = gfc_rebind_label (new_st.label1, outer_omp_metadirective_region);
+ if (new_st.here)
+ new_st.here
+ = gfc_rebind_label (new_st.here, outer_omp_metadirective_region);
+
gfc_commit_symbols ();
gfc_warning_check ();
if (variant->next)
@@ -7578,6 +7604,8 @@ gfc_parse_file (void)
gfc_statement_label = NULL;
gfc_omp_metadirective_region_count = 0;
+ gfc_omp_metadirective_region_stack.truncate (0);
+ gfc_omp_metadirective_region_stack.safe_push (0);
gfc_in_omp_metadirective_body = false;
gfc_matching_omp_context_selector = false;
diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h
index 7bf0fa4..70ffcbd 100644
--- a/gcc/fortran/parse.h
+++ b/gcc/fortran/parse.h
@@ -22,6 +22,8 @@ along with GCC; see the file COPYING3. If not see
#ifndef GFC_PARSE_H
#define GFC_PARSE_H
+#include "vec.h"
+
/* Enum for what the compiler is currently doing. */
enum gfc_compile_state
{
@@ -76,6 +78,7 @@ extern bool gfc_matching_function;
extern bool gfc_matching_omp_context_selector;
extern bool gfc_in_omp_metadirective_body;
extern int gfc_omp_metadirective_region_count;
+extern vec<int> gfc_omp_metadirective_region_stack;
match gfc_match_prefix (gfc_typespec *);
bool is_oacc (gfc_state_data *);
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 0722c76d..1dcb1c3 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -3835,6 +3835,9 @@ gfc_match_rvalue (gfc_expr **result)
gfc_typespec *ts;
bool implicit_char;
gfc_ref *ref;
+ gfc_symtree *pdt_st;
+ gfc_symbol *found_specific = NULL;
+
m = gfc_match ("%%loc");
if (m == MATCH_YES)
@@ -4082,22 +4085,36 @@ gfc_match_rvalue (gfc_expr **result)
break;
}
+ gfc_gobble_whitespace ();
+ found_specific = NULL;
+
+ /* Even if 'name' is that of a PDT template, priority has to be given to
+ possible specific procedures in the generic interface. */
+ gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st);
+ if (sym->generic && sym->generic->next
+ && gfc_peek_ascii_char() != '(')
+ {
+ gfc_actual_arglist *arg = actual_arglist;
+ for (; arg && pdt_st; arg = arg->next)
+ gfc_resolve_expr (arg->expr);
+ found_specific = gfc_search_interface (sym->generic, 0,
+ &actual_arglist);
+ }
+
/* Check to see if this is a PDT constructor. The format of these
constructors is rather unusual:
name [(type_params)](component_values)
where, component_values excludes the type_params. With the present
gfortran representation this is rather awkward because the two are not
distinguished, other than by their attributes. */
- if (sym->attr.generic)
+ if (sym->attr.generic && pdt_st != NULL && found_specific == NULL)
{
- gfc_symtree *pdt_st;
gfc_symbol *pdt_sym;
gfc_actual_arglist *ctr_arglist = NULL, *tmp;
gfc_component *c;
- /* Obtain the template. */
- gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st);
- if (pdt_st && pdt_st->n.sym && pdt_st->n.sym->attr.pdt_template)
+ /* Use the template. */
+ if (pdt_st->n.sym && pdt_st->n.sym->attr.pdt_template)
{
bool type_spec_list = false;
pdt_sym = pdt_st->n.sym;
@@ -4155,8 +4172,12 @@ gfc_match_rvalue (gfc_expr **result)
tmp = tmp->next;
}
- gfc_find_sym_tree (gfc_dt_lower_string (pdt_sym->name),
- NULL, 1, &symtree);
+ if (found_specific)
+ gfc_find_sym_tree (found_specific->name,
+ NULL, 1, &symtree);
+ else
+ gfc_find_sym_tree (gfc_dt_lower_string (pdt_sym->name),
+ NULL, 1, &symtree);
if (!symtree)
{
gfc_get_ha_sym_tree (gfc_dt_lower_string (pdt_sym->name) ,
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index ecd2ada..2a73f2a 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -8461,7 +8461,20 @@ check_default_none_expr (gfc_expr **e, int *, void *data)
break;
ns2 = ns2->parent;
}
- if (ns2 != NULL)
+
+ /* A DO CONCURRENT iterator cannot appear in a locality spec. */
+ if (sym->ns->code->ext.concur.forall_iterator)
+ {
+ gfc_forall_iterator *iter
+ = sym->ns->code->ext.concur.forall_iterator;
+ for (; iter; iter = iter->next)
+ if (iter->var->symtree
+ && strcmp(sym->name, iter->var->symtree->name) == 0)
+ return 0;
+ }
+
+ /* A named constant is not a variable, so skip test. */
+ if (ns2 != NULL && sym->attr.flavor != FL_PARAMETER)
{
gfc_error ("Variable %qs at %L not specified in a locality spec "
"of DO CONCURRENT at %L but required due to "
@@ -8741,6 +8754,8 @@ resolve_locality_spec (gfc_code *code, gfc_namespace *ns)
plist = &((*plist)->next);
}
}
+
+ delete data.sym_hash;
}
/* Resolve a list of FORALL iterators. The FORALL index-name is constrained
@@ -15385,6 +15400,39 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
return false;
}
+ /* F2018:C1585: "The function result of a pure function shall not be both
+ polymorphic and allocatable, or have a polymorphic allocatable ultimate
+ component." */
+ if (sym->attr.pure && sym->result && sym->ts.u.derived)
+ {
+ if (sym->ts.type == BT_CLASS
+ && sym->attr.class_ok
+ && CLASS_DATA (sym->result)
+ && CLASS_DATA (sym->result)->attr.allocatable)
+ {
+ gfc_error ("Result variable %qs of pure function at %L is "
+ "polymorphic allocatable",
+ sym->result->name, &sym->result->declared_at);
+ return false;
+ }
+
+ if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components)
+ {
+ gfc_component *c = sym->ts.u.derived->components;
+ for (; c; c = c->next)
+ if (c->ts.type == BT_CLASS
+ && CLASS_DATA (c)
+ && CLASS_DATA (c)->attr.allocatable)
+ {
+ gfc_error ("Result variable %qs of pure function at %L has "
+ "polymorphic allocatable component %qs",
+ sym->result->name, &sym->result->declared_at,
+ c->name);
+ return false;
+ }
+ }
+ }
+
if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
{
gfc_formal_arglist *curr_arg;
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 8211d92..b4d3ed6 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -2753,8 +2753,7 @@ gfc_get_st_label (int labelno)
{
gfc_st_label *lp;
gfc_namespace *ns;
- int omp_region = (gfc_in_omp_metadirective_body
- ? gfc_omp_metadirective_region_count : 0);
+ int omp_region = gfc_omp_metadirective_region_stack.last ();
if (gfc_current_state () == COMP_DERIVED)
ns = gfc_current_block ()->f2k_derived;
@@ -2768,22 +2767,28 @@ gfc_get_st_label (int labelno)
}
/* First see if the label is already in this namespace. */
- lp = ns->st_labels;
- while (lp)
+ gcc_checking_assert (gfc_omp_metadirective_region_stack.length () > 0);
+ for (int omp_region_idx = gfc_omp_metadirective_region_stack.length () - 1;
+ omp_region_idx >= 0; omp_region_idx--)
{
- if (lp->omp_region == omp_region)
+ int omp_region2 = gfc_omp_metadirective_region_stack[omp_region_idx];
+ lp = ns->st_labels;
+ while (lp)
{
- if (lp->value == labelno)
- return lp;
- if (lp->value < labelno)
+ if (lp->omp_region == omp_region2)
+ {
+ if (lp->value == labelno)
+ return lp;
+ if (lp->value < labelno)
+ lp = lp->left;
+ else
+ lp = lp->right;
+ }
+ else if (lp->omp_region < omp_region2)
lp = lp->left;
else
lp = lp->right;
}
- else if (lp->omp_region < omp_region)
- lp = lp->left;
- else
- lp = lp->right;
}
lp = XCNEW (gfc_st_label);
@@ -2799,6 +2804,53 @@ gfc_get_st_label (int labelno)
return lp;
}
+/* Rebind a statement label to a new OpenMP region. If a label with the same
+ value already exists in the new region, update it and return it. Otherwise,
+ move the label to the new region. */
+
+gfc_st_label *
+gfc_rebind_label (gfc_st_label *label, int new_omp_region)
+{
+ gfc_st_label *lp = label->ns->st_labels;
+ int labelno = label->value;
+
+ while (lp)
+ {
+ if (lp->omp_region == new_omp_region)
+ {
+ if (lp->value == labelno)
+ {
+ if (lp == label)
+ return label;
+ if (lp->defined == ST_LABEL_UNKNOWN
+ && label->defined != ST_LABEL_UNKNOWN)
+ lp->defined = label->defined;
+ if (lp->referenced == ST_LABEL_UNKNOWN
+ && label->referenced != ST_LABEL_UNKNOWN)
+ lp->referenced = label->referenced;
+ if (lp->format == NULL && label->format != NULL)
+ lp->format = label->format;
+ gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels);
+ return lp;
+ }
+ if (lp->value < labelno)
+ lp = lp->left;
+ else
+ lp = lp->right;
+ }
+ else if (lp->omp_region < new_omp_region)
+ lp = lp->left;
+ else
+ lp = lp->right;
+ }
+
+ gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels);
+ label->left = nullptr;
+ label->right = nullptr;
+ label->omp_region = new_omp_region;
+ gfc_insert_bbt (&label->ns->st_labels, label, compare_st_labels);
+ return label;
+}
/* Called when a statement with a statement label is about to be
accepted. We add the label to the list of the current namespace,
@@ -2812,7 +2864,7 @@ gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
labelno = lp->value;
- if (lp->defined != ST_LABEL_UNKNOWN)
+ if (lp->defined != ST_LABEL_UNKNOWN && !gfc_in_omp_metadirective_body)
gfc_error ("Duplicate statement label %d at %L and %L", labelno,
&lp->where, label_locus);
else
@@ -2897,6 +2949,7 @@ gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
}
if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
+ && !gfc_in_omp_metadirective_body
&& !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
"Shared DO termination label %d at %C", labelno))
return false;
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index e2b17a7..cb40816 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -268,13 +268,7 @@ gfc_conv_descriptor_data_get (tree desc)
return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field);
}
-/* This provides WRITE access to the data field.
-
- TUPLES_P is true if we are generating tuples.
-
- This function gets called through the following macros:
- gfc_conv_descriptor_data_set
- gfc_conv_descriptor_data_set. */
+/* This provides WRITE access to the data field. */
void
gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 89a03d8..5b9111d3 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -12844,14 +12844,6 @@ conv_intrinsic_atomic_cas (gfc_code *code)
new_val = gfc_build_addr_expr (NULL_TREE, tmp);
}
- /* Convert a constant to a pointer. */
- if (!POINTER_TYPE_P (TREE_TYPE (comp)))
- {
- tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "comp");
- gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), comp));
- comp = gfc_build_addr_expr (NULL_TREE, tmp);
- }
-
gfc_init_se (&argse, NULL);
gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
atom_expr);
generated by cgit v1.1 at 2025-11-05 13:34:30 +0000