Patchwork [Ada] Private type as actual in generic RCI

login
register
mail settings
Submitter Arnaud Charlet
Date Sept. 10, 2010, 2:53 p.m.
Message ID <20100910145307.GA9594@adacore.com>
Download mbox | patch
Permalink /patch/64403/
State New
Headers show

Comments

Arnaud Charlet - Sept. 10, 2010, 2:53 p.m.
This change fixes an inconsistency in the code generation circuitry of the
PolyORB-based implementation of the distributed systems annex. This
inconsistency occurs when an RCI that is a generic instance contains a function
whose return type is a formal type of the generic, and the actual type
is private.

No test (requires PolyORB setup).

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-09-10  Thomas Quinot  <quinot@adacore.com>

	* exp_dist.adb (Build_From_Any_Call, Build_To_Any_Call,
	Build_TypeCode_Call): For a subtype inserted for the expansion of a
	generic actual type, go to the underlying type of the original actual
	type.

Patch

Index: exp_dist.adb
===================================================================
--- exp_dist.adb	(revision 164184)
+++ exp_dist.adb	(working copy)
@@ -8427,6 +8427,15 @@  package body Exp_Dist is
 
             Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
 
+            --  For the subtype representing a generic actual type, go to the
+            --  actual type.
+
+            if Is_Generic_Actual_Type (U_Type) then
+               U_Type := Underlying_Type (Base_Type (U_Type));
+            end if;
+
+            --  For a standard subtype, go to the base type
+
             if Sloc (U_Type) <= Standard_Location then
                U_Type := Base_Type (U_Type);
             end if;
@@ -8516,13 +8525,6 @@  package body Exp_Dist is
                   Decl : Entity_Id;
 
                begin
-                  --  For the subtype representing a generic actual type, go
-                  --  to the base type.
-
-                  if Is_Generic_Actual_Type (U_Type) then
-                     U_Type := Base_Type (U_Type);
-                  end if;
-
                   Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
                   Append_To (Decls, Decl);
                end;
@@ -9240,12 +9242,14 @@  package body Exp_Dist is
 
             Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
 
-            --  Check first for Boolean and Character. These are enumeration
-            --  types, but we treat them specially, since they may require
-            --  special handling in the transfer protocol. However, this
-            --  special handling only applies if they have standard
-            --  representation, otherwise they are treated like any other
-            --  enumeration type.
+            --  For the subtype representing a generic actual type, go to the
+            --  actual type.
+
+            if Is_Generic_Actual_Type (U_Type) then
+               U_Type := Underlying_Type (Base_Type (U_Type));
+            end if;
+
+            --  For a standard subtype, go to the base type
 
             if Sloc (U_Type) <= Standard_Location then
                U_Type := Base_Type (U_Type);
@@ -9254,6 +9258,13 @@  package body Exp_Dist is
             if Present (Fnam) then
                null;
 
+            --  Check first for Boolean and Character. These are enumeration
+            --  types, but we treat them specially, since they may require
+            --  special handling in the transfer protocol. However, this
+            --  special handling only applies if they have standard
+            --  representation, otherwise they are treated like any other
+            --  enumeration type.
+
             elsif U_Type = Standard_Boolean then
                Lib_RE := RE_TA_B;
 
@@ -9380,14 +9391,11 @@  package body Exp_Dist is
             Decls : constant List_Id := New_List;
             Stms  : constant List_Id := New_List;
 
-            Expr_Parameter : constant Entity_Id :=
-                               Make_Defining_Identifier (Loc, Name_E);
-
-            Any : constant Entity_Id :=
-                    Make_Defining_Identifier (Loc, Name_A);
+            Expr_Parameter : Entity_Id;
+            Any            : Entity_Id;
+            Result_TC      : Node_Id;
 
             Any_Decl  : Node_Id;
-            Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
 
             Use_Opaque_Representation : Boolean;
             --  When True, use stream attributes and represent type as an
@@ -9402,12 +9410,16 @@  package body Exp_Dist is
             if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
                Build_To_Any_Function
                   (Loc  => Loc,
-                  Typ  => Etype (Typ),
-                  Decl => Decl,
-                  Fnam => Fnam);
+                   Typ  => Etype (Typ),
+                   Decl => Decl,
+                   Fnam => Fnam);
                return;
             end if;
 
+            Expr_Parameter := Make_Defining_Identifier (Loc, Name_E);
+            Any            := Make_Defining_Identifier (Loc, Name_A);
+            Result_TC      := Build_TypeCode_Call (Loc, Typ, Decls);
+
             Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
 
             Spec :=
@@ -10017,15 +10029,20 @@  package body Exp_Dist is
                Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
             end if;
 
-            if No (Fnam) then
-               if Sloc (U_Type) <= Standard_Location then
+            --  For the subtype representing a generic actual type, go to the
+            --  actual type.
 
-                  --  Do not try to build alias typecodes for subtypes from
-                  --  Standard.
+            if Is_Generic_Actual_Type (U_Type) then
+               U_Type := Underlying_Type (Base_Type (U_Type));
+            end if;
 
-                  U_Type := Base_Type (U_Type);
-               end if;
+            --  For a standard subtype, go to the base type
 
+            if Sloc (U_Type) <= Standard_Location then
+               U_Type := Base_Type (U_Type);
+            end if;
+
+            if No (Fnam) then
                if U_Type = Standard_Boolean then
                   Lib_RE := RE_TC_B;