aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog17
-rw-r--r--gcc/fortran/check.cc42
-rw-r--r--gcc/fortran/interface.cc135
-rw-r--r--gcc/fortran/primary.cc2
4 files changed, 117 insertions, 79 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f87c64b..e6d9fa6 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,20 @@
+2025-05-06 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ PR fortran/120049
+ * check.cc (gfc_check_c_associated): Modify checks to avoid
+ ICE and allow use, intrinsic :: iso_c_binding from a separate
+ module file.
+
+2025-05-06 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/119928
+ * interface.cc (gfc_check_dummy_characteristics): Do not issue
+ error if one dummy symbol has been generated from an actual
+ argument and the other one has OPTIONAL, INTENT, ALLOCATABLE,
+ POINTER, TARGET, VALUE, ASYNCHRONOUS or CONTIGUOUS.
+ (gfc_get_formal_from_actual_arglist): Do nothing if symbol
+ is a class.
+
2025-05-04 Harald Anlauf <anlauf@gmx.de>
PR fortran/119986
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 299c216..f02a2a3 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -5955,30 +5955,40 @@ gfc_check_c_sizeof (gfc_expr *arg)
bool
gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
{
- 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))
+ if (c_ptr_1)
{
- 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->expr_type == EXPR_FUNCTION && c_ptr_1->ts.type == BT_VOID)
+ 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 (!scalar_check (c_ptr_1, 0))
return false;
- if (c_ptr_2
- && (c_ptr_2->ts.type != BT_DERIVED
+ if (c_ptr_2)
+ {
+ if (c_ptr_2->expr_type == EXPR_FUNCTION && c_ptr_2->ts.type == BT_VOID)
+ return true;
+
+ 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_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;
+ != c_ptr_2->ts.u.derived->intmod_sym_id))
+ {
+ 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_2 && !scalar_check (c_ptr_2, 1))
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 1e552a3..753f589 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -1403,77 +1403,82 @@ gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
}
}
- /* Check INTENT. */
- if (s1->attr.intent != s2->attr.intent && !s1->attr.artificial
- && !s2->attr.artificial)
- {
- snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* A lot of information is missing for artificially generated
+ formal arguments, let's not look into that. */
- /* Check OPTIONAL attribute. */
- if (s1->attr.optional != s2->attr.optional)
+ if (!s1->attr.artificial && !s2->attr.artificial)
{
- snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* Check INTENT. */
+ if (s1->attr.intent != s2->attr.intent)
+ {
+ snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
- /* Check ALLOCATABLE attribute. */
- if (s1->attr.allocatable != s2->attr.allocatable)
- {
- snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* Check OPTIONAL attribute. */
+ if (s1->attr.optional != s2->attr.optional)
+ {
+ snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
- /* Check POINTER attribute. */
- if (s1->attr.pointer != s2->attr.pointer)
- {
- snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* Check ALLOCATABLE attribute. */
+ if (s1->attr.allocatable != s2->attr.allocatable)
+ {
+ snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
- /* Check TARGET attribute. */
- if (s1->attr.target != s2->attr.target)
- {
- snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* Check POINTER attribute. */
+ if (s1->attr.pointer != s2->attr.pointer)
+ {
+ snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
- /* Check ASYNCHRONOUS attribute. */
- if (s1->attr.asynchronous != s2->attr.asynchronous)
- {
- snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* Check TARGET attribute. */
+ if (s1->attr.target != s2->attr.target)
+ {
+ snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
- /* Check CONTIGUOUS attribute. */
- if (s1->attr.contiguous != s2->attr.contiguous)
- {
- snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* Check ASYNCHRONOUS attribute. */
+ if (s1->attr.asynchronous != s2->attr.asynchronous)
+ {
+ snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
- /* Check VALUE attribute. */
- if (s1->attr.value != s2->attr.value)
- {
- snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'",
- s1->name);
- return false;
- }
+ /* Check CONTIGUOUS attribute. */
+ if (s1->attr.contiguous != s2->attr.contiguous)
+ {
+ snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
- /* Check VOLATILE attribute. */
- if (s1->attr.volatile_ != s2->attr.volatile_)
- {
- snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'",
- s1->name);
- return false;
+ /* Check VALUE attribute. */
+ if (s1->attr.value != s2->attr.value)
+ {
+ snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
+
+ /* Check VOLATILE attribute. */
+ if (s1->attr.volatile_ != s2->attr.volatile_)
+ {
+ snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
}
/* Check interface of dummy procedures. */
@@ -5849,6 +5854,12 @@ gfc_get_formal_from_actual_arglist (gfc_symbol *sym,
char name[GFC_MAX_SYMBOL_LEN + 1];
static int var_num;
+ /* Do not infer the formal from actual arguments if we are dealing with
+ classes. */
+
+ if (sym->ts.type == BT_CLASS)
+ return;
+
f = &sym->formal;
for (a = actual_args; a != NULL; a = a->next)
{
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 72ecc7c..ec4e135 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -4396,7 +4396,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
case FL_PROCEDURE:
/* Check for a nonrecursive function result variable. */
if (sym->attr.function
- && !sym->attr.external
+ && (!sym->attr.external || sym->abr_modproc_decl)
&& sym->result == sym
&& (gfc_is_function_return_value (sym, gfc_current_ns)
|| (sym->attr.entry
generated by cgit v1.1 at 2025-05-08 06:07:48 +0000