From: Arnaud Charlet <charlet@gcc.gnu.org>
Date: Thu, 20 Nov 2014 11:02:25 +0000 (+0100)
Subject: [multiple changes]
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=4b963531a13ebfef4fd889df305d4037e7334fa0;p=gcc.git

[multiple changes]

2014-11-20  Javier Miranda  <miranda@adacore.com>

	* sem_ch6.adb (Analyze_Function_Return): For functions returning
	an access to an interface add an implicit conversion to the target
	type to force the displacement of the pointer to the object to
	reference the secondary dispatch table.
	(Check_Anonymous_Return): Skip internally built functions which handle
	the case of null access when locating the master of a task.
	* sem_res.adb (Valid_Conversion): Return true for internally
	generated conversions of access to interface types added to force
	the displacement of the pointer to reference the corresponding
	dispatch table.

2014-11-20  Pascal Obry  <obry@adacore.com>

	* adaint.c (add_handle): realloc with a size of +100.

From-SVN: r217836
---

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 27f16af46f3..c904bde40c6 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,20 @@
+2014-11-20  Javier Miranda  <miranda@adacore.com>
+
+	* sem_ch6.adb (Analyze_Function_Return): For functions returning
+	an access to an interface add an implicit conversion to the target
+	type to force the displacement of the pointer to the object to
+	reference the secondary dispatch table.
+	(Check_Anonymous_Return): Skip internally built functions which handle
+	the case of null access when locating the master of a task.
+	* sem_res.adb (Valid_Conversion): Return true for internally
+	generated conversions of access to interface types added to force
+	the displacement of the pointer to reference the corresponding
+	dispatch table.
+
+2014-11-20  Pascal Obry  <obry@adacore.com>
+
+	* adaint.c (add_handle): realloc with a size of +100.
+
 2014-11-20  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_res.adb (Make_Call_Into_Operator): In ASIS mode, propagate
diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c
index 4820677d40d..cd3f11a3469 100644
--- a/gcc/ada/adaint.c
+++ b/gcc/ada/adaint.c
@@ -2339,7 +2339,7 @@ add_handle (HANDLE h, int pid)
 
   if (plist_length == plist_max_length)
     {
-      plist_max_length += 1000;
+      plist_max_length += 100;
       HANDLES_LIST =
         (HANDLE *) xrealloc (HANDLES_LIST, sizeof (HANDLE) * plist_max_length);
       PID_LIST =
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 832a3ea7ab0..723d4593cdd 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -901,7 +901,35 @@ package body Sem_Ch6 is
                return;
             end if;
 
-            Analyze_And_Resolve (Expr, R_Type);
+            Analyze (Expr);
+
+            --  Ada 2005 (AI-251): If the type of the returned object is
+            --  an access to an interface type then we add an implicit type
+            --  conversion to force the displacement of the "this" pointer to
+            --  reference the secondary dispatch table. We cannot delay the
+            --  generation of this implicit conversion until the expansion
+            --  because in this case the type resolution changes the decoration
+            --  of the expression node to match R_Type; by contrast, if the
+            --  returned object is a class-wide interface type then it is too
+            --  early to generate here the implicit conversion since the return
+            --  statement may be rewritten by the expander into an extended
+            --  return statement whose expansion takes care of adding the
+            --  implicit type conversion to displace the pointer to the object.
+
+            if Expander_Active
+              and then Serious_Errors_Detected = 0
+              and then Is_Access_Type (R_Type)
+              and then Nkind (Expr) /= N_Null
+              and then Is_Interface (Designated_Type (R_Type))
+              and then Is_Progenitor (Designated_Type (R_Type),
+                                      Designated_Type (Etype (Expr)))
+            then
+               Rewrite (Expr,
+                 Convert_To (R_Type, Relocate_Node (Expr)));
+               Analyze (Expr);
+            end if;
+
+            Resolve (Expr, R_Type);
             Check_Limited_Return (Expr);
          end if;
 
@@ -2512,6 +2540,13 @@ package body Sem_Ch6 is
          if Ekind (Scop) = E_Function
            and then Ekind (Etype (Scop)) = E_Anonymous_Access_Type
            and then not Is_Thunk (Scop)
+
+            --  Skip internally built functions which handle the case of
+            --  a null access (see Expand_Interface_Conversion)
+
+           and then not (Is_Interface (Designated_Type (Etype (Scop)))
+                           and then not Comes_From_Source (Parent (Scop)))
+
            and then (Has_Task (Designated_Type (Etype (Scop)))
                       or else
                        (Is_Class_Wide_Type (Designated_Type (Etype (Scop)))
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 6e02a2583f0..24628bc2edf 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -12047,6 +12047,16 @@ package body Sem_Res is
             return Valid_Array_Conversion;
          end if;
 
+      --  Ada 2005 (AI-251): Internally generated conversions of access to
+      --  interface types added to force the displacement of the pointer to
+      --  reference the corresponding dispatch table.
+
+      elsif not Comes_From_Source (N)
+         and then Is_Access_Type (Target_Type)
+         and then Is_Interface (Designated_Type (Target_Type))
+      then
+         return True;
+
       --  Ada 2005 (AI-251): Anonymous access types where target references an
       --  interface type.