On 5/19/25 1:50 PM, Harald Anlauf wrote:
Hi Jerry,
so contrary to what the name of patch claims (pr120049-final.diff),
it fixes only the case of direct use of iso_c_binding, but not the
indirect one thru the other module, which is the reason for the
original ICE and the PR.
So if you want to push the incremental patch now, go ahead.
Cheers,
Harald
Am 18.05.25 um 23:46 schrieb Jerry D:
On 5/18/25 2:34 PM, Jerry D wrote:
On 5/18/25 2:10 PM, Harald Anlauf wrote:
Hi Jerry,
I found 2 corner invalid cases which are silently accepted with
your patch when iso_c_binding is used indirectly:
print *, c_associated(c_loc(val), C_NULL_FUNPTR)
print *, c_associated(C_NULL_FUNPTR, c_loc(val))
These should get rejected, too. Can you see how to catch these, too?
Thanks,
Harald
Yes, will do! I try to think of cases to run through on. This helps.
Thanks,
Jerry
--- snip ---
Attached is the revised patch to fix the additional test cases. I had to
do some trial and error to get the testsuite directives to work the way
they should.
One will notice that the file containing the gtk_sup module is
simplified and gets taken care of with the directives in the specific tests.
Regression tested on x86_64.
OK for trunk?
-- Jerry
commit d58968361cbe3131bddb5c322d72858bc6d9e09a
Author: Jerry DeLisle <jvdeli...@gcc.gnu.org>
Date: Mon May 19 19:41:16 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 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.
gcc/testsuite/ChangeLog:
* gfortran.dg/pr120049_a.f90: Update test directives.
* gfortran.dg/pr120049_b.f90: Update test directives
* gfortran.dg/pr120049_2.f90: New test.
Co--Authored-By: Steve Kargl <ka...@gcc.gnu.org>
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index f02a2a33897..35537dfcf65 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -5952,49 +5952,96 @@ 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 ((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))
+ 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)
+check_1_error:
+
+ 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)
+{
+ if ((c_ptr_1->ts.type == BT_DERIVED)
+ && (c_ptr_1->expr_type == EXPR_STRUCTURE))
+ goto check_2_error;
+
+ if ((c_ptr_2->ts.type == BT_VOID)
+ && (c_ptr_2->expr_type == EXPR_FUNCTION))
+ 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;
+
+ if (c_ptr_2->expr_type == EXPR_STRUCTURE)
+ 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..cf7d3577981
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr120049_2.f90
@@ -0,0 +1,58 @@
+! Compiled with pr120049_b.f90
+! { dg-options -O0 }
+! { dg-do compile }
+! { dg-compile-aux-modules "pr120049_b.f90" }
+!
+! Test the fix for PR120049
+program tests_gtk_sup
+ use gtk_sup
+ 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" }
+ print *, c_associated(c_loc(val), C_NULL_FUNPTR) ! { dg-error "C_ASSOCIATED shall have the" }
+ print *, c_associated(C_NULL_FUNPTR, c_loc(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
diff --git a/gcc/testsuite/gfortran.dg/pr120049_a.f90 b/gcc/testsuite/gfortran.dg/pr120049_a.f90
index c404a4dedd9..7095314fe0e 100644
--- a/gcc/testsuite/gfortran.dg/pr120049_a.f90
+++ b/gcc/testsuite/gfortran.dg/pr120049_a.f90
@@ -1,5 +1,8 @@
-! { dg-do preprocess }
-! { dg-additional-options "-cpp" }
+! Compiled with pr120049_b.f90
+! { dg-options -O0 }
+! { dg-do run }
+! { dg-compile-aux-modules "pr120049_b.f90" }
+! { dg-additional-sources pr120049_b.f90 }
!
! Test the fix for PR86248
program tests_gtk_sup
diff --git a/gcc/testsuite/gfortran.dg/pr120049_b.f90 b/gcc/testsuite/gfortran.dg/pr120049_b.f90
index 127db984077..28a2783abbd 100644
--- a/gcc/testsuite/gfortran.dg/pr120049_b.f90
+++ b/gcc/testsuite/gfortran.dg/pr120049_b.f90
@@ -1,5 +1,3 @@
-! { dg-do run }
-! { dg-additional-sources pr120049_a.f90 }
!
! Module for pr120049.f90
!
