Hello all,
The attached patch revises the logic of the checks in
gfc_check_c_associated to handle previous cases that ICE'ed as seen in
the PR. There are multiple gotchas in these cases, particularly with the
optional c_ptr_2 argument.
I factored the logic into two new helper functions. This helps to see
what is happening and allows the c_ptr_1 checks to be performed
separately in the event the c_ptr_2 checks succeed.
In gfc_typename we did not handle the BT_VOID case which occurs in some
of the error conditions. I thought to possibly let it fall through to
"UNKNOWN". As it is with the patch I return "VOID".
I added a new test case.
I want to add Steve as Co-author as soon as I figure out how to do that
with the git machinery.
Regression tested on x86_64. OK for trunk and eventual backport to 15?
Regards,
Jerry
Author: Jerry DeLisle <jvdeli...@gcc.gnu.org>
Date: Sat May 17 09:45:14 2025 -0700
Fortran: Fix c_associated argument checks.
PR fortran/120049
gcc/fortran/ChangeLog:
* 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 handles 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.
gcc/testsuite/ChangeLog:
* gfortran.dg/pr120049_2.f90: New test.
commit a8ecfef37b221fc828ab8a91793fbdef3c56509b
Author: Jerry DeLisle <jvdeli...@gcc.gnu.org>
Date: Sat May 17 09:45:14 2025 -0700
Fortran: Fix c_associated argument checks.
PR fortran/120049
gcc/fortran/ChangeLog:
* 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 handles 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.
gcc/testsuite/ChangeLog:
* gfortran.dg/pr120049_2.f90: New test.
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index f02a2a33897..ab2828b0f70 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -5952,49 +5952,79 @@ 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->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 (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 (scalar_check (c_ptr_1, 0))
+ return true;
- if (c_ptr_2)
+ return false;
+}
+
+static inline
+bool check_c_ptr_2 (gfc_expr *c_ptr_1, gfc_expr *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)
{
- if (c_ptr_2->expr_type == EXPR_FUNCTION && c_ptr_2->ts.type == BT_VOID)
- return true;
+ if (c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING)
+ goto check_2_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
+ 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))
- {
- 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;
- }
+ goto check_2_error;
}
+ else
+ 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: %s instead of %s", &c_ptr_2->where,
+ gfc_typename (&c_ptr_1->ts), gfc_typename (&c_ptr_2->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/misc.cc b/gcc/fortran/misc.cc
index 893c40fbba2..b8bdf7578de 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/testsuite/gfortran.dg/pr120049_2.f90 b/gcc/testsuite/gfortran.dg/pr120049_2.f90
new file mode 100644
index 00000000000..6c74405abd6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr120049_2.f90
@@ -0,0 +1,53 @@
+! { dg-do compile }
+!
+! Test the fix for PR120049
+program tests_gtk_sup
+ use, intrinsic :: iso_c_binding
+ implicit none
+
+ type mytype
+ integer :: myint
+ end type mytype
+ type(mytype) :: ijkl = mytype(42)
+ logical :: truth
+ real :: var1
+ type(c_ptr), target :: val
+ character(15) :: stringy
+ complex :: certainly
+ truth = .true.
+ var1 = 86.
+ stringy = "what the hay!"
+ certainly = (3.14,-4.13)
+ if (c_associated(val, c_loc(val))) then
+ stop 1
+ endif
+ if (c_associated(c_loc(val), val)) then
+ stop 2
+ endif
+ print *, c_associated(c_loc(val), 42) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(c_loc(val), .42) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(c_loc(val), truth) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(c_loc(val), .false.) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(c_loc(val), var1) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(c_loc(val), stringy) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(c_loc(val), certainly) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(42) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(.42) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(truth) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(.false.) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(var1) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(stringy) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(certainly) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(.42) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(val, testit(val)) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(testit(val), val) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(testit(val)) ! { dg-error "C_ASSOCIATED shall have the" }
+contains
+
+ function testit (avalue) result(res)
+ type(c_ptr) :: avalue
+ type(mytype) :: res
+ res%myint = 42
+ end function
+
+end program tests_gtk_sup
