[Ada] AI12-0028-1 Import of variadic C functions

2020-06-19  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* gcc-interface/decl.c (gnat_to_gnu_param): Tidy up.
	(gnat_to_gnu_subprog_type): For a variadic C function, do not
	build unnamed parameters and do not add final void node.
	* gcc-interface/misc.c: Include snames.h.
	* gcc-interface/trans.c (Attribute_to_gnu): Tidy up.
	(Call_to_gnu): Implement support for unnamed parameters in a
	variadic C function.
	* gcc-interface/utils.c: Include snames.h.
	(copy_type): Tidy up.

diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 38c73cb4b44429a842bb0a67ce76ab414c3baa3c..33d59d556a2bb8b2cecc2c8823471b745697c063 100644 (file)
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -5401,8 +5401,8 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
       tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
 
       if (foreign
-         || (!must_pass_by_ref (unpadded_type)
-             && mech != By_Reference
+         || (mech != By_Reference
+             && !must_pass_by_ref (unpadded_type)
              && (mech == By_Copy || !default_pass_by_ref (unpadded_type))
              && TYPE_ALIGN (unpadded_type) >= TYPE_ALIGN (gnu_param_type)))
        gnu_param_type = unpadded_type;
@@ -5424,11 +5424,6 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
        gnu_param_type = TREE_TYPE (gnu_param_type);
 
       gnu_param_type = TREE_TYPE (gnu_param_type);
-
-      if (ro_param)
-       gnu_param_type
-         = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
-
       gnu_param_type = build_pointer_type (gnu_param_type);
       by_component_ptr = true;
     }
