decl.c (intrin_types_incompatible_p): New function, helper for ...

2010-06-23  Olivier Hainque  <hainque@adacore.com>

	* gcc-interface/decl.c (intrin_types_incompatible_p): New function,
	helper for ...
	(intrin_arglists_compatible_p, intrin_return_compatible_p): New
	functions, helpers for ...
	(intrin_profiles_compatible_p): New function, replacement for ...
	(compatible_signatures_p): Removed.
	(gnat_to_gnu_entity) <case E_Procedure>: If -Wextra, warn on
	attempt to bind an unregistered builtin function.  When we have
	one, use it and warn on profile incompatibilities.

From-SVN: r161257

1 files changed, 212 insertions, 36 deletions

diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index fb4769b..020bc45 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -154,13 +154,24 @@ static tree make_type_from_size (tree, tree, bool);
 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
 static unsigned int ceil_alignment (unsigned HOST_WIDE_INT);
 static void check_ok_for_atomic (tree, Entity_Id, bool);
-static int compatible_signatures_p (tree, tree);
 static tree create_field_decl_from (tree, tree, tree, tree, tree, tree);
 static tree get_rep_part (tree);
 static tree get_variant_part (tree);
 static tree create_variant_part_from (tree, tree, tree, tree, tree);
 static void copy_and_substitute_in_size (tree, tree, tree);
 static void rest_of_type_decl_compilation_no_defer (tree);
+
+/* The relevant constituents of a subprogram binding to a GCC builtin.  Used
+   to pass around calls performing profile compatibilty checks.  */
+
+typedef struct {
+  Entity_Id gnat_entity;  /* The Ada subprogram entity.  */
+  tree ada_fntype;        /* The corresponding GCC type node.  */
+  tree btin_fntype;       /* The GCC builtin function type node.  */
+} intrin_binding_t;
+
+static bool intrin_profiles_compatible_p (intrin_binding_t *);
+
 
 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
    entity, return the equivalent GCC tree for that entity (a ..._DECL node)
@@ -3906,9 +3917,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	   We still want the parameter associations to take place because the
 	   proper generation of calls depends on it (a GNAT parameter without
 	   a corresponding GCC tree has a very specific meaning), so we don't
-	   just break here.  */
-	if (Convention (gnat_entity) == Convention_Intrinsic)
-	  gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
+	   just "break;" here.  */
+	if (Convention (gnat_entity) == Convention_Intrinsic
+	    && Present (Interface_Name (gnat_entity)))
+	  {
+	    gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
+
+	    /* Post a "Wextra" warning if we couldn't find the decl.  Absence
+	       of a real intrinsic for an import is most often unexpected but
+	       allows hooking in alternate bodies, convenient in some cases so
+	       we don't want the warning to be unconditional.  */
+	    if (gnu_builtin_decl == NULL_TREE && extra_warnings)
+	      post_error ("?gcc intrinsic not found for&!", gnat_entity);
+	  }
 
 	/* ??? What if we don't find the builtin node above ? warn ? err ?
 	   In the current state we neither warn nor err, and calls will just
@@ -4204,21 +4225,25 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 				    | (TYPE_QUAL_CONST * const_flag)
 				    | (TYPE_QUAL_VOLATILE * volatile_flag));
 
-	/* If we have a builtin decl for that function, check the signatures
-	   compatibilities.  If the signatures are compatible, use the builtin
-	   decl.  If they are not, we expect the checker predicate to have
-	   posted the appropriate errors, and just continue with what we have
-	   so far.  */
+	/* If we have a builtin decl for that function, use it.  Check if the
+	   profiles are compatible and warn if they are not.  The checker is
+	   expected to post extra diagnostics in this case.  */
 	if (gnu_builtin_decl)
 	  {
-	    tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl);
+	    intrin_binding_t inb;
 
-	    if (compatible_signatures_p (gnu_type, gnu_builtin_type))
-	      {
-		gnu_decl = gnu_builtin_decl;
-		gnu_type = gnu_builtin_type;
-		break;
-	      }
+	    inb.gnat_entity = gnat_entity;
+	    inb.ada_fntype = gnu_type;
+	    inb.btin_fntype = TREE_TYPE (gnu_builtin_decl);
+
+	    if (!intrin_profiles_compatible_p (&inb))
+	      post_error
+		("?profile of& doesn't match the builtin it binds!",
+		 gnat_entity);
+
+	    gnu_decl = gnu_builtin_decl;
+	    gnu_type = TREE_TYPE (gnu_builtin_decl);
+	    break;
 	  }
 
 	/* If there was no specified Interface_Name and the external and
@@ -8036,32 +8061,183 @@ check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
 		   gnat_error_point, gnat_entity);
 }
 
-/* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
-   have compatible signatures so that a call using one type may be safely
-   issued if the actual target function type is the other.  Return 1 if it is
-   the case, 0 otherwise, and post errors on the incompatibilities.
 
-   This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
-   that calls to the subprogram will have arguments suitable for the later
-   underlying builtin expansion.  */
+/* Helper for the intrin compatibility checks family.  Evaluate whether
+   two types are definitely incompatible.  */
 
