[Patch, fortran] [0/4] PR55574: C binding access to C_PTR type

[Mikael Morin <mikael dot morin at sfr dot fr>]

Hello,

as promised, here comes the patch for PR55574, where for code like:
  use iso_c_binding, only : c_loc
  type(C_PTR) :: f_ptr

the second statement is accepted despite c_ptr not being use-associated, as
c_loc implicitly pulls-in c_ptr.
This regression comes from Tobias' "constructor" patch (support for generics
with the same name as a derived type), which changed mangled names
"_gfortran_iso_c_binding_c_ptr" to real names "c_ptr".

The fix proposed here adds a "hidden" argument to `generate_isocbinding_symbol',
so that we know whether the symbol should be made accessible or not.
Then, we use either `gfc_new_symtree' or `gfc_get_unique_symtree' to create
the new symtree, depending on the "hidden" argument.

The work is divided as below in the follow-up mails.  The full diff is also
attached to this one.

1/4: Preliminary cleanups.
2/4: Use get_iso_c_binding_dt instead of gfc_get_ha_symbol in gen_cptr_param
3/4: Don't do again name to symbol resolution in gen_special_c_interop_ptr
4/4: (main part) Fix symbol name handling in generate_isocbinding_symbol.

Regression tested on x86_64-unknown-linux-gnu.  Ok for 4.8/4.7 ?

Mikael

diff --git a/gfortran.h b/gfortran.h
index 44d5c91..89f4f73 100644
--- a/gfortran.h
+++ b/gfortran.h
@@ -2626,7 +2626,8 @@ gfc_try gfc_verify_c_interop_param (gfc_symbol *);
 gfc_try verify_bind_c_sym (gfc_symbol *, gfc_typespec *, int, gfc_common_head *);
 gfc_try verify_bind_c_derived_type (gfc_symbol *);
 gfc_try verify_com_block_vars_c_interop (gfc_common_head *);
-void generate_isocbinding_symbol (const char *, iso_c_binding_symbol, const char *);
+void generate_isocbinding_symbol (const char *, iso_c_binding_symbol,
+				  const char *, bool);
 gfc_symbol *get_iso_c_sym (gfc_symbol *, char *, const char *, int);
 int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **, bool);
 int gfc_get_ha_symbol (const char *, gfc_symbol **);
diff --git a/module.c b/module.c
index 1b38555..062cf81 100644
--- a/module.c
+++ b/module.c
@@ -5708,7 +5708,8 @@ import_iso_c_binding_module (void)
 		  generate_isocbinding_symbol (iso_c_module_name,
 					       (iso_c_binding_symbol) i,
 					       u->local_name[0] ? u->local_name
-								: u->use_name);
+								: u->use_name,
+					       false);
 	      }
 	  }
 
@@ -5763,7 +5764,8 @@ import_iso_c_binding_module (void)
 
 	      default:
 		generate_isocbinding_symbol (iso_c_module_name,
-					     (iso_c_binding_symbol) i, NULL);
+					     (iso_c_binding_symbol) i, NULL,
+					     false);
 	    }
 	}
    }
diff --git a/symbol.c b/symbol.c
index acfebc5..4244fda 100644
--- a/symbol.c
+++ b/symbol.c
@@ -3811,23 +3811,11 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym)
 /* Generate symbols for the named constants c_null_ptr and c_null_funptr.  */
 
 static gfc_try
-gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
-                           const char *module_name)
+gen_special_c_interop_ptr (int ptr_id, gfc_symbol *tmp_sym,
+			   const char *module_name)
 {
-  gfc_symtree *tmp_symtree;
-  gfc_symbol *tmp_sym;
   gfc_constructor *c;
-
-  tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
-	 
-  if (tmp_symtree != NULL)
-    tmp_sym = tmp_symtree->n.sym;
-  else
-    {
-      tmp_sym = NULL;
-      gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
-                          "create symbol for %s", ptr_name);
-    }
+  iso_c_binding_symbol type_id;
 
   tmp_sym->ts.is_c_interop = 1;
   tmp_sym->attr.is_c_interop = 1;
@@ -3838,25 +3826,19 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
   /* The c_ptr and c_funptr derived types will provide the
      definition for c_null_ptr and c_null_funptr, respectively.  */
   if (ptr_id == ISOCBINDING_NULL_PTR)
-    tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
+    type_id = ISOCBINDING_PTR;
   else
-    tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+    type_id = ISOCBINDING_FUNPTR;
+  tmp_sym->ts.u.derived = get_iso_c_binding_dt (type_id);
   if (tmp_sym->ts.u.derived == NULL)
     {
       /* This can occur if the user forgot to declare c_ptr or
-         c_funptr and they're trying to use one of the procedures
-         that has arg(s) of the missing type.  In this case, a
-         regular version of the thing should have been put in the
-         current ns.  */
-
-      generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR 
-                                   ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
-                                   (const char *) (ptr_id == ISOCBINDING_NULL_PTR 
-				   ? "c_ptr"
-				   : "c_funptr"));
-      tmp_sym->ts.u.derived =
-	get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
-			      ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
+	 c_funptr and they're trying to use one of the procedures
+	 that has arg(s) of the missing type.  In this case, a
+	 regular version of the thing should have been put in the
+	 current ns.  */
+      generate_isocbinding_symbol (module_name, type_id, NULL, true);
+      tmp_sym->ts.u.derived = get_iso_c_binding_dt (type_id);
     }
 
   /* Module name is some mangled version of iso_c_binding.  */
