diff options
Diffstat (limited to 'gcc/fortran/check.cc')
| -rw-r--r-- | gcc/fortran/check.cc | 42 |
1 files changed, 26 insertions, 16 deletions
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)) |