Patchwork [fortran,4/4] C binding access to C_PTR type: main fix

login
register
mail settings
Submitter Mikael Morin
Date March 2, 2013, 4:54 p.m.
Message ID <20130302165423.10658.31897@marvin>
Download mbox | patch
Permalink /patch/224517/
State New
Headers show

Comments

Mikael Morin - March 2, 2013, 4:54 p.m.
This is the main part of the patch.
A new argument "hidden" is added to generate_isocbinding_symbol, telling whether
we want the symbol accessible or not.
The code trying to reuse existing symbols is rewritten as follows:
 - A big condition containing two internal assignments is extracted into a new
 function: check_iso_c_symbol.
 - We make two attempts to look for the symbol, and use the new function to check
 for symbol match each time.  First, we try to find the symbol under its local
 (possibly renamed) name.  Then we fall back to look it up under its real name.

The code creating new symtrees doesn't use gfc_get_sym_tree anymore, as it
wouldn't honor "hidden";  it uses either gfc_new_symtree or
gfc_get_unique_symtree instead, depending on "hidden".

The same is done in the hunk dealing with creating the derived type symtree
(accessible with a capitalized first letter name).  I also changed tmp_sym->name
to name there as it made more sense to me (local name instead of real one).  I'm
not completely sure that it's correct though.
2013-03-02  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/55574
	* gfortran.h (generate_isocbinding_symbol): New argument in prototype.
	* module.c (import_iso_c_binding_module): Update calls to
	generate_isocbinding_symbol.
	* symbol.c (gen_special_c_interop_ptr, gen_cptr_param): Ditto.
	(check_iso_c_symbol): New function.
	(generate_isocbinding_symbol): New argument 'hidden'.
	Rewrite existing symbol lookup.  Avoid namespace pollution if 'hidden'
	is set.
2013-03-02  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/55574
	* gfortran.dg/iso_c_binding_only_2.f03: New test.
! { dg-do compile }
!
! PR fortran/55574
! The following code used to be accepted because C_LOC pulls in C_PTR
! implicitly.
!
! Contributed by Valery Weber <valeryweber@hotmail.com>
!
program aaaa
  use iso_c_binding, only : c_loc
  integer, target :: i
  type(C_PTR) :: f_ptr ! { dg-error "being used before it is defined" }
  f_ptr=c_loc(i)  ! { dg-error "Can't convert" }
end program aaaa

Patch

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 b03d572..4244fda 100644
--- a/symbol.c
+++ b/symbol.c
@@ -3837,7 +3837,7 @@  gen_special_c_interop_ptr (int ptr_id, gfc_symbol *tmp_sym,
 	 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);
+      generate_isocbinding_symbol (module_name, type_id, NULL, true);
       tmp_sym->ts.u.derived = get_iso_c_binding_dt (type_id);
     }
 
@@ -3945,7 +3945,7 @@  gen_cptr_param (gfc_formal_arglist **head,
     {
       /* 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.  */
-      generate_isocbinding_symbol (module_name, c_ptr_id, NULL);
+      generate_isocbinding_symbol (module_name, c_ptr_id, NULL, true);
       c_ptr_sym = get_iso_c_binding_dt (c_ptr_id);
     }
 
@@ -4248,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
@@ -4261,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;
@@ -4272,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);
@@ -4392,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]);
 
-	  /* 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;
+	      gcc_assert (gfc_find_symtree (gfc_current_ns->sym_root,
+					    hidden_name) == NULL);
+
+	      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);
@@ -4545,7 +4596,8 @@  generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 		  {
 		    /* Create the necessary derived type so we can continue
 		       processing the file.  */
-		    generate_isocbinding_symbol (mod_name, c_ptr_id, NULL);
+		    generate_isocbinding_symbol (mod_name, c_ptr_id, NULL,
+						 true);
 		    tmp_sym->ts.u.derived = get_iso_c_binding_dt (c_ptr_id);
 		  }