@@ -3928,12 +3910,7 @@ gen_cptr_param (gfc_formal_arglist **head,
   gfc_symtree *param_symtree = NULL;
   gfc_formal_arglist *formal_arg = NULL;
   const char *c_ptr_in;
-  const char *c_ptr_type = NULL;
-
-  if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
-    c_ptr_type = "c_funptr";
-  else
-    c_ptr_type = "c_ptr";
+  iso_c_binding_symbol c_ptr_id;
 
   if(c_ptr_name == NULL)
     c_ptr_in = "gfc_cptr__";
@@ -3957,24 +3934,19 @@ gen_cptr_param (gfc_formal_arglist **head,
   param_sym->attr.value = 1;
   param_sym->attr.use_assoc = 1;
 
-  /* Get the symbol for c_ptr or c_funptr, no matter what it's name is 
+  /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
      (user renamed).  */
   if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
-    c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+    c_ptr_id = ISOCBINDING_FUNPTR;
   else
-    c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
+    c_ptr_id = ISOCBINDING_PTR;
+  c_ptr_sym = get_iso_c_binding_dt (c_ptr_id);
   if (c_ptr_sym == NULL)
     {
       /* This can happen if the user did not define c_ptr but they are
-         trying to use one of the iso_c_binding functions that need it.  */
-      if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
-	generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
-				     (const char *)c_ptr_type);
-      else
-	generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
-				     (const char *)c_ptr_type);
-
-      gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
+	 trying to use one of the iso_c_binding functions that need it.  */
+      generate_isocbinding_symbol (module_name, c_ptr_id, NULL, true);
+      c_ptr_sym = get_iso_c_binding_dt (c_ptr_id);
     }
 
   param_sym->ts.u.derived = c_ptr_sym;
@@ -4276,6 +4248,39 @@ std_for_isocbinding_symbol (int id)
     }
 }
 
+
+/* Tells whether symbol TMP_SYM is ISO_C_BINDING's symbol identified by SYM_ID.
+   If TMP_SYM is a generic, it uses the derived type in the list of interfaces
+   (if there is one).  Returns the symbol if it matches SYM_ID,
+   NULL otherwise.  */
+
+static gfc_symbol *
+check_iso_c_symbol (gfc_symbol *tmp_sym, iso_c_binding_symbol sym_id)
+{
+  if (tmp_sym->attr.generic)
+    tmp_sym = gfc_find_dt_in_generic (tmp_sym);
+
+  if (tmp_sym == NULL || tmp_sym->from_intmod != INTMOD_ISO_C_BINDING)
+    return NULL;
+
+  /* FIXME: This block is probably unnecessary. */
+  if (tmp_sym->attr.flavor == FL_DERIVED
+      && get_iso_c_binding_dt (tmp_sym->intmod_sym_id) == NULL)
+    {
+      gfc_dt_list *dt_list;
+      dt_list = gfc_get_dt_list ();
+      dt_list->derived = tmp_sym;
+      dt_list->next = gfc_derived_types;
+      gfc_derived_types = dt_list;
+    }
+
+  if (tmp_sym->intmod_sym_id != sym_id)
+    return NULL;
+
+  return tmp_sym;
+}
+
+
 /* Generate the given set of C interoperable kind objects, or all
    interoperable kinds.  This function will only be given kind objects
    for valid iso_c_binding defined types because this is verified when
@@ -4289,7 +4294,7 @@ std_for_isocbinding_symbol (int id)
 
 void
 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
-			     const char *local_name)
+			     const char *local_name, bool hidden)
 {
   const char *const name = (local_name && local_name[0]) ? local_name
 					     : c_interop_kinds_table[s].name;
@@ -4300,34 +4305,47 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
   if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
     return;
 
-  tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+  if (!hidden)
+    {
+      tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+
+      /* Already exists in this scope so don't re-add it.  */
+      if (tmp_symtree != NULL)
+	{
+	  if (check_iso_c_symbol (tmp_symtree->n.sym, s) == NULL)
+	    tmp_symtree->ambiguous = 1;
+
+	  return;
+	}
+    }
 
-  /* Already exists in this scope so don't re-add it. */
-  if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
-      && (!tmp_sym->attr.generic
-	  || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
-      && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
+  tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
+				  c_interop_kinds_table[s].name);
+  if (tmp_symtree != NULL)
     {
-      if (tmp_sym->attr.flavor == FL_DERIVED
-	  && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
+      tmp_sym = check_iso_c_symbol (tmp_symtree->n.sym, s);
+      if (tmp_sym != NULL)
 	{
-	  gfc_dt_list *dt_list;
-	  dt_list = gfc_get_dt_list ();
-	  dt_list->derived = tmp_sym;
-	  dt_list->next = gfc_derived_types;
-  	  gfc_derived_types = dt_list;
-        }
+	  if (hidden)
+	    return;
 
-      return;
+	  gcc_assert (strcmp (name, c_interop_kinds_table[s].name) != 0);
+	  tmp_symtree = gfc_new_symtree (&gfc_current_ns->sym_root, name);
+	  tmp_symtree->n.sym = tmp_sym;
+	  tmp_symtree->n.sym->refs++;
+	  return;
+	}
     }
 
   /* Create the sym tree in the current ns.  */
