This patch does not change the behavior of the compiler. It adds
a new attribute to facilitate some non gcc back-end work to locate
the protected subprogram type entity associated with an internally
generated access to subprogram type.
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-02 Javier Miranda <mira...@adacore.com>
* exp_ch9.adb (Expand_Access_Protected_Subprogram_Type): Link the
internally generated access to subprogram with its associated protected
subprogram type.
* einfo.ads, einfo.adb (Original_Access_Type): New attribute.
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 176998)
+++ exp_ch9.adb (working copy)
@@ -5067,6 +5067,12 @@
Insert_After (N, Decl1);
Analyze (Decl1);
+ -- Associate the access to subprogram with its original access to
+ -- protected subprogram type. Needed by the backend to know that this
+ -- type corresponds with an access to protected subprogram type.
+
+ Set_Original_Access_Type (D_T2, T);
+
-- Create Equivalent_Type, a record with two components for an access to
-- object and an access to subprogram.
Index: einfo.adb
===================================================================
--- einfo.adb (revision 177129)
+++ einfo.adb (working copy)
@@ -181,6 +181,7 @@
-- Default_Expr_Function Node21
-- Discriminant_Constraint Elist21
-- Interface_Name Node21
+ -- Original_Access_Type Node21
-- Original_Array_Type Node21
-- Small_Value Ureal21
@@ -2353,6 +2354,12 @@
return Flag242 (Id);
end Optimize_Alignment_Time;
+ function Original_Access_Type (Id : E) return E is
+ begin
+ pragma Assert (Ekind (Id) = E_Access_Subprogram_Type);
+ return Node21 (Id);
+ end Original_Access_Type;
+
function Original_Array_Type (Id : E) return E is
begin
pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
@@ -4852,6 +4859,12 @@
Set_Flag242 (Id, V);
end Set_Optimize_Alignment_Time;
+ procedure Set_Original_Access_Type (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind (Id) = E_Access_Subprogram_Type);
+ Set_Node21 (Id, V);
+ end Set_Original_Access_Type;
+
procedure Set_Original_Array_Type (Id : E; V : E) is
begin
pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
@@ -8332,6 +8345,9 @@
when Fixed_Point_Kind =>
Write_Str ("Small_Value");
+ when E_Access_Subprogram_Type =>
+ Write_Str ("Original_Access_Type");
+
when E_In_Parameter =>
Write_Str ("Default_Expr_Function");
Index: einfo.ads
===================================================================
--- einfo.ads (revision 177129)
+++ einfo.ads (working copy)
@@ -3206,6 +3206,12 @@
-- Optimize_Alignment (Off) mode applies to the type/object, then neither
-- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set.
+-- Original_Access_Type (Node21)
+-- Present in E_Access_Subprogram_Type entities. Set only if the access
+-- type was generated by the expander as part of processing an access
+-- to protected subprogram type. Points to the access to protected
+-- subprogram type.
+
-- Original_Array_Type (Node21)
-- Present in modular types and array types and subtypes. Set only
-- if the Is_Packed_Array_Type flag is set, indicating that the type
@@ -4876,6 +4882,7 @@
-- E_Access_Subprogram_Type
-- Equivalent_Type (Node18) (remote types only)
-- Directly_Designated_Type (Node20)
+ -- Original_Access_Type (Node21)
-- Needs_No_Actuals (Flag22)
-- Can_Use_Internal_Rep (Flag229)
-- (plus type attributes)
@@ -6223,6 +6230,7 @@
function OK_To_Reorder_Components (Id : E) return B;
function Optimize_Alignment_Space (Id : E) return B;
function Optimize_Alignment_Time (Id : E) return B;
+ function Original_Access_Type (Id : E) return E;
function Original_Array_Type (Id : E) return E;
function Original_Record_Component (Id : E) return E;
function Overlays_Constant (Id : E) return B;
@@ -6812,6 +6820,7 @@
procedure Set_OK_To_Reorder_Components (Id : E; V : B := True);
procedure Set_Optimize_Alignment_Space (Id : E; V : B := True);
procedure Set_Optimize_Alignment_Time (Id : E; V : B := True);
+ procedure Set_Original_Access_Type (Id : E; V : E);
procedure Set_Original_Array_Type (Id : E; V : E);
procedure Set_Original_Record_Component (Id : E; V : E);
procedure Set_Overlays_Constant (Id : E; V : B := True);
@@ -7546,6 +7555,7 @@
pragma Inline (OK_To_Reorder_Components);
pragma Inline (Optimize_Alignment_Space);
pragma Inline (Optimize_Alignment_Time);
+ pragma Inline (Original_Access_Type);
pragma Inline (Original_Array_Type);
pragma Inline (Original_Record_Component);
pragma Inline (Overlays_Constant);
@@ -7943,6 +7953,7 @@
pragma Inline (Set_OK_To_Rename);
pragma Inline (Set_Optimize_Alignment_Space);
pragma Inline (Set_Optimize_Alignment_Time);
+ pragma Inline (Set_Original_Access_Type);
pragma Inline (Set_Original_Array_Type);
pragma Inline (Set_Original_Record_Component);
pragma Inline (Set_Overlays_Constant);