-static int
-compatible_signatures_p (tree ftype1, tree ftype2)
+static bool
+intrin_types_incompatible_p (tree t1, tree t2)
+{
+  enum tree_code code;
+
+  if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
+    return false;
+
+  if (TYPE_MODE (t1) != TYPE_MODE (t2))
+    return true;
+
+  if (TREE_CODE (t1) != TREE_CODE (t2))
+    return true;
+
+  code = TREE_CODE (t1);
+
+  switch (code)
+    {
+    case INTEGER_TYPE:
+    case REAL_TYPE:
+      return TYPE_PRECISION (t1) != TYPE_PRECISION (t2);
+
+    case POINTER_TYPE:
+    case REFERENCE_TYPE:
+      /* Assume designated types are ok.  We'd need to account for char * and
+	 void * variants to do better, which could rapidly get messy and isn't
+	 clearly worth the effort.  */
+      return false;
+
+    default:
+      break;
+    }
+
+  return false;
+}
+
+/* Helper for intrin_profiles_compatible_p, to perform compatibility checks
+   on the Ada/builtin argument lists for the INB binding.  */
+
+static bool
+intrin_arglists_compatible_p (intrin_binding_t * inb)
+{
+  tree ada_args = TYPE_ARG_TYPES (inb->ada_fntype);
+  tree btin_args = TYPE_ARG_TYPES (inb->btin_fntype);
+
+  /* Sequence position of the last argument we checked.  */
+  int argpos = 0;
+
+  while (ada_args != 0 || btin_args != 0)
+    {
+      tree ada_type, btin_type;
+
+      /* If one list is shorter than the other, they fail to match.  */
+      if (ada_args == 0 || btin_args == 0)
+	return false;
+
+      ada_type = TREE_VALUE (ada_args);
+      btin_type = TREE_VALUE (btin_args);
+
+      /* If we're done with the Ada args and not with the internal builtin
+	 args, complain.  */
+      if (ada_type == void_type_node
+	  && btin_type != void_type_node)
+	{
+	  post_error ("?Ada arguments list too short!", inb->gnat_entity);
+	  return false;
+	}
+
+      /* If we're done with the internal builtin args, check the remaining
+	 args on the Ada side.  If they are all ints, assume these are access
+	 levels and just ignore them with a conditional warning. Complain
+	 otherwise.  */
+      if (btin_type == void_type_node
+	  && ada_type != void_type_node)
+	{
+	  while (TREE_CODE (ada_type) == INTEGER_TYPE)
+	    {
+	      ada_args = TREE_CHAIN (ada_args);
+	      ada_type = TREE_VALUE (ada_args);
+	    }
+
+	  if (ada_type != void_type_node)
+	    {
+	      post_error_ne_num ("?Ada arguments list too long (> ^)!",
+				 inb->gnat_entity, inb->gnat_entity,
+				 argpos);
+	      return false;
+	    }
+
+	  else
+	    {
+	      if (extra_warnings)
+		post_error ("?trailing Ada integer args ignored for "
+			    "intrinsic binding!",
+			    inb->gnat_entity);
+	      return true;
+	    }
+	}
+
+      /* Otherwise, check that types match for the current argument.  */
+      argpos ++;
+      if (intrin_types_incompatible_p (ada_type, btin_type))
+	{
+	  post_error_ne_num ("?intrinsic binding type mismatch on argument ^!",
+			     inb->gnat_entity, inb->gnat_entity, argpos);
+	  return false;
+	}
+
+      ada_args = TREE_CHAIN (ada_args);
+      btin_args = TREE_CHAIN (btin_args);
+    }
+
+  return true;
+}
+
+/* Helper for intrin_profiles_compatible_p, to perform compatibility checks
+   on the Ada/builtin return values for the INB binding.  */
+
+static bool
+intrin_return_compatible_p (intrin_binding_t * inb)
+{
+  tree ada_return_type = TREE_TYPE (inb->ada_fntype);
+  tree btin_return_type = TREE_TYPE (inb->btin_fntype);
+
+  if (VOID_TYPE_P (btin_return_type)
+      && VOID_TYPE_P (ada_return_type))
+    return true;
+
+  if (VOID_TYPE_P (ada_return_type)
+      && !VOID_TYPE_P (btin_return_type))
+    {
+      if (extra_warnings)
+	post_error ("?builtin function imported as Ada procedure!",
+		    inb->gnat_entity);
+      return true;
+    }
+
+  if (intrin_types_incompatible_p (btin_return_type, ada_return_type))
+    {
+      post_error ("?intrinsic binding type mismatch on return value!",
+		  inb->gnat_entity);
+      return false;
+    }
+
+  return true;
+}
+
+/* Check and return whether the Ada and gcc builtin profiles bound by INB are
+   compatible.  Issue relevant warnings when they are not.
+
+   This is intended as a light check to diagnose the most obvious cases, not
+   as a full fledged type compatiblity predicate.  It is the programmer's
+   responsibility to ensure correctness of the Ada declarations in Imports,
+   especially when binding straight to a compiler internal.  */
+
+static bool
+intrin_profiles_compatible_p (intrin_binding_t * inb)
 {
-  /* As of now, we only perform very trivial tests and consider it's the
-     programmer's responsibility to ensure the type correctness in the Ada
-     declaration, as in the regular Import cases.
+  /* Check compatibility on return values and argument lists, each responsible
+     for posting warnings as appropriate.  Ensure use of the proper sloc for
+     this purpose.  */
+
+  bool arglists_compatible_p, return_compatible_p;
+  location_t saved_location = input_location;
+
+  Sloc_to_locus (Sloc (inb->gnat_entity), &input_location);
 
-     Mismatches typically result in either error messages from the builtin
-     expander, internal compiler errors, or in a real call sequence.  This
-     should be refined to issue diagnostics helping error detection and
-     correction.  */
+  return_compatible_p = intrin_return_compatible_p (inb);
+  arglists_compatible_p = intrin_arglists_compatible_p (inb);
 
-  /* Almost fake test, ensuring a use of each argument.  */
-  if (ftype1 == ftype2)
-    return 1;
+  input_location = saved_location;
 
-  return 1;
+  return return_compatible_p && arglists_compatible_p;
 }
 
 /* Return a FIELD_DECL node modeled on OLD_FIELD.  FIELD_TYPE is its type