-  gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
-  if (tmp_symtree)
-    tmp_sym = tmp_symtree->n.sym;
+  if (!hidden)
+    tmp_symtree = gfc_new_symtree (&gfc_current_ns->sym_root, name);
   else
-    gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
-			"create symbol");
+    tmp_symtree = gfc_get_unique_symtree (gfc_current_ns);
+
+  tmp_sym = gfc_new_symbol (c_interop_kinds_table[s].name, gfc_current_ns);
+  tmp_symtree->n.sym = tmp_sym;
+  tmp_sym->refs++;
 
   /* Say what module this symbol belongs to.  */
   tmp_sym->module = gfc_get_string (mod_name);
@@ -4420,21 +4438,26 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 	  gfc_component *tmp_comp = NULL;
 	  char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
 
-	  hidden_name = gfc_get_string ("%c%s",
-			    (char) TOUPPER ((unsigned char) tmp_sym->name[0]),
-                            &tmp_sym->name[1]);
+	  if (!hidden)
+	    {
+	      hidden_name = gfc_get_string ("%c%s",
+				(char) TOUPPER ((unsigned char) name[0]),
+				&name[1]);
+
+	      gcc_assert (gfc_find_symtree (gfc_current_ns->sym_root,
+					    hidden_name) == NULL);
 
-	  /* Generate real derived type.  */
-	  tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
-					  hidden_name);
-
-	  if (tmp_symtree != NULL)
-	    gcc_unreachable ();
-	  gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
-	  if (tmp_symtree)
-	    dt_sym = tmp_symtree->n.sym;
+	      tmp_symtree = gfc_new_symtree (&gfc_current_ns->sym_root,
+					     hidden_name);
+	    }
 	  else
-	    gcc_unreachable ();
+	    tmp_symtree = gfc_get_unique_symtree (gfc_current_ns);
+
+	  /* Generate real derived type.  */
+	  dt_sym = gfc_new_symbol (c_interop_kinds_table[s].name,
+				   gfc_current_ns);
+	  tmp_symtree->n.sym = dt_sym;
+	  tmp_symtree->n.sym->refs++;
 
 	  /* Generate an artificial generic function.  */
 	  dt_sym->name = gfc_get_string (tmp_sym->name);
@@ -4522,8 +4545,8 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 
       case ISOCBINDING_NULL_PTR:
       case ISOCBINDING_NULL_FUNPTR:
-        gen_special_c_interop_ptr (s, name, mod_name);
-        break;
+	gen_special_c_interop_ptr (s, tmp_sym, mod_name);
+	break;
 
       case ISOCBINDING_F_POINTER:
       case ISOCBINDING_ASSOCIATED:
@@ -4556,31 +4579,26 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 	      }
 	    else
 	      {
-               /* Here, we're taking the simple approach.  We're defining
-                  c_loc as an external identifier so the compiler will put
-                  what we expect on the stack for the address we want the
-                  C address of.  */
+		iso_c_binding_symbol c_ptr_id;
+
+		/* Here, we're taking the simple approach.  We're defining
+		   c_loc as an external identifier so the compiler will put
+		   what we expect on the stack for the address we want the
+		   C address of.  */
 		tmp_sym->ts.type = BT_DERIVED;
-                if (s == ISOCBINDING_LOC)
-                  tmp_sym->ts.u.derived =
-                    get_iso_c_binding_dt (ISOCBINDING_PTR);
-                else
-                  tmp_sym->ts.u.derived =
-                    get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+		if (s == ISOCBINDING_LOC)
+		  c_ptr_id = ISOCBINDING_PTR;
+		else
+		  c_ptr_id = ISOCBINDING_FUNPTR;
 
+		tmp_sym->ts.u.derived = get_iso_c_binding_dt (c_ptr_id);
 		if (tmp_sym->ts.u.derived == NULL)
 		  {
-                    /* Create the necessary derived type so we can continue
-                       processing the file.  */
-		    generate_isocbinding_symbol
-		      (mod_name, s == ISOCBINDING_FUNLOC
-				? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
-		      (const char *)(s == ISOCBINDING_FUNLOC
-				? "c_funptr" : "c_ptr"));
-                    tmp_sym->ts.u.derived =
-		    get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
-					    ? ISOCBINDING_FUNPTR
-					    : ISOCBINDING_PTR);
+		    /* Create the necessary derived type so we can continue
+		       processing the file.  */
+		    generate_isocbinding_symbol (mod_name, c_ptr_id, NULL,
+						 true);
+		    tmp_sym->ts.u.derived = get_iso_c_binding_dt (c_ptr_id);
 		  }
 
 		/* The function result is itself (no result clause).  */