From a05e99a2693109e7a2b4fffe853890946cd0320d Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Wed, 15 Feb 2006 10:38:00 +0100 Subject: [PATCH] exp_ch3.adb (Component_Needs_Simple_Initialization): Add check for availability of RE_Interface_Tag. 2006-02-13 Javier Miranda Gary Dismukes * exp_ch3.adb (Component_Needs_Simple_Initialization): Add check for availability of RE_Interface_Tag. (Build_Initialization_Call): Fix wrong access to the discriminant value. (Freeze_Record_Type): Do not generate the tables associated with timed and conditional dispatching calls through synchronized interfaces if compiling under No_Dispatching_Calls restriction. When compiling for Ada 2005, for a nonabstract type with a null extension, call Make_Controlling_Function_Wrappers and insert the wrapper function declarations and bodies (the latter being appended as freeze actions). (Predefined_Primitive_Bodies): Do not generate the bodies of the predefined primitives associated with timed and conditional dispatching calls through synchronized interfaces if we are compiling under No_Dispatching_Calls. (Build_Init_Procedure): Use RTE_Available to check if a run-time service is available before generating a call. (Make_Controlling_Function_Wrappers): New procedure. (Expand_N_Full_Type_Declaration): Create a class-wide master for access-to-limited-interfaces because they can be used to reference tasks that implement such limited interface. (Build_Offset_To_Top_Functions): Build the tree corresponding to the procedure spec and body of the Offset_To_Top function that is generated when the parent of a type with discriminants has secondary dispatch tables. (Init_Secondary_Tags): Handle the case in which the parent of the type containing secondary dispatch tables has discriminants to generate the correct arguments to call Set_Offset_To_Top. (Build_Record_Init_Proc): Add call to Build_Offset_To_Top_Functions. * a-tags.ads, a-tags.adb: (Check_Index): Removed. Add Wide_[Wide_]Expanded_Name. (Get_Predefined_Prim_Op_Address): New subprogram that provides exactly the same functionality of Get_Prim_Op_Address but applied to predefined primitive operations because the pointers to the predefined primitives are now saved in a separate table. (Parent_Size): Modified to get access to the separate table of primitive operations or the parent type. (Set_Predefined_Prim_Op_Address): New subprogram that provides the same functionality of Set_Prim_Op_Address but applied to predefined primitive operations. (Set_Signature): New subprogram used to store the signature of a DT. (Displace): If the Offset_To_Top value is not static then call the function generated by the expander to get such value; otherwise use the value stored in the table of interfaces. (Offset_To_Top): The type of the actual has been changed to Address to give the correct support to tagged types with discriminants. In this case this value is stored just immediately after the tag field. (Set_Offset_To_Top): Two new formals have been added to indicate if the offset_to_top value is static and hence pass this value to the run-time to store it in the table of interfaces, or else if this value is dynamic and then pass to the run-time the address of a function that is generated by the expander to provide this value for each object of the type. * rtsfind.ads (Default_Prin_Op_Count): Removed. (Default_Prim_Op_Count): New entity (Get_Predefined_Prim_Op_Address): New entity (Set_Predefined_Prim_Op_Address): New entity (RE_Set_Signature): New entity From-SVN: r111059 --- gcc/ada/a-tags.adb | 248 ++++++++++++----- gcc/ada/a-tags.ads | 120 ++++++--- gcc/ada/exp_ch3.adb | 636 +++++++++++++++++++++++++++++++++++++------- gcc/ada/rtsfind.ads | 6 + 4 files changed, 817 insertions(+), 193 deletions(-) diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index a8d6cd00109..cfce83451b5 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,6 +34,8 @@ with Ada.Exceptions; with System.HTable; with System.Storage_Elements; use System.Storage_Elements; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_StW; use System.WCh_StW; pragma Elaborate_All (System.HTable); @@ -41,6 +43,10 @@ package body Ada.Tags is -- Structure of the GNAT Primary Dispatch Table +-- +----------------------+ +-- | table of | +-- : predefined primitive : +-- | ops pointers | -- +----------------------+ -- | Signature | -- +----------------------+ @@ -66,8 +72,6 @@ package body Ada.Tags is -- +-------------------+ -- | num prim ops | -- +-------------------+ --- | num interfaces | --- +-------------------+ -- | Ifaces_Table_Ptr --> Interface Data -- +-------------------+ +------------+ -- Select Specific Data <---- SSD_Ptr | | table | @@ -83,6 +87,10 @@ package body Ada.Tags is -- Structure of the GNAT Secondary Dispatch Table +-- +-----------------------+ +-- | table of | +-- : predefined primitive : +-- | ops pointers | -- +-----------------------+ -- | Signature | -- +-----------------------+ @@ -126,9 +134,9 @@ package body Ada.Tags is -- Field_Type_Ptr in A-Tags.ads. -- Define the specifications of Get_ and Set_ - -- in A-Tags.ads. + -- in a-tags.ads. - -- Update the GNAT Dispatch Table structure in A-Tags.adb + -- Update the GNAT Dispatch Table structure in a-tags.adb -- Provide bodies to the Get_ and Set_ routines. -- The profile of a Get_ routine should resemble: @@ -184,9 +192,16 @@ package body Ada.Tags is -- Declarations for the table of interfaces type Interface_Data_Element is record - Iface_Tag : Tag; - Offset : System.Storage_Elements.Storage_Offset; + Iface_Tag : Tag; + Static_Offset_To_Top : Boolean; + Offset_To_Top_Value : System.Storage_Elements.Storage_Offset; + Offset_To_Top_Func : System.Address; end record; + -- If some ancestor of the tagged type has discriminants the field + -- Static_Offset_To_Top is False and the field Offset_To_Top_Func + -- is used to store the address of the function generated by the + -- expander which provides this value; otherwise Static_Offset_To_Top + -- is True and such value is stored in the Offset_To_Top_Value field. type Interfaces_Array is array (Natural range <>) of Interface_Data_Element; @@ -322,9 +337,6 @@ package body Ada.Tags is -- only to declare the corresponding access type. end record; - -- Run-time check types and subprograms: These subprograms are used only - -- when the run-time is compiled with assertions enabled. - type Signature_Type is (Must_Be_Primary_DT, Must_Be_Secondary_DT, @@ -356,6 +368,17 @@ package body Ada.Tags is function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size); -- The profile of the implicitly defined _size primitive + type Offset_To_Top_Function_Ptr is + access function (This : System.Address) + return System.Storage_Elements.Storage_Offset; + -- Type definition used to call the function that is generated by the + -- expander in case of tagged types with discriminants that have secondary + -- dispatch tables. This function provides the Offset_To_Top value in this + -- specific case. + + function To_Offset_To_Top_Function_Ptr is + new Unchecked_Conversion (System.Address, Offset_To_Top_Function_Ptr); + type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset; function To_Storage_Offset_Ptr is @@ -365,11 +388,6 @@ package body Ada.Tags is -- Local Subprograms -- ----------------------- - function Check_Index - (T : Tag; - Index : Natural) return Boolean; - -- Check that Index references a valid entry of the dispatch table of T - function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean; -- Check that the signature of T is valid and corresponds with the subset -- specified by the signature Kind. @@ -489,20 +507,6 @@ package body Ada.Tags is end HTable_Subprograms; - ----------------- - -- Check_Index -- - ----------------- - - function Check_Index - (T : Tag; - Index : Natural) return Boolean - is - Max_Entries : constant Natural := Get_Num_Prim_Ops (T); - - begin - return Index /= 0 and then Index <= Max_Entries; - end Check_Index; - --------------------- -- Check_Signature -- --------------------- @@ -624,7 +628,7 @@ package body Ada.Tags is pragma Assert (Check_Signature (T, Must_Be_Interface)); - Obj_Base := This - Offset_To_Top (Curr_DT); + Obj_Base := This - Offset_To_Top (This); Obj_DT := To_Tag_Ptr (Obj_Base).all; pragma Assert @@ -636,8 +640,25 @@ package body Ada.Tags is if Iface_Table /= null then for Id in 1 .. Iface_Table.Nb_Ifaces loop if Iface_Table.Table (Id).Iface_Tag = T then - Obj_Base := Obj_Base + Iface_Table.Table (Id).Offset; - Obj_DT := To_Tag_Ptr (Obj_Base).all; + + -- Case of Static value of Offset_To_Top + + if Iface_Table.Table (Id).Static_Offset_To_Top then + Obj_Base := + Obj_Base + Iface_Table.Table (Id).Offset_To_Top_Value; + + -- Otherwise we call the function generated by the expander + -- to provide us with this value + + else + Obj_Base := + Obj_Base + + To_Offset_To_Top_Function_Ptr + (Iface_Table.Table (Id).Offset_To_Top_Func).all + (Obj_Base); + end if; + + Obj_DT := To_Tag_Ptr (Obj_Base).all; pragma Assert (Check_Signature (Obj_DT, Must_Be_Secondary_DT)); @@ -680,7 +701,7 @@ package body Ada.Tags is pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); - Obj_Base := This - Offset_To_Top (Curr_DT); + Obj_Base := This - Offset_To_Top (This); Obj_DT := To_Tag_Ptr (Obj_Base).all; pragma Assert @@ -782,12 +803,10 @@ package body Ada.Tags is --------------------- function Get_Entry_Index (T : Tag; Position : Positive) return Positive is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - return SSD (T).SSD_Table (Index).Index; + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + return SSD (T).SSD_Table (Position).Index; end Get_Entry_Index; ---------------------- @@ -815,6 +834,21 @@ package body Ada.Tags is end if; end Get_Num_Prim_Ops; + -------------------------------- + -- Get_Predef_Prim_Op_Address -- + -------------------------------- + + function Get_Predefined_Prim_Op_Address + (T : Tag; + Position : Positive) return System.Address + is + Prim_Ops_DT : constant Tag := To_Tag (To_Address (T) - DT_Prologue_Size); + begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); + pragma Assert (Position <= Default_Prim_Op_Count); + return Prim_Ops_DT.Prims_Ptr (Position); + end Get_Predefined_Prim_Op_Address; + ------------------------- -- Get_Prim_Op_Address -- ------------------------- @@ -825,7 +859,7 @@ package body Ada.Tags is is begin pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); - pragma Assert (Check_Index (T, Position)); + pragma Assert (Position <= Get_Num_Prim_Ops (T)); return T.Prims_Ptr (Position); end Get_Prim_Op_Address; @@ -837,12 +871,10 @@ package body Ada.Tags is (T : Tag; Position : Positive) return Prim_Op_Kind is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - return SSD (T).SSD_Table (Index).Kind; + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + return SSD (T).SSD_Table (Position).Kind; end Get_Prim_Op_Kind; ---------------------- @@ -853,12 +885,10 @@ package body Ada.Tags is (T : Tag; Position : Positive) return Positive is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Secondary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - return OSD (T).OSD_Table (Index); + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + return OSD (T).OSD_Table (Position); end Get_Offset_Index; ------------------- @@ -898,6 +928,9 @@ package body Ada.Tags is ---------------- procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is + Old_T_Prim_Ops : Tag; + New_T_Prim_Ops : Tag; + Size : Positive; begin pragma Assert (Check_Signature (Old_T, Must_Be_Primary_Or_Secondary_DT)); pragma Assert (Check_Signature (New_T, Must_Be_Primary_Or_Secondary_DT)); @@ -906,6 +939,11 @@ package body Ada.Tags is if Old_T /= null then New_T.Prims_Ptr (1 .. Entry_Count) := Old_T.Prims_Ptr (1 .. Entry_Count); + Old_T_Prim_Ops := To_Tag (To_Address (Old_T) - DT_Prologue_Size); + New_T_Prim_Ops := To_Tag (To_Address (New_T) - DT_Prologue_Size); + Size := Default_Prim_Op_Count; + New_T_Prim_Ops.Prims_Ptr (1 .. Size) := + Old_T_Prim_Ops.Prims_Ptr (1 .. Size); end if; end Inherit_DT; @@ -1034,12 +1072,18 @@ package body Ada.Tags is ------------------- function Offset_To_Top - (T : Tag) return System.Storage_Elements.Storage_Offset + (This : System.Address) return System.Storage_Elements.Storage_Offset is - Offset_To_Top : constant Storage_Offset_Ptr := - To_Storage_Offset_Ptr - (To_Address (T) - K_Offset_To_Top); + Curr_DT : constant Tag := To_Tag_Ptr (This).all; + Offset_To_Top : Storage_Offset_Ptr; begin + Offset_To_Top := To_Storage_Offset_Ptr + (To_Address (Curr_DT) - K_Offset_To_Top); + + if Offset_To_Top.all = SSE.Storage_Offset'Last then + Offset_To_Top := To_Storage_Offset_Ptr (This + Tag_Size); + end if; + return Offset_To_Top.all; end Offset_To_Top; @@ -1066,14 +1110,18 @@ package body Ada.Tags is Parent_Tag : Tag; -- The tag of the parent type through the dispatch table + Prim_Ops_DT : Tag; + -- The table of primitive operations of the parent + F : Acc_Size; -- Access to the _size primitive of the parent. We assume that it is -- always in the first slot of the dispatch table. begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - Parent_Tag := TSD (T).Tags_Table (1); - F := To_Acc_Size (Parent_Tag.Prims_Ptr (1)); + Parent_Tag := TSD (T).Tags_Table (1); + Prim_Ops_DT := To_Tag (To_Address (Parent_Tag) - DT_Prologue_Size); + F := To_Acc_Size (Prim_Ops_DT.Prims_Ptr (1)); -- Here we compute the size of the _parent field of the object @@ -1156,12 +1204,10 @@ package body Ada.Tags is Position : Positive; Value : Positive) is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - SSD (T).SSD_Table (Index).Index := Value; + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + SSD (T).SSD_Table (Position).Index := Value; end Set_Entry_Index; ----------------------- @@ -1219,12 +1265,10 @@ package body Ada.Tags is Position : Positive; Value : Positive) is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Secondary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - OSD (T).OSD_Table (Index) := Value; + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + OSD (T).OSD_Table (Position) := Value; end Set_Offset_Index; ----------------------- @@ -1234,7 +1278,9 @@ package body Ada.Tags is procedure Set_Offset_To_Top (This : System.Address; Interface_T : Tag; - Offset_Value : System.Storage_Elements.Storage_Offset) + Is_Static : Boolean; + Offset_Value : System.Storage_Elements.Storage_Offset; + Offset_Func : System.Address) is Prim_DT : Tag; Sec_Base : System.Address; @@ -1257,7 +1303,7 @@ package body Ada.Tags is -- "This" points to the primary DT and we must save Offset_Value in the -- Offset_To_Top field of the corresponding secondary dispatch table. - Prim_DT := To_Tag_Ptr (This).all; + Prim_DT := To_Tag_Ptr (This).all; pragma Assert (Check_Signature (Prim_DT, Must_Be_Primary_DT)); @@ -1268,9 +1314,13 @@ package body Ada.Tags is To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top); pragma Assert - (Check_Signature (Sec_DT, Must_Be_Primary_Or_Secondary_DT)); + (Check_Signature (Sec_DT, Must_Be_Secondary_DT)); - Offset_To_Top.all := Offset_Value; + if Is_Static then + Offset_To_Top.all := Offset_Value; + else + Offset_To_Top.all := SSE.Storage_Offset'Last; + end if; -- Save Offset_Value in the table of interfaces of the primary DT. This -- data will be used by the subprogram "Displace" to give support to @@ -1284,7 +1334,14 @@ package body Ada.Tags is if Iface_Table /= null then for Id in 1 .. Iface_Table.Nb_Ifaces loop if Iface_Table.Table (Id).Iface_Tag = Interface_T then - Iface_Table.Table (Id).Offset := Offset_Value; + Iface_Table.Table (Id).Static_Offset_To_Top := Is_Static; + + if Is_Static then + Iface_Table.Table (Id).Offset_To_Top_Value := Offset_Value; + else + Iface_Table.Table (Id).Offset_To_Top_Func := Offset_Func; + end if; + return; end if; end loop; @@ -1307,6 +1364,22 @@ package body Ada.Tags is OSD_Ptr.all := Value; end Set_OSD; + ------------------------------------ + -- Set_Predefined_Prim_Op_Address -- + ------------------------------------ + + procedure Set_Predefined_Prim_Op_Address + (T : Tag; + Position : Positive; + Value : System.Address) + is + Prim_Ops_DT : constant Tag := To_Tag (To_Address (T) - DT_Prologue_Size); + begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); + pragma Assert (Position >= 1 and then Position <= Default_Prim_Op_Count); + Prim_Ops_DT.Prims_Ptr (Position) := Value; + end Set_Predefined_Prim_Op_Address; + ------------------------- -- Set_Prim_Op_Address -- ------------------------- @@ -1318,7 +1391,7 @@ package body Ada.Tags is is begin pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); - pragma Assert (Check_Index (T, Position)); + pragma Assert (Position <= Get_Num_Prim_Ops (T)); T.Prims_Ptr (Position) := Value; end Set_Prim_Op_Address; @@ -1331,12 +1404,10 @@ package body Ada.Tags is Position : Positive; Value : Prim_Op_Kind) is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - SSD (T).SSD_Table (Index).Kind := Value; + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + SSD (T).SSD_Table (Position).Kind := Value; end Set_Prim_Op_Kind; ------------------- @@ -1359,6 +1430,19 @@ package body Ada.Tags is TSD (T).Remotely_Callable := Value; end Set_Remotely_Callable; + ------------------- + -- Set_Signature -- + ------------------- + + procedure Set_Signature (T : Tag; Value : Signature_Kind) is + Signature : constant System.Address := To_Address (T) - K_Signature; + Sig_Ptr : constant Signature_Values_Ptr := + To_Signature_Values_Ptr (Signature); + begin + Sig_Ptr.all (1) := Valid_Signature; + Sig_Ptr.all (2) := Value; + end Set_Signature; + ------------- -- Set_SSD -- ------------- @@ -1426,4 +1510,28 @@ package body Ada.Tags is return To_Type_Specific_Data_Ptr (TSD_Ptr.all); end TSD; + ------------------------ + -- Wide_Expanded_Name -- + ------------------------ + + WC_Encoding : Character; + pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Encoding method for source, as exported by binder + + function Wide_Expanded_Name (T : Tag) return Wide_String is + begin + return String_To_Wide_String + (Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding)); + end Wide_Expanded_Name; + + ----------------------------- + -- Wide_Wide_Expanded_Name -- + ----------------------------- + + function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is + begin + return String_To_Wide_Wide_String + (Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding)); + end Wide_Wide_Expanded_Name; + end Ada.Tags; diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 25fed4f1dcb..bb69544a9d3 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -68,6 +68,12 @@ package Ada.Tags is Tag_Error : exception; + function Wide_Expanded_Name (T : Tag) return Wide_String; + pragma Ada_05 (Wide_Expanded_Name); + + function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String; + pragma Ada_05 (Wide_Wide_Expanded_Name); + private -- The following subprogram specifications are placed here instead of -- the package body to see them from the frontend through rtsfind. @@ -151,11 +157,25 @@ private Default_Prim_Op_Count : constant Positive := 15; -- Number of predefined primitive operations added by the Expander for a - -- tagged type. It is utilized for indexing in the two auxiliary tables - -- used for dispatching asynchronous, conditional and timed selects. In - -- order to be space efficient, indexing is performed by subtracting this - -- constant value from the provided position in the auxiliary tables (must - -- match Exp_Disp.Default_Prim_Op_Count). + -- tagged type (must match Exp_Disp.Default_Prim_Op_Count). + + type Signature_Kind is + (Unknown, + Valid_Signature, + Primary_DT, + Secondary_DT, + Abstract_Interface); + for Signature_Kind'Size use 8; + -- Kind of signature found in the header of the dispatch table. These + -- signatures are generated by the frontend and are used by the Check_XXX + -- routines to ensure that the kind of dispatch table managed by each of + -- the routines in this package is correct. This additional check is only + -- performed with this run-time package is compiled with assertions enabled + + -- The signature is a sequence of two bytes. The first byte must have the + -- value Valid_Signature, and the second byte must have a value in the + -- range Primary_DT .. Abstract_Interface. The Unknown value is used by + -- the Check_XXX routines to indicate that the signature is wrong. package SSE renames System.Storage_Elements; @@ -200,6 +220,13 @@ private -- operation in the DT, retrieve the corresponding operation's position in -- the primary dispatch table from the Offset Specific Data table of T. + function Get_Predefined_Prim_Op_Address + (T : Tag; + Position : Positive) return System.Address; + -- Given a pointer to a dispatch table (T) and a position in the DT + -- this function returns the address of the virtual function stored + -- in it (used for dispatching calls). + function Get_Prim_Op_Address (T : Tag; Position : Positive) return System.Address; @@ -239,9 +266,11 @@ private -- Initialize the TSD of a type knowing the tag of the direct ancestor function Offset_To_Top - (T : Tag) return System.Storage_Elements.Storage_Offset; + (This : System.Address) return System.Storage_Elements.Storage_Offset; -- Returns the current value of the offset_to_top component available in - -- the prologue of the dispatch table. + -- the prologue of the dispatch table. If the parent of the tagged type + -- has discriminants this value is stored in a record component just + -- immediately after the tag component. function OSD (T : Tag) return Object_Specific_Data_Ptr; -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table, @@ -305,7 +334,9 @@ private procedure Set_Offset_To_Top (This : System.Address; Interface_T : Tag; - Offset_Value : System.Storage_Elements.Storage_Offset); + Is_Static : Boolean; + Offset_Value : System.Storage_Elements.Storage_Offset; + Offset_Func : System.Address); -- Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of -- the dispatch table. In primary dispatch tables the value of "This" is -- not required (and the compiler passes always the Null_Address value) and @@ -319,6 +350,14 @@ private -- Given a pointer T to a secondary dispatch table, store the pointer to -- the record containing the Object Specific Data generated by GNAT. + procedure Set_Predefined_Prim_Op_Address + (T : Tag; + Position : Positive; + Value : System.Address); + -- Given a pointer to a dispatch Table (T) and a position in the dispatch + -- table associated with a predefined primitive operation, put the address + -- of the virtual function in it (used for overriding). + procedure Set_Prim_Op_Address (T : Tag; Position : Positive; @@ -342,6 +381,9 @@ private -- Set to true if the type has been declared in a context described -- in E.4 (18). + procedure Set_Signature (T : Tag; Value : Signature_Kind); + -- Given a pointer T to a dispatch table, store the signature id + procedure Set_SSD (T : Tag; Value : System.Address); -- Given a pointer T to a dispatch Table, stores the pointer to the record -- containing the Select Specific Data generated by GNAT. @@ -363,11 +405,15 @@ private -- record containing the Type Specific Data generated by GNAT. DT_Prologue_Size : constant SSE.Storage_Count := - SSE.Storage_Count (4 * (Standard'Address_Size / System.Storage_Unit)); - -- Size of the first part of the dispatch table + SSE.Storage_Count + ((Default_Prim_Op_Count + 4) * + (Standard'Address_Size / System.Storage_Unit)); + -- Size of the hidden part of the dispatch table. It contains the table of + -- predefined primitive operations plus the C++ ABI header. DT_Signature_Size : constant SSE.Storage_Count := - SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + SSE.Storage_Count + (1 * (Standard'Address_Size / System.Storage_Unit)); -- Size of the Signature field of the dispatch table DT_Tagged_Kind_Size : constant SSE.Storage_Count := @@ -375,23 +421,35 @@ private -- Size of the Tagged_Type_Kind field of the dispatch table DT_Offset_To_Top_Size : constant SSE.Storage_Count := - SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + SSE.Storage_Count + (1 * (Standard'Address_Size / + System.Storage_Unit)); -- Size of the Offset_To_Top field of the Dispatch Table DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count := - SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + SSE.Storage_Count + (1 * (Standard'Address_Size / + System.Storage_Unit)); -- Size of the Typeinfo_Ptr field of the Dispatch Table DT_Entry_Size : constant SSE.Storage_Count := - SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + SSE.Storage_Count + (1 * (Standard'Address_Size / System.Storage_Unit)); -- Size of each primitive operation entry in the Dispatch Table + Tag_Size : constant SSE.Storage_Count := + SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + -- Size of each tag + TSD_Prologue_Size : constant SSE.Storage_Count := - SSE.Storage_Count (10 * (Standard'Address_Size / System.Storage_Unit)); + SSE.Storage_Count + (10 * (Standard'Address_Size / + System.Storage_Unit)); -- Size of the first part of the type specific data TSD_Entry_Size : constant SSE.Storage_Count := - SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + SSE.Storage_Count + (1 * (Standard'Address_Size / System.Storage_Unit)); -- Size of each ancestor tag entry in the TSD type Address_Array is array (Natural range <>) of System.Address; @@ -400,24 +458,6 @@ private -- of this type are declared with a dummy size of 1, the actual size -- depending on the number of primitive operations. - type Signature_Kind is - (Unknown, - Valid_Signature, - Primary_DT, - Secondary_DT, - Abstract_Interface); - for Signature_Kind'Size use 8; - -- Kind of signature found in the header of the dispatch table. These - -- signatures are generated by the frontend and are used by the Check_XXX - -- routines to ensure that the kind of dispatch table managed by each of - -- the routines in this package is correct. This additional check is only - -- performed with this run-time package is compiled with assertions enabled - - -- The signature is a sequence of two bytes. The first byte must have the - -- value Valid_Signature, and the second byte must have a value in the - -- range Primary_DT .. Abstract_Interface. The Unknown value is used by - -- the Check_XXX routines to indicate that the signature is wrong. - -- Unchecked Conversions type Addr_Ptr is access System.Address; @@ -427,6 +467,8 @@ private array (1 .. DT_Signature_Size) of Signature_Kind; -- Type used to see the signature as a sequence of Signature_Kind values + type Signature_Values_Ptr is access all Signature_Values; + function To_Addr_Ptr is new Unchecked_Conversion (System.Address, Addr_Ptr); @@ -455,6 +497,13 @@ private new Unchecked_Conversion (System.Storage_Elements.Storage_Offset, Signature_Values); + function To_Signature_Values_Ptr is + new Unchecked_Conversion (System.Address, + Signature_Values_Ptr); + + function To_Tag is + new Unchecked_Conversion (System.Address, Tag); + function To_Tag_Ptr is new Unchecked_Conversion (System.Address, Tag_Ptr); @@ -470,6 +519,7 @@ private pragma Inline_Always (Get_Access_Level); pragma Inline_Always (Get_Entry_Index); pragma Inline_Always (Get_Offset_Index); + pragma Inline_Always (Get_Predefined_Prim_Op_Address); pragma Inline_Always (Get_Prim_Op_Address); pragma Inline_Always (Get_Prim_Op_Kind); pragma Inline_Always (Get_RC_Offset); @@ -488,10 +538,12 @@ private pragma Inline_Always (Set_Num_Prim_Ops); pragma Inline_Always (Set_Offset_Index); pragma Inline_Always (Set_Offset_To_Top); + pragma Inline_Always (Set_Predefined_Prim_Op_Address); pragma Inline_Always (Set_Prim_Op_Address); pragma Inline_Always (Set_Prim_Op_Kind); pragma Inline_Always (Set_RC_Offset); pragma Inline_Always (Set_Remotely_Callable); + pragma Inline_Always (Set_Signature); pragma Inline_Always (Set_OSD); pragma Inline_Always (Set_SSD); pragma Inline_Always (Set_TSD); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 6a975e6d68a..62cfb4ed4d9 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -51,6 +51,7 @@ with Sem; use Sem; with Sem_Attr; use Sem_Attr; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; +with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; @@ -237,6 +238,17 @@ package body Exp_Ch3 is -- discriminant_checking functions of the parent can be reused by -- a derived type. + procedure Make_Controlling_Function_Wrappers + (Tag_Typ : Entity_Id; + Decl_List : out List_Id; + Body_List : out List_Id); + -- Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions + -- associated with inherited functions with controlling results which + -- are not overridden. The body of each wrapper function consists solely + -- of a return statement whose expression is an extension aggregate + -- invoking the inherited subprogram's parent subprogram and extended + -- with a null association list. + function Predef_Spec_Or_Body (Loc : Source_Ptr; Tag_Typ : Entity_Id; @@ -1097,6 +1109,7 @@ package body Exp_Ch3 is -- honest. Actually it isn't quite type honest, because there can be -- conflicts of views in the private type case. That is why we set -- Conversion_OK in the conversion node. + if (Is_Record_Type (Typ) or else Is_Array_Type (Typ) or else Is_Private_Type (Typ)) @@ -1241,6 +1254,7 @@ package body Exp_Ch3 is if With_Default_Init and then Nkind (Id_Ref) = N_Selected_Component + and then Nkind (Arg) = N_Identifier then Append_To (Args, Make_Selected_Component (Loc, @@ -1403,6 +1417,11 @@ package body Exp_Ch3 is -- of the initialization procedure (by calling all the preceding -- auxiliary routines), and install it as the _init TSS. + procedure Build_Offset_To_Top_Functions; + -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec + -- and body of the Offset_To_Top function that is generated when the + -- parent of a type with discriminants has secondary dispatch tables. + procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id); -- Add range checks to components of disciminated records. S is a -- subtype indication of a record component. Check_List is a list @@ -1577,7 +1596,7 @@ package body Exp_Ch3 is while Present (D) loop -- Don't generate the assignment for discriminants in derived -- tagged types if the discriminant is a renaming of some - -- ancestor discriminant. This initialization will be done + -- ancestor discriminant. This initialization will be done -- when initializing the _parent field of the derived record. if Is_Tagged and then @@ -1726,6 +1745,127 @@ package body Exp_Ch3 is return Res; end Build_Init_Call_Thru; + ----------------------------------- + -- Build_Offset_To_Top_Functions -- + ----------------------------------- + + procedure Build_Offset_To_Top_Functions is + ADT : Elmt_Id; + Body_Node : Node_Id; + Func_Id : Entity_Id; + Spec_Node : Node_Id; + E : Entity_Id; + + procedure Build_Offset_To_Top_Internal (Typ : Entity_Id); + -- Internal subprogram used to recursively traverse all the ancestors + + ---------------------------------- + -- Build_Offset_To_Top_Internal -- + ---------------------------------- + + procedure Build_Offset_To_Top_Internal (Typ : Entity_Id) is + begin + -- Climb to the ancestor (if any) handling private types + + if Present (Full_View (Etype (Typ))) then + if Full_View (Etype (Typ)) /= Typ then + Build_Offset_To_Top_Internal (Full_View (Etype (Typ))); + end if; + + elsif Etype (Typ) /= Typ then + Build_Offset_To_Top_Internal (Etype (Typ)); + end if; + + if Present (Abstract_Interfaces (Typ)) + and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) + then + E := First_Entity (Typ); + while Present (E) loop + if Is_Tag (E) + and then Chars (E) /= Name_uTag + then + if Typ = Rec_Type then + Body_Node := New_Node (N_Subprogram_Body, Loc); + + Func_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('F')); + + Set_DT_Offset_To_Top_Func (E, Func_Id); + + Spec_Node := New_Node (N_Function_Specification, Loc); + Set_Defining_Unit_Name (Spec_Node, Func_Id); + Set_Parameter_Specifications (Spec_Node, New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + In_Present => True, + Parameter_Type => New_Reference_To (Typ, Loc)))); + Set_Result_Definition (Spec_Node, + New_Reference_To (RTE (RE_Storage_Offset), Loc)); + + Set_Specification (Body_Node, Spec_Node); + Set_Declarations (Body_Node, New_List); + Set_Handled_Statement_Sequence (Body_Node, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, + Name_uO), + Selector_Name => New_Reference_To + (E, Loc)), + Attribute_Name => Name_Position))))); + + Set_Ekind (Func_Id, E_Function); + Set_Mechanism (Func_Id, Default_Mechanism); + Set_Is_Internal (Func_Id, True); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Func_Id); + end if; + + Analyze (Body_Node); + + Append_Freeze_Action (Rec_Type, Body_Node); + end if; + + Next_Elmt (ADT); + end if; + + Next_Entity (E); + end loop; + end if; + end Build_Offset_To_Top_Internal; + + -- Start of processing for Build_Offset_To_Top_Functions + + begin + if Etype (Rec_Type) = Rec_Type + or else not Has_Discriminants (Etype (Rec_Type)) + or else No (Abstract_Interfaces (Rec_Type)) + or else Is_Empty_Elmt_List (Abstract_Interfaces (Rec_Type)) + then + return; + end if; + + -- Skip the first _Tag, which is the main tag of the + -- tagged type. Following tags correspond with abstract + -- interfaces. + + ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Rec_Type))); + + -- Handle private types + + if Present (Full_View (Rec_Type)) then + Build_Offset_To_Top_Internal (Full_View (Rec_Type)); + else + Build_Offset_To_Top_Internal (Rec_Type); + end if; + end Build_Offset_To_Top_Functions; + -------------------------- -- Build_Init_Procedure -- -------------------------- @@ -1758,9 +1898,10 @@ package body Exp_Ch3 is ---------------------------------- procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is - E : Entity_Id; - Aux_N : Node_Id; - Iface : Entity_Id; + Aux_N : Node_Id; + E : Entity_Id; + Iface : Entity_Id; + Prev_E : Entity_Id; begin -- Climb to the ancestor (if any) handling private types @@ -1800,33 +1941,132 @@ package body Exp_Ch3 is Expression => New_Reference_To (Aux_N, Loc))); - -- Generate: - -- Set_Offset_To_Top (Init, Iface'Tag, n); + -- Issue error if Set_Offset_To_Top is not available + -- in a configurable run-time environment. - Append_To (Body_Stmts, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To - (RTE (RE_Set_Offset_To_Top), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Attribute_Name => Name_Address), - - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To - (Node (First_Elmt - (Access_Disp_Table (Iface))), - Loc)), - - Unchecked_Convert_To (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, - Name_uInit), - Selector_Name => New_Reference_To - (E, Loc)), - Attribute_Name => Name_Position))))); + if not RTE_Available (RE_Set_Offset_To_Top) then + Error_Msg_CRT ("abstract interface types", Typ); + return; + end if; + + -- We generate a different call to Set_Offset_To_Top + -- when the parent of the type has discriminants + + if Typ /= Etype (Typ) + and then Has_Discriminants (Etype (Typ)) + then + pragma Assert (Present (DT_Offset_To_Top_Func (E))); + + -- Generate: + -- Set_Offset_To_Top + -- (This => Init, + -- Interface_T => Iface'Tag, + -- Is_Constant => False, + -- Offset_Value => n, + -- Offset_Func => Fn'Address) + + Append_To (Body_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To + (RTE (RE_Set_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, + Name_uInit), + Attribute_Name => Name_Address), + + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt + (Access_Disp_Table (Iface))), + Loc)), + + New_Occurrence_Of (Standard_False, Loc), + + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, + Name_uInit), + Selector_Name => New_Reference_To + (E, Loc)), + Attribute_Name => Name_Position)), + + Unchecked_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To + (DT_Offset_To_Top_Func (E), + Loc), + Attribute_Name => + Name_Address))))); + + -- In this case the next component stores the value + -- of the offset to the top + + Prev_E := E; + Next_Entity (E); + pragma Assert (Present (E)); + + Append_To (Body_Stmts, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, + Name_uInit), + Selector_Name => + New_Reference_To (E, Loc)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, + Name_uInit), + Selector_Name => New_Reference_To + (Prev_E, Loc)), + Attribute_Name => Name_Position))); + + -- Normal case: No discriminants in the parent type + + else + -- Generate: + -- Set_Offset_To_Top + -- (This => Init, + -- Interface_T => Iface'Tag, + -- Is_Constant => True, + -- Offset_Value => n, + -- Offset_Func => null); + + Append_To (Body_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To + (RTE (RE_Set_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Address), + + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt + (Access_Disp_Table (Iface))), + Loc)), + + New_Occurrence_Of (Standard_True, Loc), + + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, + Name_uInit), + Selector_Name => New_Reference_To + (E, Loc)), + Attribute_Name => Name_Position)), + + New_Reference_To + (RTE (RE_Null_Address), Loc)))); + end if; Next_Elmt (ADT); end if; @@ -1897,8 +2137,9 @@ package body Exp_Ch3 is if Parent_Subtype_Renaming_Discrims then -- N is a Derived_Type_Definition that renames the parameters - -- of the ancestor type. We init it by expanding our discrims - -- and call the ancestor _init_proc with a type-converted object + -- of the ancestor type. We initialize it by expanding our + -- discriminants and call the ancestor _init_proc with a + -- type-converted object Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters)); @@ -1945,7 +2186,9 @@ package body Exp_Ch3 is -- _Init._Tag := Typ'Tag; -- Suppress the tag assignment when Java_VM because JVM tags are - -- represented implicitly in objects. + -- represented implicitly in objects. It is also suppressed in + -- case of CPP_Class types because in this case the tag is + -- initialized in the C++ side. if Is_Tagged_Type (Rec_Type) and then not Is_CPP_Class (Rec_Type) @@ -2375,7 +2618,10 @@ package body Exp_Ch3 is Needs_Simple_Initialization (T) and then not Is_RTE (T, RE_Tag) and then not Is_RTE (T, RE_Vtable_Ptr) - and then not Is_RTE (T, RE_Interface_Tag); -- Ada 2005 (AI-251) + + -- Ada 2005 (AI-251): Check also the tag of abstract interfaces + + and then not Is_RTE (T, RE_Interface_Tag); end Component_Needs_Simple_Initialization; --------------------- @@ -2552,7 +2798,8 @@ package body Exp_Ch3 is -- since the call is generated, there had better be a routine -- at the other end of the call, even if it does nothing!) - -- Note: the reason we exclude the CPP_Class case is ??? + -- Note: the reason we exclude the CPP_Class case is because in this + -- case the initialization is performed in the C++ side. if Is_CPP_Class (Rec_Id) then return False; @@ -2647,6 +2894,7 @@ package body Exp_Ch3 is elsif Requires_Init_Proc (Rec_Type) or else Is_Unchecked_Union (Rec_Type) then + Build_Offset_To_Top_Functions; Build_Init_Procedure; Set_Is_Public (Proc_Id, Is_Public (Pe)); @@ -3342,7 +3590,7 @@ package body Exp_Ch3 is if Is_Access_Type (Def_Id) then -- Anonymous access types are created for the components of the - -- record parameter for an entry declaration. No master is created + -- record parameter for an entry declaration. No master is created -- for such a type. if Has_Task (Designated_Type (Def_Id)) @@ -3352,17 +3600,22 @@ package body Exp_Ch3 is Build_Master_Renaming (Parent (Def_Id), Def_Id); -- Create a class-wide master because a Master_Id must be generated - -- for access-to-limited-class-wide types, whose root may be extended - -- with task components. + -- for access-to-limited-class-wide types whose root may be extended + -- with task components, and for access-to-limited-interfaces because + -- they can be used to reference tasks implementing such interface. elsif Is_Class_Wide_Type (Designated_Type (Def_Id)) - and then Is_Limited_Type (Designated_Type (Def_Id)) + and then (Is_Limited_Type (Designated_Type (Def_Id)) + or else + (Is_Interface (Designated_Type (Def_Id)) + and then + Is_Limited_Interface (Designated_Type (Def_Id)))) and then Tasking_Allowed - -- Don't create a class-wide master for types whose convention is + -- Do not create a class-wide master for types whose convention is -- Java since these types cannot embed Ada tasks anyway. Note that -- the following test cannot catch the following case: - -- + -- package java.lang.Object is -- type Typ is tagged limited private; -- type Ref is access all Typ'Class; @@ -3370,7 +3623,7 @@ package body Exp_Ch3 is -- type Typ is tagged limited ...; -- pragma Convention (Typ, Java) -- end; - -- + -- Because the convention appears after we have done the -- processing for type Ref. @@ -3487,7 +3740,7 @@ package body Exp_Ch3 is if No (Expr) then - -- Expand Initialize call for controlled objects. One may wonder why + -- Expand Initialize call for controlled objects. One may wonder why -- the Initialize Call is not done in the regular Init procedure -- attached to the record type. That's because the init procedure is -- recursively called on each component, including _Parent, thus the @@ -3591,21 +3844,27 @@ package body Exp_Ch3 is -- Generate attribute for Persistent_BSS if needed - declare - Prag : Node_Id; - begin - if Persistent_BSS_Mode - and then Comes_From_Source (N) - and then Is_Potentially_Persistent_Type (Typ) - and then Is_Library_Level_Entity (Def_Id) - then + if Persistent_BSS_Mode + and then Comes_From_Source (N) + and then Is_Potentially_Persistent_Type (Typ) + and then Is_Library_Level_Entity (Def_Id) + then + declare + Prag : Node_Id; + begin Prag := Make_Linker_Section_Pragma (Def_Id, Sloc (N), ".persistent.bss"); Insert_After (N, Prag); Analyze (Prag); - end if; - end; + end; + end if; + + -- If access type, then we know it is null if not initialized + + if Is_Access_Type (Typ) then + Set_Is_Known_Null (Def_Id); + end if; -- Explicit initialization present @@ -3618,23 +3877,23 @@ package body Exp_Ch3 is Expr_Q := Expr; end if; - -- When we have the appropriate type of aggregate in the - -- expression (it has been determined during analysis of the - -- aggregate by setting the delay flag), let's perform in - -- place assignment and thus avoid creating a temporary. + -- When we have the appropriate type of aggregate in the expression + -- (it has been determined during analysis of the aggregate by + -- setting the delay flag), let's perform in place assignment and + -- thus avoid creating a temporary. if Is_Delayed_Aggregate (Expr_Q) then Convert_Aggr_In_Object_Decl (N); else - -- In most cases, we must check that the initial value meets - -- any constraint imposed by the declared type. However, there - -- is one very important exception to this rule. If the entity - -- has an unconstrained nominal subtype, then it acquired its - -- constraints from the expression in the first place, and not - -- only does this mean that the constraint check is not needed, - -- but an attempt to perform the constraint check can - -- cause order of elaboration problems. + -- In most cases, we must check that the initial value meets any + -- constraint imposed by the declared type. However, there is one + -- very important exception to this rule. If the entity has an + -- unconstrained nominal subtype, then it acquired its constraints + -- from the expression in the first place, and not only does this + -- mean that the constraint check is not needed, but an attempt to + -- perform the constraint check can cause order order of + -- elaboration problems. if not Is_Constr_Subt_For_U_Nominal (Typ) then @@ -3653,6 +3912,7 @@ package body Exp_Ch3 is -- If the type is controlled we attach the object to the final -- list and adjust the target after the copy. This + -- ??? incomplete sentence if Controlled_Type (Typ) then declare @@ -3662,10 +3922,10 @@ package body Exp_Ch3 is begin -- Attach the result to a dummy final list which will never -- be finalized if Delay_Finalize_Attachis set. It is - -- important to attach to a dummy final list rather than - -- not attaching at all in order to reset the pointers - -- coming from the initial value. Equivalent code exists - -- in the sec-stack case in Exp_Ch4.Expand_N_Allocator. + -- important to attach to a dummy final list rather than not + -- attaching at all in order to reset the pointers coming + -- from the initial value. Equivalent code exists in the + -- sec-stack case in Exp_Ch4.Expand_N_Allocator. if Delay_Finalize_Attach (N) then F := @@ -3694,11 +3954,11 @@ package body Exp_Ch3 is -- For tagged types, when an init value is given, the tag has to -- be re-initialized separately in order to avoid the propagation -- of a wrong tag coming from a view conversion unless the type - -- is class wide (in this case the tag comes from the init - -- value). Suppress the tag assignment when Java_VM because JVM - -- tags are represented implicitly in objects. Ditto for types - -- that are CPP_CLASS, and for initializations that are - -- aggregates, because they have to have the right tag. + -- is class wide (in this case the tag comes from the init value). + -- Suppress the tag assignment when Java_VM because JVM tags are + -- represented implicitly in objects. Ditto for types that are + -- CPP_CLASS, and for initializations that are aggregates, because + -- they have to have the right tag. if Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) @@ -3706,8 +3966,8 @@ package body Exp_Ch3 is and then not Java_VM and then Nkind (Expr) /= N_Aggregate then - -- The re-assignment of the tag has to be done even if - -- the object is a constant + -- The re-assignment of the tag has to be done even if the + -- object is a constant. New_Ref := Make_Selected_Component (Loc, @@ -3731,9 +3991,7 @@ package body Exp_Ch3 is -- For discrete types, set the Is_Known_Valid flag if the -- initializing value is known to be valid. - elsif Is_Discrete_Type (Typ) - and then Expr_Known_Valid (Expr) - then + elsif Is_Discrete_Type (Typ) and then Expr_Known_Valid (Expr) then Set_Is_Known_Valid (Def_Id); elsif Is_Access_Type (Typ) then @@ -3743,7 +4001,7 @@ package body Exp_Ch3 is -- Can_Never_Be_Null if this is a constant. if Known_Non_Null (Expr) then - Set_Is_Known_Non_Null (Def_Id); + Set_Is_Known_Non_Null (Def_Id, True); if Constant_Present (N) then Set_Can_Never_Be_Null (Def_Id); @@ -3761,19 +4019,19 @@ package body Exp_Ch3 is end if; end if; - -- Cases where the back end cannot handle the initialization - -- directly. In such cases, we expand an assignment that will - -- be appropriately handled by Expand_N_Assignment_Statement. + -- Cases where the back end cannot handle the initialization directly + -- In such cases, we expand an assignment that will be appropriately + -- handled by Expand_N_Assignment_Statement. - -- The exclusion of the unconstrained case is wrong, but for - -- now it is too much trouble ??? + -- The exclusion of the unconstrained case is wrong, but for now it + -- is too much trouble ??? if (Is_Possibly_Unaligned_Slice (Expr) or else (Is_Possibly_Unaligned_Object (Expr) and then not Represented_As_Scalar (Etype (Expr)))) - -- The exclusion of the unconstrained case is wrong, but for - -- now it is too much trouble ??? + -- The exclusion of the unconstrained case is wrong, but for now + -- it is too much trouble ??? and then not (Is_Array_Type (Etype (Expr)) and then not Is_Constrained (Etype (Expr))) @@ -4427,6 +4685,9 @@ package body Exp_Ch3 is Renamed_Eq : Node_Id := Empty; -- Could use some comments ??? + Wrapper_Decl_List : List_Id := No_List; + Wrapper_Body_List : List_Id := No_List; + begin -- Build discriminant checking functions if not a derived type (for -- derived types that are not tagged types, we always use the @@ -4508,6 +4769,17 @@ package body Exp_Ch3 is if Is_Tagged_Type (Def_Id) then if Is_CPP_Class (Def_Id) then + + -- Because of the new C++ ABI compatibility we now allow the + -- programer to use the Ada tag (and in this case we must do + -- the normal expansion of the tag) + + if Etype (First_Component (Def_Id)) = RTE (RE_Tag) + and then Underlying_Type (Etype (Def_Id)) = Def_Id + then + Expand_Tagged_Root (Def_Id); + end if; + Set_All_DT_Position (Def_Id); Set_Default_Constructor (Def_Id); @@ -4562,6 +4834,21 @@ package body Exp_Ch3 is (Def_Id, Predef_List, Renamed_Eq); Insert_List_Before_And_Analyze (N, Predef_List); + -- Ada 2005 (AI-391): For a nonabstract null extension, create + -- wrapper functions for each nonoverridden inherited function + -- with a controlling result of the type. The wrapper for such + -- a function returns an extension aggregate that invokes the + -- the parent function. + + if Ada_Version >= Ada_05 + and then not Is_Abstract (Def_Id) + and then Is_Null_Extension (Def_Id) + then + Make_Controlling_Function_Wrappers + (Def_Id, Wrapper_Decl_List, Wrapper_Body_List); + Insert_List_Before_And_Analyze (N, Wrapper_Decl_List); + end if; + Set_Is_Frozen (Def_Id, True); Set_All_DT_Position (Def_Id); @@ -4752,11 +5039,19 @@ package body Exp_Ch3 is Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); Append_Freeze_Actions (Def_Id, Predef_List); + -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden + -- inherited functions, then add their bodies to the freeze actions. + + if Present (Wrapper_Body_List) then + Append_Freeze_Actions (Def_Id, Wrapper_Body_List); + end if; + -- Populate the two auxiliary tables used for dispatching -- asynchronous, conditional and timed selects for synchronized -- types that implement a limited interface. if Ada_Version >= Ada_05 + and then not Restriction_Active (No_Dispatching_Calls) and then Is_Concurrent_Record_Type (Def_Id) and then Implements_Interface ( Typ => Def_Id, @@ -5022,7 +5317,7 @@ package body Exp_Ch3 is -- code requires both those types to be frozen if Is_Frozen (Desig_Type) - and then (not Present (Freeze_Node (Desig_Type)) + and then (No (Freeze_Node (Desig_Type)) or else Analyzed (Freeze_Node (Desig_Type))) then Freeze_Action_Typ := Def_Id; @@ -5608,6 +5903,167 @@ package body Exp_Ch3 is return Empty_List; end Init_Formals; + ------------------------------------- + -- Make_Predefined_Primitive_Specs -- + ------------------------------------- + + procedure Make_Controlling_Function_Wrappers + (Tag_Typ : Entity_Id; + Decl_List : out List_Id; + Body_List : out List_Id) + is + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Prim_Elmt : Elmt_Id; + Subp : Entity_Id; + Actual_List : List_Id; + Formal_List : List_Id; + Formal : Entity_Id; + Par_Formal : Entity_Id; + Formal_Node : Node_Id; + Func_Spec : Node_Id; + Func_Decl : Node_Id; + Func_Body : Node_Id; + Return_Stmt : Node_Id; + + begin + Decl_List := New_List; + Body_List := New_List; + + Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + + while Present (Prim_Elmt) loop + Subp := Node (Prim_Elmt); + + -- If a primitive function with a controlling result of the type has + -- not been overridden by the user, then we must create a wrapper + -- function here that effectively overrides it and invokes the + -- abstract inherited function's nonabstract parent. This can only + -- occur for a null extension. Note that functions with anonymous + -- controlling access results don't qualify and must be overridden. + -- We also exclude Input attributes, since each type will have its + -- own version of Input constructed by the expander. The test for + -- Comes_From_Source is needed to distinguish inherited operations + -- from renamings (which also have Alias set). + + if Is_Abstract (Subp) + and then Present (Alias (Subp)) + and then not Comes_From_Source (Subp) + and then Ekind (Subp) = E_Function + and then Has_Controlling_Result (Subp) + and then not Is_Access_Type (Etype (Subp)) + and then not Is_TSS (Subp, TSS_Stream_Input) + then + Formal_List := No_List; + Formal := First_Formal (Subp); + + if Present (Formal) then + Formal_List := New_List; + + while Present (Formal) loop + Append + (Make_Parameter_Specification + (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal)), + In_Present => In_Present (Parent (Formal)), + Out_Present => Out_Present (Parent (Formal)), + Parameter_Type => + New_Reference_To (Etype (Formal), Loc), + Expression => + New_Copy_Tree (Expression (Parent (Formal)))), + Formal_List); + + Next_Formal (Formal); + end loop; + end if; + + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars (Subp)), + Parameter_Specifications => + Formal_List, + Result_Definition => + New_Reference_To (Etype (Subp), Loc)); + + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + Append_To (Decl_List, Func_Decl); + + -- Build a wrapper body that calls the parent function. The body + -- contains a single return statement that returns an extension + -- aggregate whose ancestor part is a call to the parent function, + -- passing the formals as actuals (with any controlling arguments + -- converted to the types of the corresponding formals of the + -- parent function, which might be anonymous access types), and + -- having a null extension. + + Formal := First_Formal (Subp); + Par_Formal := First_Formal (Alias (Subp)); + Formal_Node := First (Formal_List); + + if Present (Formal) then + Actual_List := New_List; + else + Actual_List := No_List; + end if; + + while Present (Formal) loop + if Is_Controlling_Formal (Formal) then + Append_To (Actual_List, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Par_Formal), Loc), + Expression => + New_Reference_To + (Defining_Identifier (Formal_Node), Loc))); + else + Append_To + (Actual_List, + New_Reference_To + (Defining_Identifier (Formal_Node), Loc)); + end if; + + Next_Formal (Formal); + Next_Formal (Par_Formal); + Next (Formal_Node); + end loop; + + Return_Stmt := + Make_Return_Statement (Loc, + Expression => + Make_Extension_Aggregate (Loc, + Ancestor_Part => + Make_Function_Call (Loc, + Name => New_Reference_To (Alias (Subp), Loc), + Parameter_Associations => Actual_List), + Null_Record_Present => True)); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => New_Copy_Tree (Func_Spec), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Return_Stmt))); + + Set_Defining_Unit_Name + (Specification (Func_Body), + Make_Defining_Identifier (Loc, Chars (Subp))); + + Append_To (Body_List, Func_Body); + + -- Replace the inherited function with the wrapper function + -- in the primitive operations list. + + Override_Dispatching_Operation + (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec)); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end Make_Controlling_Function_Wrappers; + ------------------ -- Make_Eq_Case -- ------------------ @@ -6370,6 +6826,8 @@ package body Exp_Ch3 is -- limited interface. The interface versions will have null bodies. if Ada_Version >= Ada_05 + and then + not Restriction_Active (No_Dispatching_Calls) and then ((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ)) or else diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 3b4522c85f9..acc7ac925db 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -502,6 +502,7 @@ package Rtsfind is RE_Get_Entry_Index, -- Ada.Tags RE_Get_External_Tag, -- Ada.Tags RE_Get_Offset_Index, -- Ada.Tags + RE_Get_Predefined_Prim_Op_Address, -- Ada.Tags RE_Get_Prim_Op_Address, -- Ada.Tags RE_Get_Prim_Op_Kind, -- Ada.Tags RE_Get_RC_Offset, -- Ada.Tags @@ -539,11 +540,13 @@ package Rtsfind is RE_Set_Offset_Index, -- Ada.Tags RE_Set_Offset_To_Top, -- Ada.Tags RE_Set_OSD, -- Ada.Tags + RE_Set_Predefined_Prim_Op_Address, -- Ada.Tags RE_Set_Prim_Op_Address, -- Ada.Tags RE_Set_Prim_Op_Kind, -- Ada.Tags RE_Set_RC_Offset, -- Ada.Tags RE_Set_Remotely_Callable, -- Ada.Tags RE_Set_SSD, -- Ada.Tags + RE_Set_Signature, -- Ada.Tags RE_Set_Tagged_Kind, -- Ada.Tags RE_Set_TSD, -- Ada.Tags RE_Tag, -- Ada.Tags @@ -1656,6 +1659,7 @@ package Rtsfind is RE_Get_Entry_Index => Ada_Tags, RE_Get_External_Tag => Ada_Tags, RE_Get_Offset_Index => Ada_Tags, + RE_Get_Predefined_Prim_Op_Address => Ada_Tags, RE_Get_Prim_Op_Address => Ada_Tags, RE_Get_Prim_Op_Kind => Ada_Tags, RE_Get_RC_Offset => Ada_Tags, @@ -1693,11 +1697,13 @@ package Rtsfind is RE_Set_Offset_Index => Ada_Tags, RE_Set_Offset_To_Top => Ada_Tags, RE_Set_OSD => Ada_Tags, + RE_Set_Predefined_Prim_Op_Address => Ada_Tags, RE_Set_Prim_Op_Address => Ada_Tags, RE_Set_Prim_Op_Kind => Ada_Tags, RE_Set_RC_Offset => Ada_Tags, RE_Set_Remotely_Callable => Ada_Tags, RE_Set_SSD => Ada_Tags, + RE_Set_Signature => Ada_Tags, RE_Set_Tagged_Kind => Ada_Tags, RE_Set_TSD => Ada_Tags, RE_Tag => Ada_Tags, -- 2.30.2