[Bug fortran/120049] ICE when using IS_C_ASSOCIATED ()

[kargls at comcast dot net via Gcc-bugs]

https://gcc.gnu.org/bugzilla/show_bug.cgi?id=120049

--- Comment #27 from kargls at comcast dot net ---
On 5/10/25 06:21, anlauf at gcc dot gnu.org wrote:
> https://gcc.gnu.org/bugzilla/show_bug.cgi?id=120049
> 
> --- Comment #26 from anlauf at gcc dot gnu.org ---
> Have you tried to move some of the checks *after* the resolution stage?
> 
> The checks in check.cc are invoked rather early.  Maybe look into
> trans-intrinsic.cc (conv_isocbinding_function)?
> 

The checks in check.cc should still occur, but I think we need
something like my WIP.  The diff is hard to read, so:

/* C_PTR_1 shall be a scalar of type C_PTR or C_FUNPTR.
    C_PTR_2 (optional) shall be a scalar of the same type as C_PTR_1.

    In 'A = C_ASSOCIATED(C_LOC(X))' and similar expression where C_LOC
    is indirectly accessed through a user's module and not directly from
    ISO_C_BINDING, the   */

bool
gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
{
   bool saw_c_ptr = false, saw_fun_ptr = false;

   if (!scalar_check (c_ptr_1, 0))
     return false;

   /* This test might be too restrictive due to renaming as from_intmod
      might not be set.  */
   if (c_ptr_1->ts.type == BT_DERIVED
       && c_ptr_1->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING)
     {
       if (c_ptr_1->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR)
        saw_c_ptr = true;
       else if (c_ptr_1->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR)
        saw_c_funptr = true;
       else
        goto error1;
     }
   else if (c_ptr_1->expr_type == EXPR_FUNCTION && c_ptr_1->ts.type == 
BT_VOID)
     {
       if (c_ptr_1->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR)
        saw_c_ptr = true;
       else if (c_ptr_1->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR)
        saw_c_funptr = true;
       else
        goto error1;
     }
   else
     goto error1;

   if (c_ptr_2 && !scalar_check (c_ptr_2, 1))
     return false;

   if (c_ptr_2 && saw_c_ptr)
     {
       if (c_ptr_2->ts.type == BT_DERIVED
         && c_ptr_2->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
         && c_ptr_2->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
        goto erro2;
       else if (c_ptr_2->expr_type == EXPR_FUNCTION
                && c_ptr_2->ts.type == BT_VOID)
        {

        }
       else
        goto error2;
     }
   else if (c_ptr_2 && saw_c_funptr)
     {
        /* Same type of checking as for C_PTR.  */
     }
   else
     goto error2;

   return true;

error1:

   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;

error2:

   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;

}