https://gcc.gnu.org/g:41dee7da08873721a719849d19ef07c027e76dfb
commit r15-9749-g41dee7da08873721a719849d19ef07c027e76dfb
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. Rephrase error message.
* 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.
* gfortran.dg/c_f_pointer_tests_6.f90: Adjust dg-error
directive.
Co-Authored-By: Steve Kargl <ka...@gcc.gnu.org>
(cherry picked from commit 42983ffde6612b7f8a4e7ab3e76fa8b0d136e854)
Diff:
---
gcc/fortran/check.cc | 125 ++++++++++++++++------
gcc/fortran/misc.cc | 3 +
gcc/testsuite/gfortran.dg/c_f_pointer_tests_6.f90 | 2 +-
gcc/testsuite/gfortran.dg/pr120049_2.f90 | 62 +++++++++++
gcc/testsuite/gfortran.dg/pr120049_a.f90 | 7 +-
gcc/testsuite/gfortran.dg/pr120049_b.f90 | 2 -
6 files changed, 164 insertions(+), 37 deletions(-)
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 0073cd0b7802..ce9da31ceb32 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -5916,49 +5916,110 @@ 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 (!scalar_check (c_ptr_1, 0))
+ 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))
+ return true;
+ else
+ /* Return since the check_1_error message may not apply here. */
return false;
- if (c_ptr_2)
- {
- if (c_ptr_2->expr_type == EXPR_FUNCTION && c_ptr_2->ts.type == BT_VOID)
- return true;
+check_1_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
- != c_ptr_2->ts.u.derived->intmod_sym_id))
+ 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)
+{
+ switch (c_ptr_2->ts.type)
+ {
+ case BT_VOID:
+ if (c_ptr_2->expr_type == EXPR_FUNCTION)
{
- 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_1->ts.type == BT_DERIVED)
+ && c_ptr_1->expr_type == EXPR_STRUCTURE
+ && (c_ptr_1->ts.u.derived->intmod_sym_id
+ == ISOCBINDING_FUNPTR))
+ goto check_2_error;
}
- }
+ break;
+
+ case BT_DERIVED:
+ if ((c_ptr_2->expr_type == EXPR_STRUCTURE)
+ && (c_ptr_2->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR)
+ && (c_ptr_1->ts.type == BT_VOID)
+ && (c_ptr_1->expr_type == EXPR_FUNCTION))
+ return scalar_check (c_ptr_2, 1);
+
+ if ((c_ptr_2->expr_type == EXPR_STRUCTURE)
+ && (c_ptr_1->ts.type == BT_VOID)
+ && (c_ptr_1->expr_type == EXPR_FUNCTION))
+ goto check_2_error;
- if (c_ptr_2 && !scalar_check (c_ptr_2, 1))
+ if (c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING)
+ goto check_2_error;
+
+ 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))
+ goto check_2_error;
+ break;
+
+ default:
+ goto check_2_error;
+ }
+
+ 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, found %s instead of %s", &c_ptr_2->where,
+ gfc_typename (&c_ptr_2->ts), gfc_typename (&c_ptr_1->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 893c40fbba2c..b8bdf7578de6 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/c_f_pointer_tests_6.f90
b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_6.f90
index 23ca88b0de05..bc2206d4e742 100644
--- a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_6.f90
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_6.f90
@@ -38,6 +38,6 @@ contains
type(my_c_ptr_0) :: my_ptr2
type(c_funptr) :: myfun
print *,c_associated(my_ptr,my_ptr2)
- print *,c_associated(my_ptr,myfun) ! { dg-error "Argument C_PTR_2 at .1.
to C_ASSOCIATED shall have the same type as C_PTR_1: TYPE.c_ptr. instead of
TYPE.c_funptr." }
+ print *,c_associated(my_ptr,myfun) ! { dg-error "Argument C_PTR_2 at .1.
to C_ASSOCIATED shall have the same type as C_PTR_1, found TYPE.c_funptr.
instead of TYPE.c_ptr." }
end subroutine
end
diff --git a/gcc/testsuite/gfortran.dg/pr120049_2.f90
b/gcc/testsuite/gfortran.dg/pr120049_2.f90
new file mode 100644
index 000000000000..1f91e06e98ee
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr120049_2.f90
@@ -0,0 +1,62 @@
+! 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
+ type(c_funptr), target :: fptr
+ 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(fptr, C_NULL_FUNPTR)
+ print *, c_associated(c_loc(val), C_NULL_PTR)
+ print *, c_associated(C_NULL_PTR, c_loc(val))
+ 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 c404a4dedd9a..7095314fe0e6 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 127db984077d..28a2783abbd9 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
!