@@ -5760,6 +5755,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
 {
   const Entity_Kind kind = Ekind (gnat_subprog);
   const bool method_p = is_cplusplus_method (gnat_subprog);
+  const bool variadic = IN (Convention (gnat_subprog), Convention_C_Variadic);
   Entity_Id gnat_return_type = Etype (gnat_subprog);
   Entity_Id gnat_param;
   tree gnu_type = present_gnu_tree (gnat_subprog)
@@ -5792,7 +5788,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
   bool return_by_invisi_ref_p = false;
   bool return_unconstrained_p = false;
   bool incomplete_profile_p = false;
-  unsigned int num;
+  int num;
 
   /* Look into the return type and get its associated GCC tree if it is not
      void, and then compute various flags for the subprogram type.  But make
@@ -5962,6 +5958,11 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
       tree gnu_param, gnu_param_type;
       bool cico = false;
 
+      /* For a variadic C function, do not build unnamed parameters.  */
+      if (variadic
+         && num == (Convention (gnat_subprog) - Convention_C_Variadic_0))
+       break;
+
       /* Fetch an existing parameter with complete type and reuse it.  But we
         didn't save the CICO property so we can only do it for In parameters
         or parameters passed by reference.  */
@@ -6195,7 +6196,8 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
 
   /* The lists have been built in reverse.  */
   gnu_param_type_list = nreverse (gnu_param_type_list);
-  gnu_param_type_list = chainon (gnu_param_type_list, void_list_node);
+  if (!variadic)
+    gnu_param_type_list = chainon (gnu_param_type_list, void_list_node);
   gnu_param_list = nreverse (gnu_param_list);
   gnu_cico_list = nreverse (gnu_cico_list);
 

diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c
index f72122bf5e05b9904d71cf2c629b215662bb9792..f360ad4da2295c584f8d8397a2159096cd3cd385 100644 (file)
--- a/gcc/ada/gcc-interface/misc.c
+++ b/gcc/ada/gcc-interface/misc.c
@@ -47,6 +47,7 @@
 #include "atree.h"
 #include "namet.h"
 #include "nlists.h"
+#include "snames.h"
 #include "uintp.h"
 #include "fe.h"
 #include "sinfo.h"

diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index b60b03d9ebb9e53e7aa8f44767edc235e40b6c83..5a93c433ec1559a66af75f4bcd1157a6f8c1c121 100644 (file)
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -2065,7 +2065,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
     case Attr_Range_Length:
       prefix_unused = true;
 
-      if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
+      if (INTEGRAL_TYPE_P (gnu_type) || SCALAR_FLOAT_TYPE_P (gnu_type))
        {
          gnu_result_type = get_unpadded_type (Etype (gnat_node));
 
@@ -4457,9 +4457,10 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
   tree gnu_after_list = NULL_TREE;
   tree gnu_retval = NULL_TREE;
   tree gnu_call, gnu_result;
-  bool by_descriptor = false;
   bool went_into_elab_proc = false;
   bool pushed_binding_level = false;
+  bool variadic;
+  bool by_descriptor;
   Entity_Id gnat_formal;
   Node_Id gnat_actual;
   atomic_acces_t aa_type;
@@ -4505,20 +4506,32 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
      entity being called.  */
   if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
     {
+      const Entity_Id gnat_prefix_type
+       = Underlying_Type (Etype (Prefix (Name (gnat_node))));
+
       gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
+      variadic = IN (Convention (gnat_prefix_type), Convention_C_Variadic);
 
       /* If the access type doesn't require foreign-compatible representation,
         be prepared for descriptors.  */
-      if (targetm.calls.custom_function_descriptors > 0
-         && Can_Use_Internal_Rep
-            (Underlying_Type (Etype (Prefix (Name (gnat_node))))))
-       by_descriptor = true;
+      by_descriptor
+       = targetm.calls.custom_function_descriptors > 0
+         && Can_Use_Internal_Rep (gnat_prefix_type);
     }
   else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
-    /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
-    gnat_formal = Empty;
+    {
+      /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
+      gnat_formal = Empty;
+      variadic = false;
+      by_descriptor = false;
+    }
   else
-    gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
+    {
+      gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
+      variadic
+       = IN (Convention (Entity (Name (gnat_node))), Convention_C_Variadic);
+      by_descriptor = false;
+    }
 
   /* The lifetime of the temporaries created for the call ends right after the
      return value is copied, so we can give them the scope of the elaboration
@@ -4853,27 +4866,12 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
          gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
        }
 
-      /* Otherwise the parameter is passed by copy.  */
-      else
+      /* Then see if the parameter is passed by copy.  */
+      else if (is_true_formal_parm)
        {
          if (!in_param)
            gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
 
-         /* If we didn't create a PARM_DECL for the formal, this means that
-            it is an Out parameter not passed by reference and that need not
-            be copied in.  In this case, the value of the actual need not be
-            read.  However, we still need to make sure that its side-effects
-            are evaluated before the call, so we evaluate its address.  */
-         if (!is_true_formal_parm)
-           {
-             if (TREE_SIDE_EFFECTS (gnu_name))
-               {
-                 tree addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_name);
-                 append_to_statement_list (addr, &gnu_stmt_list);
-               }
-             continue;
-           }
-
          gnu_actual = convert (gnu_formal_type, gnu_actual);
 
          /* If this is a front-end built-in function, there is no need to
@@ -4882,6 +4880,98 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
            gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
        }
 
+      /* Then see if this is an unnamed parameter in a variadic C function.  */
+      else if (variadic)
+       {
+         /* This is based on the processing done in gnat_to_gnu_param, but
+            we expect the mechanism to be set in (almost) all cases.  */
+         const Mechanism_Type mech = Mechanism (gnat_formal);
+
+         /* Strip off possible padding type.  */
+         if (TYPE_IS_PADDING_P (gnu_formal_type))
+           gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
+
+         /* Arrays are passed as pointers to element type.  First check for
+            unconstrained array and get the underlying array.  */
+         if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
+           gnu_formal_type
+             = TREE_TYPE
+               (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_formal_type))));
+
+         /* Arrays are passed as pointers to element type.  */
+         if (mech != By_Copy && TREE_CODE (gnu_formal_type) == ARRAY_TYPE)
+           {
+             gnu_actual = maybe_implicit_deref (gnu_actual);
+             gnu_actual = maybe_unconstrained_array (gnu_actual);
+
+             /* Strip off any multi-dimensional entries, then strip
+                off the last array to get the component type.  */
+             while (TREE_CODE (TREE_TYPE (gnu_formal_type)) == ARRAY_TYPE
+                    && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_formal_type)))
+               gnu_formal_type = TREE_TYPE (gnu_formal_type);
+
+             gnu_formal_type = TREE_TYPE (gnu_formal_type);
+             gnu_formal_type = build_pointer_type (gnu_formal_type);
+             gnu_actual
+               = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
+           }
+
+         /* Fat pointers are passed as thin pointers.  */
+         else if (TYPE_IS_FAT_POINTER_P (gnu_formal_type))
+           gnu_formal_type
+             = make_type_from_size (gnu_formal_type,
+                                    size_int (POINTER_SIZE), 0);
+
+         /* If we were requested or muss pass by reference, do so.
+            If we were requested to pass by copy, do so.
+            Otherwise, pass In Out or Out parameters or aggregates by
+            reference.  */
+         else if (mech == By_Reference
+                  || must_pass_by_ref (gnu_formal_type)
+                  || (mech != By_Copy
+                      && (!in_param || AGGREGATE_TYPE_P (gnu_formal_type))))
+           {
+             gnu_formal_type = build_reference_type (gnu_formal_type);
+             gnu_actual
+               = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
+           }
+
+         /* Otherwise pass by copy after applying default C promotions.  */
+         else
+           {
+             if (INTEGRAL_TYPE_P (gnu_formal_type)
+                 && TYPE_PRECISION (gnu_formal_type)
+                    < TYPE_PRECISION (integer_type_node))
+               gnu_formal_type = integer_type_node;
+
+             else if (SCALAR_FLOAT_TYPE_P (gnu_formal_type)
+                      && TYPE_PRECISION (gnu_formal_type)
+                         < TYPE_PRECISION (double_type_node))
+               gnu_formal_type = double_type_node;
+           }
+
+         gnu_actual = convert (gnu_formal_type, gnu_actual);
+       }
+
+      /* If we didn't create a PARM_DECL for the formal, this means that
+        it is an Out parameter not passed by reference and that need not
+        be copied in.  In this case, the value of the actual need not be
+        read.  However, we still need to make sure that its side-effects
+        are evaluated before the call, so we evaluate its address.  */
+      else
+       {
+         if (!in_param)
+           gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
+
+         if (TREE_SIDE_EFFECTS (gnu_name))
+           {
+             tree addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_name);
+             append_to_statement_list (addr, &gnu_stmt_list);
+           }
+
+         continue;
+       }
+
       gnu_actual_vec.safe_push (gnu_actual);
     }
 

diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c
index fb08b6c90ed88b144174e851afc1340faaf598dc..2a6ed04756b041207e72a8f4ffaa289703de42a0 100644 (file)
--- a/gcc/ada/gcc-interface/utils.c
+++ b/gcc/ada/gcc-interface/utils.c
@@ -50,6 +50,7 @@
 #include "types.h"
 #include "atree.h"
 #include "nlists.h"
+#include "snames.h"
 #include "uintp.h"
 #include "fe.h"
 #include "sinfo.h"
@@ -2561,7 +2562,7 @@ copy_type (tree type)
     }
 
   /* And the contents of the language-specific slot if needed.  */
-  if ((INTEGRAL_TYPE_P (type) || TREE_CODE (type) == REAL_TYPE)
+  if ((INTEGRAL_TYPE_P (type) || SCALAR_FLOAT_TYPE_P (type))
       && TYPE_RM_VALUES (type))
     {
       TYPE_RM_VALUES (new_type) = NULL_TREE;