From f2cbd970083b0c0af05fb2cfca08ad4e8d02dc41 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Tue, 8 Apr 2008 08:47:55 +0200 Subject: [PATCH] a-tags.adb (Register_Interface_Offset): New subprogram. 2008-04-08 Javier Miranda Robert Dewar Ed Schonberg * a-tags.adb (Register_Interface_Offset): New subprogram. (Set_Dynamic_Offset_To_Top): New subprogram (see previous comment). (To_Predef_Prims_Table_Ptr): Removed. (Acc_Size): Removed. (To_Acc_Size): Removed. (Parent_Size): Modified to the call the subprogram returning the size of the parent by means of the new TSD component Size_Func. * a-tags.ads (Offset_To_Top_Ptr): New access type declaration. (DT_Offset_To_Top_Offset): New constant value that is used to generate code referencing the Offset_To_Top component of the dispatch table's prologue. (Prim_Ptr): New declaration of access to procedure. Used to avoid the use of 'address to initialize dispatch table slots. (Size_Func): New component of the TSD. Used by the run-time to call the size primitive of the tagged type. * checks.adb (Apply_Access_Check): Avoid check when accessing the Offset_To_Top component of a dispatch table. (Null_Exclusion_Static_Checks): If the non-null access type appears in a deferred constant declaration. do not add a null expression, to prevent spurious errors when full declaration is analyzed. (Apply_Discriminant_Check): If both discriminant constraints share a node which is not static but has no side effects, do not generate a check for that discriminant. (Generate_Index_Checks): Set Name_Req to true in call to duplicate subexpr, since the prefix of an attribute is a name. * checks.ads: Fix nit in comment. * exp_ch3.ads, exp_ch3.adb (Freeze_Record_Type): Do not add the spec and body of predefined primitives in case of CPP tagged type derivations. (Freeze_Type): Deal properly with no storage pool case (Make_Predefined_Primitive_Specs): Generate specification of abstract primitive Deep_Adjust if a nonlimited interface is derived from a limited interface. (Build_Dcheck_Functions): Create discriminant-checking functions only for variants that have some component(s). (Build_Slice_Assignment): In expanded code for slice assignment, handle properly the case where the slice bounds extend to the last value of the underlying representation. (Get_Simple_Init_Val): New calling sequence, accomodate Invalid_Value (Is_Variable_Size_Record): An array component has a static size if index bounds are enumeration literals. * exp_disp.adb (Make_DT): Use the first subtype to determine whether an external tag has been specified for the type. (Building_Static_DT): Add missing support for private types. (Make_DT): Add declaration of Parent_Typ to ensure consistent access to the entity associated with the parent of Typ. This is done to avoid wrong access when the parent is a private type. (Expand_Interface_Conversion): Improve error message when the configurable runtime has no support for dynamic interface conversion. (Expand_Interface_Thunk): Add missing support to interface types in configurable runtime. (Expand_Dispatching_Call): remove obsolete code. (Make_DT): Replace occurrences of RE_Address by RE_Prim_Ptr, and ensure that all subtypes and aggregates associated with dispatch tables have the attribute Is_Dispatch_Table_Entity set to true. (Register_Primitive): Rename one variable to improve code reading. Replace occurrences of RE_Addres by RE_Prim_Ptr. Register copy o of the pointer to the 'size primitive in the TSD. * rtsfind.ads (RE_DT_Offset_To_Top_Offset): New entity. (RE_Offset_To_Top_Ptr): New entity. (RE_Register_Interface_Offset): New entity. (RE_Set_Dynamic_Offset_To_Top): New entity. (RE_Set_Offset_To_Top): Removed entity. (RE_Prim_Ptr): New entity (RE_Size_Func): New entity (RE_Size_Ptr): New entity (RTU_Id): Add Ada_Dispatching and Ada_Dispatching_EDF. (Ada_Dispatching_Child): Define this new subrange. (RE_Id): Add new required run-time calls (RE_Set_Deadline, RE_Clock, RE_Time_Span, and RE_Time_Span_Zero). (RE_Unit_Table): Add new required run-time calls * rtsfind.adb (Get_Unit_Name): Add processing for Ada.Dispatching children. * exp_atag.ads, exp_atag.adb (Build_Offset_To_Top): New subprogram. (Build_Set_Static_Offset_To_Top): New subprogram. Generates code that initializes the Offset_To_Top component of a dispatch table. (Build_Predef_Prims): Removed. (Build_Get_Predefined_Prim_Op_Address): Replace call to Predef_Prims by its actual code. (Build_Set_Size_Function): New subprogram. * exp_ch13.adb: Do not generate storage variable for storage_size zero (Expand): Handle setting/restoring flag Inside_Freezing_Actions From-SVN: r134020 --- gcc/ada/a-tags.adb | 151 +++++++-------- gcc/ada/a-tags.ads | 69 +++++-- gcc/ada/checks.adb | 63 ++++-- gcc/ada/checks.ads | 4 +- gcc/ada/exp_atag.adb | 144 ++++++++++---- gcc/ada/exp_atag.ads | 34 +++- gcc/ada/exp_ch13.adb | 47 +++-- gcc/ada/exp_ch3.adb | 319 +++++++++++++++++++----------- gcc/ada/exp_ch3.ads | 22 ++- gcc/ada/exp_disp.adb | 448 +++++++++++++++++++++++++++++-------------- gcc/ada/rtsfind.adb | 9 +- gcc/ada/rtsfind.ads | 83 +++++++- 12 files changed, 938 insertions(+), 455 deletions(-) diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 522a826fc06..3f841c622f4 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -105,25 +105,12 @@ package body Ada.Tags is function To_Object_Specific_Data_Ptr is new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); - function To_Predef_Prims_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Predef_Prims_Table_Ptr); - function To_Tag_Ptr is new Ada.Unchecked_Conversion (System.Address, Tag_Ptr); function To_Type_Specific_Data_Ptr is new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); - ------------------------------------------------ - -- Unchecked Conversions for other components -- - ------------------------------------------------ - - type Acc_Size - is access function (A : System.Address) return Long_Long_Integer; - - function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size); - -- The profile of the implicitly defined _size primitive - ------------------------------- -- Inline_Always Subprograms -- ------------------------------- @@ -733,7 +720,7 @@ package body Ada.Tags is begin Len := 1; - while Str (Len) /= ASCII.Nul loop + while Str (Len) /= ASCII.NUL loop Len := Len + 1; end loop; @@ -778,35 +765,23 @@ package body Ada.Tags is -- The tag of the parent is always in the first slot of the table of -- ancestor tags. - Size_Slot : constant Positive := 1; - -- The pointer to the _size primitive is always in the first slot of - -- the dispatch table. - TSD_Ptr : constant Addr_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); TSD : constant Type_Specific_Data_Ptr := To_Type_Specific_Data_Ptr (TSD_Ptr.all); -- Pointer to the TSD - Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot); - Parent_Predef_Prims_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (Parent_Tag) - - DT_Predef_Prims_Offset); - Parent_Predef_Prims : constant Predef_Prims_Table_Ptr := - To_Predef_Prims_Table_Ptr - (Parent_Predef_Prims_Ptr.all); - - -- The tag of the parent type through the dispatch table and its - -- Predef_Prims field. - - F : constant Acc_Size := - To_Acc_Size (Parent_Predef_Prims (Size_Slot)); - -- Access to the _size primitive of the parent + Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot); + Parent_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Parent_Tag) + - DT_Typeinfo_Ptr_Size); + Parent_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all); begin -- Here we compute the size of the _parent field of the object - return SSE.Storage_Count (F.all (Obj)); + return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj)); end Parent_Size; ---------------- @@ -837,6 +812,56 @@ package body Ada.Tags is end if; end Parent_Tag; + ------------------------------- + -- Register_Interface_Offset -- + ------------------------------- + + procedure Register_Interface_Offset + (This : System.Address; + Interface_T : Tag; + Is_Static : Boolean; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr) + is + Prim_DT : Dispatch_Table_Ptr; + Iface_Table : Interface_Data_Ptr; + + begin + -- "This" points to the primary DT and we must save Offset_Value in + -- the Offset_To_Top field of the corresponding dispatch table. + + Prim_DT := DT (To_Tag_Ptr (This).all); + Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table; + + -- 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 backward abstract interface type conversions. + + -- Register the offset in the table of interfaces + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then + if Is_Static or else Offset_Value = 0 then + Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True; + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value := + Offset_Value; + else + Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False; + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func := + Offset_Func; + end if; + + return; + end if; + end loop; + end if; + + -- If we arrive here there is some error in the run-time data structure + + raise Program_Error; + end Register_Interface_Offset; + ------------------ -- Register_Tag -- ------------------ @@ -892,68 +917,26 @@ package body Ada.Tags is -- Set_Offset_To_Top -- ----------------------- - procedure Set_Offset_To_Top + procedure Set_Dynamic_Offset_To_Top (This : System.Address; Interface_T : Tag; - Is_Static : Boolean; Offset_Value : SSE.Storage_Offset; Offset_Func : Offset_To_Top_Function_Ptr) is - Prim_DT : Dispatch_Table_Ptr; - Sec_Base : System.Address; - Sec_DT : Dispatch_Table_Ptr; - Iface_Table : Interface_Data_Ptr; - + Sec_Base : System.Address; + Sec_DT : Dispatch_Table_Ptr; begin -- Save the offset to top field in the secondary dispatch table if Offset_Value /= 0 then Sec_Base := This + Offset_Value; - Sec_DT := DT (To_Tag_Ptr (Sec_Base).all); - - if Is_Static then - Sec_DT.Offset_To_Top := Offset_Value; - else - Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last; - end if; + Sec_DT := DT (To_Tag_Ptr (Sec_Base).all); + Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last; end if; - -- "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 := DT (To_Tag_Ptr (This).all); - Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table; - - -- 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 backward abstract interface type conversions. - - -- Register the offset in the table of interfaces - - if Iface_Table /= null then - for Id in 1 .. Iface_Table.Nb_Ifaces loop - if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then - Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := - Is_Static; - - if Is_Static then - Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value - := Offset_Value; - else - Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func - := Offset_Func; - end if; - - return; - end if; - end loop; - end if; - - -- If we arrive here there is some error in the run-time data structure - - raise Program_Error; - end Set_Offset_To_Top; + Register_Interface_Offset + (This, Interface_T, False, Offset_Value, Offset_Func); + end Set_Dynamic_Offset_To_Top; ---------------------- -- Set_Prim_Op_Kind -- diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 1fc31e8a233..5117eea9ad7 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -222,7 +222,8 @@ private -- type. This construct is used in the handling of dispatching triggers -- in select statements. - type Address_Array is array (Positive range <>) of System.Address; + type Prim_Ptr is access procedure; + type Address_Array is array (Positive range <>) of Prim_Ptr; subtype Dispatch_Table is Address_Array (1 .. 1); -- Used by GDB to identify the _tags and traverse the run-time structure @@ -242,8 +243,14 @@ private type Tag_Ptr is access all Tag; pragma No_Strict_Aliasing (Tag_Ptr); + type Offset_To_Top_Ptr is access all SSE.Storage_Offset; + pragma No_Strict_Aliasing (Offset_To_Top_Ptr); + type Tag_Table is array (Natural range <>) of Tag; + type Size_Ptr is + access function (A : System.Address) return Long_Long_Integer; + type Type_Specific_Data (Idepth : Natural) is record -- The discriminant Idepth is the Inheritance Depth Level: Used to -- implement the membership test associated with single inheritance of @@ -279,6 +286,12 @@ private -- Controller Offset: Used to give support to tagged controlled objects -- (see Get_Deep_Controller at s-finimp) + Size_Func : Size_Ptr; + -- Pointer to the subprogram computing the _size of the object. Used by + -- the run-time whenever a call to the 'size primitive is required. We + -- cannot assume that the contents of dispatch tables are addresses + -- because in some architectures the ABI allows descriptors. + Interfaces_Table : Interface_Data_Ptr; -- Pointer to the table of interface tags. It is used to implement the -- membership test associated with interfaces and also for backward @@ -370,6 +383,10 @@ private use type System.Storage_Elements.Storage_Offset; + DT_Offset_To_Top_Offset : constant SSE.Storage_Count := + DT_Typeinfo_Ptr_Size + + DT_Offset_To_Top_Size; + DT_Predef_Prims_Offset : constant SSE.Storage_Count := DT_Typeinfo_Ptr_Size + DT_Offset_To_Top_Size @@ -474,28 +491,44 @@ private pragma Export (Ada, Parent_Size, "ada__tags__parent_size"); -- This procedure is used in s-finimp and is thus exported manually + procedure Register_Interface_Offset + (This : System.Address; + Interface_T : Tag; + Is_Static : Boolean; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr); + -- Register in the table of interfaces of the tagged type associated with + -- "This" object the offset of the record component associated with the + -- progenitor Interface_T (that is, the distance from "This" to the object + -- component containing the tag of the secondary dispatch table). In case + -- of constant offset, Is_Static is true and Offset_Value has such value. + -- In case of variable offset, Is_Static is false and Offset_Func is an + -- access to function that must be called to evaluate the offset. + procedure Register_Tag (T : Tag); -- Insert the Tag and its associated external_tag in a table for the -- sake of Internal_Tag - procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive); - -- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's - -- TSD table indexed by Position. - - procedure Set_Offset_To_Top + procedure Set_Dynamic_Offset_To_Top (This : System.Address; Interface_T : Tag; - Is_Static : Boolean; Offset_Value : SSE.Storage_Offset; Offset_Func : Offset_To_Top_Function_Ptr); - -- 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 - -- the Offset_Value is always cero; in secondary dispatch tables "This" - -- points to the object, Interface_T is the interface for which the - -- secondary dispatch table is being initialized, and Offset_Value is the - -- distance from "This" to the object component containing the tag of the - -- secondary dispatch table. + -- Ada 2005 (AI-251): The compiler generates calls to this routine only + -- when initializing the Offset_To_Top field of dispatch tables associated + -- with tagged type whose parent has variable size components. "This" is + -- the object whose dispatch table is being initialized. Interface_T is the + -- interface for which the secondary dispatch table is being initialized, + -- and Offset_Value is the distance from "This" to the object component + -- containing the tag of the secondary dispatch table (a zero value means + -- that this interface shares the primary dispatch table). Offset_Func + -- references a function that must be called to evaluate the offset at + -- runtime. This routine also takes care of registering these values in + -- the table of interfaces of the type. + + procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive); + -- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's + -- TSD table indexed by Position. procedure Set_Prim_Op_Kind (T : Tag; @@ -532,5 +565,7 @@ private type Addr_Ptr is access System.Address; pragma No_Strict_Aliasing (Addr_Ptr); - -- Why is this needed ??? + -- This type is used by the frontend to generate the code that handles + -- dispatch table slots of types declared at the local level. + end Ada.Tags; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index d815a534a21..1dfd0de9914 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -450,6 +450,17 @@ package body Checks is return; end if; + -- No check if accessing the Offset_To_Top component of a dispatch + -- table. They are safe by construction. + + if Present (Etype (P)) + and then RTU_Loaded (Ada_Tags) + and then RTE_Available (RE_Offset_To_Top_Ptr) + and then Etype (P) = RTE (RE_Offset_To_Top_Ptr) + then + return; + end if; + -- Otherwise go ahead and install the check Install_Null_Excluding_Check (P); @@ -1239,12 +1250,23 @@ package body Checks is return; end if; - exit when - not Is_OK_Static_Expression (ItemS) - or else - not Is_OK_Static_Expression (ItemT); + -- If the expressions for the discriminants are identical + -- and it is side-effect free (for now just an entity), + -- this may be a shared constraint, e.g. from a subtype + -- without a constraint introduced as a generic actual. + -- Examine other discriminants if any. + + if ItemS = ItemT + and then Is_Entity_Name (ItemS) + then + null; + + elsif not Is_OK_Static_Expression (ItemS) + or else not Is_OK_Static_Expression (ItemT) + then + exit; - if Expr_Value (ItemS) /= Expr_Value (ItemT) then + elsif Expr_Value (ItemS) /= Expr_Value (ItemT) then if Do_Access then -- needs run-time check. exit; else @@ -2723,10 +2745,13 @@ package body Checks is end if; end if; - -- Check that null-excluding objects are always initialized + -- Check that null-excluding objects are always initialized, except for + -- deferred constants, for which the expression will appear in the full + -- declaration. if K = N_Object_Declaration and then No (Expression (N)) + and then not Constant_Present (N) and then not No_Initialization (N) then -- Add an expression that assigns null. This node is needed by @@ -2742,9 +2767,9 @@ package body Checks is Reason => CE_Null_Not_Allowed); end if; - -- Check that a null-excluding component, formal or object is not - -- being assigned a null value. Otherwise generate a warning message - -- and replace Expression (N) by a N_Constraint_Error node. + -- Check that a null-excluding component, formal or object is not being + -- assigned a null value. Otherwise generate a warning message and + -- replace Expression (N) by an N_Contraint_Error node. if K /= N_Function_Specification then Expr := Expression (N); @@ -3368,14 +3393,14 @@ package body Checks is -- Nothing to do if the range of the result is known OK. We skip this -- for conversions, since the caller already did the check, and in any -- case the condition for deleting the check for a type conversion is - -- different in any case. + -- different. if Nkind (N) /= N_Type_Conversion then Determine_Range (N, OK, Lo, Hi); - -- Note in the test below that we assume that if a bound of the - -- range is equal to that of the type. That's not quite accurate - -- but we do this for the following reasons: + -- Note in the test below that we assume that the range is not OK + -- if a bound of the range is equal to that of the type. That's not + -- quite accurate but we do this for the following reasons: -- a) The way that Determine_Range works, it will typically report -- the bounds of the value as being equal to the bounds of the @@ -3385,7 +3410,7 @@ package body Checks is -- b) It is very unusual to have a situation in which this would -- generate an unnecessary overflow check (an example would be -- a subtype with a range 0 .. Integer'Last - 1 to which the - -- literal value one is added. + -- literal value one is added). -- c) The alternative is a lot of special casing in this routine -- which would partially duplicate Determine_Range processing. @@ -4121,12 +4146,7 @@ package body Checks is -- appropriate one for our purposes. if (Ekind (Ent) = E_Variable - or else - Ekind (Ent) = E_Constant - or else - Ekind (Ent) = E_Loop_Parameter - or else - Ekind (Ent) = E_In_Parameter) + or else Is_Constant_Object (Ent)) and then not Is_Library_Level_Entity (Ent) then Entry_OK := True; @@ -4371,7 +4391,8 @@ package body Checks is Duplicate_Subexpr_Move_Checks (Sub)), Right_Opnd => Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr_Move_Checks (A), + Prefix => + Duplicate_Subexpr_Move_Checks (A, Name_Req => True), Attribute_Name => Name_Range, Expressions => Num)), Reason => CE_Index_Check_Failed)); diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index c92e9cb12c2..0c9049471b4 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -211,7 +211,7 @@ package Checks is -- by the back end, but many are done by the front end. -- Overflow checks are similarly controlled by the Do_Overflow_Check flag. - -- The difference here is that if Backend_Overflow_Checks is is + -- The difference here is that if back end overflow checks are inactive -- (Backend_Overflow_Checks_On_Target set False), then the actual overflow -- checks are generated by the front end, but if back end overflow checks -- are active (Backend_Overflow_Checks_On_Target set True), then the back diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb index c2c37a7eb30..318614e598f 100644 --- a/gcc/ada/exp_atag.adb +++ b/gcc/ada/exp_atag.adb @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2008, 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- -- @@ -26,9 +26,11 @@ with Einfo; use Einfo; with Elists; use Elists; with Exp_Util; use Exp_Util; +with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Rtsfind; use Rtsfind; +with Sinfo; use Sinfo; with Sem_Util; use Sem_Util; with Stand; use Stand; with Snames; use Snames; @@ -57,15 +59,6 @@ package body Exp_Atag is -- Generate: To_Type_Specific_Data_Ptr -- (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all); - function Build_Predef_Prims - (Loc : Source_Ptr; - Tag_Node : Node_Id) return Node_Id; - -- Build code that retrieves the address of the dispatch table containing - -- the predefined Ada primitives: - -- - -- Generate: To_Predef_Prims_Table_Ptr - -- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all); - ------------------------------------------------ -- Build_Common_Dispatching_Select_Statements -- ------------------------------------------------ @@ -239,10 +232,33 @@ package body Exp_Atag is Position : Uint) return Node_Id is begin + -- Build code that retrieves the address of the dispatch table + -- containing the predefined Ada primitives: + -- + -- Generate: + -- To_Predef_Prims_Table_Ptr + -- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all); + return Make_Indexed_Component (Loc, Prefix => - Build_Predef_Prims (Loc, Tag_Node), + Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Addr_Ptr), + Make_Function_Call (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Name_Op_Subtract, + Prefix => + New_Reference_To + (RTU_Entity (System_Storage_Elements), Loc), + Selector_Name => + Make_Identifier (Loc, + Chars => Name_Op_Subtract)), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), Tag_Node), + New_Reference_To (RTE (RE_DT_Predef_Prims_Offset), + Loc)))))), Expressions => New_List (Make_Integer_Literal (Loc, Position))); end Build_Get_Predefined_Prim_Op_Address; @@ -397,35 +413,37 @@ package body Exp_Atag is New_Reference_To (RTE (RE_Max_Predef_Prims), Loc)))); end Build_Inherit_Predefined_Prims; - ------------------------ - -- Build_Predef_Prims -- - ------------------------ + ------------------------- + -- Build_Offset_To_Top -- + ------------------------- - function Build_Predef_Prims - (Loc : Source_Ptr; - Tag_Node : Node_Id) return Node_Id + function Build_Offset_To_Top + (Loc : Source_Ptr; + This_Node : Node_Id) return Node_Id is + Tag_Node : Node_Id; + begin - return - Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RTE (RE_Addr_Ptr), - Make_Function_Call (Loc, - Name => - Make_Expanded_Name (Loc, - Chars => Name_Op_Subtract, - Prefix => - New_Reference_To - (RTU_Entity (System_Storage_Elements), Loc), - Selector_Name => - Make_Identifier (Loc, - Chars => Name_Op_Subtract)), + Tag_Node := + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node)); - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Address), Tag_Node), - New_Reference_To (RTE (RE_DT_Predef_Prims_Offset), - Loc)))))); - end Build_Predef_Prims; + return + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr), + Make_Function_Call (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Name_Op_Subtract, + Prefix => New_Reference_To + (RTU_Entity (System_Storage_Elements), Loc), + Selector_Name => Make_Identifier (Loc, + Chars => Name_Op_Subtract)), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), Tag_Node), + New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset), + Loc))))); + end Build_Offset_To_Top; ------------------------------------------ -- Build_Set_Predefined_Prim_Op_Address -- @@ -471,6 +489,60 @@ package body Exp_Atag is Expression => Address_Node); end Build_Set_Prim_Op_Address; + ----------------------------- + -- Build_Set_Size_Function -- + ----------------------------- + + function Build_Set_Size_Function + (Loc : Source_Ptr; + Tag_Node : Node_Id; + Size_Func : Entity_Id) return Node_Id is + begin + pragma Assert (Chars (Size_Func) = Name_uSize + and then RTE_Record_Component_Available (RE_Size_Func)); + return + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Build_TSD (Loc, Tag_Node), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Size_Func), Loc)), + Expression => + Unchecked_Convert_To (RTE (RE_Size_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Size_Func, Loc), + Attribute_Name => Name_Unrestricted_Access))); + end Build_Set_Size_Function; + + ------------------------------------ + -- Build_Set_Static_Offset_To_Top -- + ------------------------------------ + + function Build_Set_Static_Offset_To_Top + (Loc : Source_Ptr; + Iface_Tag : Node_Id; + Offset_Value : Node_Id) return Node_Id is + begin + return + Make_Assignment_Statement (Loc, + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr), + Make_Function_Call (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Name_Op_Subtract, + Prefix => New_Reference_To + (RTU_Entity (System_Storage_Elements), Loc), + Selector_Name => Make_Identifier (Loc, + Chars => Name_Op_Subtract)), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), Iface_Tag), + New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset), + Loc))))), + Offset_Value); + end Build_Set_Static_Offset_To_Top; + --------------- -- Build_TSD -- --------------- diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads index 9d724f29140..2ac42a9d254 100644 --- a/gcc/ada/exp_atag.ads +++ b/gcc/ada/exp_atag.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2008, 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- -- @@ -117,6 +117,19 @@ package Exp_Atag is -- New_Tag.Prims_Ptr (1 .. Num_Prims) := -- Old_Tag.Prims_Ptr (1 .. Num_Prims); + function Build_Offset_To_Top + (Loc : Source_Ptr; + This_Node : Node_Id) return Node_Id; + -- Build code that references the Offset_To_Top component of the primary + -- or secondary dispatch table associated with This_Node. This subprogram + -- provides a subset of the functionality provided by the function + -- Offset_To_Top of package Ada.Tags, and is only called by the frontend + -- when such routine is not available in a configurable runtime. + -- + -- Generates: + -- Offset_To_Top_Ptr + -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset) + function Build_Set_Predefined_Prim_Op_Address (Loc : Source_Ptr; Tag_Node : Node_Id; @@ -145,4 +158,23 @@ package Exp_Atag is -- -- Generates: Tag.D (Position) := Value + function Build_Set_Size_Function + (Loc : Source_Ptr; + Tag_Node : Node_Id; + Size_Func : Entity_Id) return Node_Id; + -- Build code that saves in the TSD the address of the function + -- calculating _size of the object. + + function Build_Set_Static_Offset_To_Top + (Loc : Source_Ptr; + Iface_Tag : Node_Id; + Offset_Value : Node_Id) return Node_Id; + -- Build code that initialize the Offset_To_Top component of the + -- secondary dispatch table referenced by Iface_Tag. + -- + -- Generates: + -- Offset_To_Top_Ptr + -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset).all + -- := Offset_Value + end Exp_Atag; diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 11b3fef8861..3ba47ec4446 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -145,21 +145,29 @@ package body Exp_Ch13 is -- For Storage_Size for an access type, create a variable to hold -- the value of the specified size with name typeV and expand an - -- assignment statement to initialze this value. + -- assignment statement to initialize this value. elsif Is_Access_Type (Ent) then - V := Make_Defining_Identifier (Loc, - New_External_Name (Chars (Ent), 'V')); - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => V, - Object_Definition => - New_Reference_To (RTE (RE_Storage_Offset), Loc), - Expression => - Convert_To (RTE (RE_Storage_Offset), Expression (N)))); + -- We don't need the variable for a storage size of zero + + if not No_Pool_Assigned (Ent) then + V := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Ent), 'V')); - Set_Storage_Size_Variable (Ent, Entity_Id (V)); + -- Insert the declaration of the object + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => V, + Object_Definition => + New_Reference_To (RTE (RE_Storage_Offset), Loc), + Expression => + Convert_To (RTE (RE_Storage_Offset), Expression (N)))); + + Set_Storage_Size_Variable (Ent, Entity_Id (V)); + end if; end if; -- Other attributes require no expansion @@ -207,6 +215,15 @@ package body Exp_Ch13 is return; end if; + -- Remember that we are processing a freezing entity and its freezing + -- nodes. This flag (non-zero = set) is used to avoid the need of + -- climbing through the tree while processing the freezing actions (ie. + -- to avoid generating spurious warnings or to avoid killing constant + -- indications while processing the code associated with freezing + -- actions). We use a counter to deal with nesting. + + Inside_Freezing_Actions := Inside_Freezing_Actions + 1; + -- If we are freezing entities defined in protected types, they belong -- in the enclosing scope, given that the original type has been -- expanded away. The same is true for entities in task types, in @@ -224,7 +241,6 @@ package body Exp_Ch13 is elsif Ekind (E_Scope) = E_Subprogram_Body then E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope)); - end if; S := Current_Scope; @@ -339,6 +355,11 @@ package body Exp_Ch13 is elsif In_Outer_Scope then Pop_Scope; end if; + + -- Restore previous value of the nesting-level counter that records + -- whether we are inside a (possibly nested) call to this procedure. + + Inside_Freezing_Actions := Inside_Freezing_Actions - 1; end Expand_N_Freeze_Entity; ------------------------------------------- diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 046a98556aa..3ec27893af0 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -570,7 +570,7 @@ package body Exp_Ch3 is Name => Comp, Expression => Get_Simple_Init_Val - (Comp_Type, Loc, Component_Size (A_Type)))); + (Comp_Type, Nod, Component_Size (A_Type)))); else Clean_Task_Names (Comp_Type, Proc_Id); @@ -680,7 +680,18 @@ package body Exp_Ch3 is and then Root_Type (A_Type) /= Standard_Wide_Wide_String) then Proc_Id := - Make_Defining_Identifier (Loc, Make_Init_Proc_Name (A_Type)); + Make_Defining_Identifier (Loc, + Chars => Make_Init_Proc_Name (A_Type)); + + -- If No_Default_Initialization restriction is active, then we don't + -- want to build an init_proc, but we need to mark that an init_proc + -- would be needed if this restriction was not active (so that we can + -- detect attempts to call it), so set a dummy init_proc in place. + + if Restriction_Active (No_Default_Initialization) then + Set_Init_Proc (A_Type, Proc_Id); + return; + end if; Body_Stmts := Init_One_Dimension (1); @@ -1018,15 +1029,17 @@ package body Exp_Ch3 is begin -- Build the discriminant checking function for each variant, label -- all components of that variant with the function's name. + -- We only Generate a discriminant-checking function only if the + -- variant is not empty, to prevent the creation of dead code. Discr_Name := Entity (Name (Variant_Part_Node)); Variant := First_Non_Pragma (Variants (Variant_Part_Node)); while Present (Variant) loop - Func_Id := Build_Dcheck_Function (Discr_Name, Variant); Component_List_Node := Component_List (Variant); if not Null_Present (Component_List_Node) then + Func_Id := Build_Dcheck_Function (Discr_Name, Variant); Decl := First_Non_Pragma (Component_Items (Component_List_Node)); @@ -2172,10 +2185,6 @@ package body Exp_Ch3 is begin Body_Stmts := New_List; Body_Node := New_Node (N_Subprogram_Body, Loc); - - Proc_Id := - Make_Defining_Identifier (Loc, - Chars => Make_Init_Proc_Name (Rec_Type)); Set_Ekind (Proc_Id, E_Procedure); Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); @@ -2567,7 +2576,7 @@ package body Exp_Ch3 is elsif Component_Needs_Simple_Initialization (Typ) then Stmts := Build_Assignment - (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id))); + (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))); -- Nothing needed for this case @@ -2635,7 +2644,7 @@ package body Exp_Ch3 is elsif Component_Needs_Simple_Initialization (Typ) then Append_List_To (Statement_List, Build_Assignment - (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id)))); + (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)))); end if; end if; @@ -3003,7 +3012,6 @@ package body Exp_Ch3 is end if; Id := First_Component (Rec_Id); - while Present (Id) loop Comp_Decl := Parent (Id); Typ := Etype (Id); @@ -3024,6 +3032,8 @@ package body Exp_Ch3 is -- Start of processing for Build_Record_Init_Proc begin + -- Check for value type, which means no initialization required + Rec_Type := Defining_Identifier (N); if Is_Value_Type (Rec_Type) then @@ -3080,6 +3090,20 @@ package body Exp_Ch3 is elsif Requires_Init_Proc (Rec_Type) or else Is_Unchecked_Union (Rec_Type) then + Proc_Id := + Make_Defining_Identifier (Loc, + Chars => Make_Init_Proc_Name (Rec_Type)); + + -- If No_Default_Initialization restriction is active, then we don't + -- want to build an init_proc, but we need to mark that an init_proc + -- would be needed if this restriction was not active (so that we can + -- detect attempts to call it), so set a dummy init_proc in place. + + if Restriction_Active (No_Default_Initialization) then + Set_Init_Proc (Rec_Type, Proc_Id); + return; + end if; + Build_Offset_To_Top_Functions; Build_Init_Procedure; Set_Is_Public (Proc_Id, Is_Public (Pe)); @@ -3121,13 +3145,12 @@ package body Exp_Ch3 is procedure Collect_Itypes (Comp : Node_Id) is Ref : Node_Id; Sub_Aggr : Node_Id; - Typ : Entity_Id; + Typ : constant Entity_Id := Etype (Comp); begin - if Is_Array_Type (Etype (Comp)) - and then Is_Itype (Etype (Comp)) + if Is_Array_Type (Typ) + and then Is_Itype (Typ) then - Typ := Etype (Comp); Ref := Make_Itype_Reference (Loc); Set_Itype (Ref, Typ); Append_Freeze_Action (Rec_Type, Ref); @@ -3189,6 +3212,11 @@ package body Exp_Ch3 is -- Ri1 : Index; -- begin + + -- if Left_Hi < Left_Lo then + -- return; + -- end if; + -- if Rev then -- Li1 := Left_Hi; -- Ri1 := Right_Hi; @@ -3198,18 +3226,14 @@ package body Exp_Ch3 is -- end if; -- loop - -- if Rev then - -- exit when Li1 < Left_Lo; - -- else - -- exit when Li1 > Left_Hi; - -- end if; - -- Target (Li1) := Source (Ri1); -- if Rev then + -- exit when Li1 = Left_Lo; -- Li1 := Index'pred (Li1); -- Ri1 := Index'pred (Ri1); -- else + -- exit when Li1 = Left_Hi; -- Li1 := Index'succ (Li1); -- Ri1 := Index'succ (Ri1); -- end if; @@ -3276,6 +3300,16 @@ package body Exp_Ch3 is Stats := New_List; + -- Build test for empty slice case + + Append_To (Stats, + Make_If_Statement (Loc, + Condition => + Make_Op_Lt (Loc, + Left_Opnd => New_Occurrence_Of (Left_Hi, Loc), + Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)), + Then_Statements => New_List (Make_Simple_Return_Statement (Loc)))); + -- Build initializations for indices declare @@ -3326,7 +3360,7 @@ package body Exp_Ch3 is Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))), End_Label => Empty); - -- Build exit condition + -- Build the exit condition and increment/decrement statements declare F_Ass : constant List_Id := New_List; @@ -3336,31 +3370,10 @@ package body Exp_Ch3 is Append_To (F_Ass, Make_Exit_Statement (Loc, Condition => - Make_Op_Gt (Loc, + Make_Op_Eq (Loc, Left_Opnd => New_Occurrence_Of (Lnn, Loc), Right_Opnd => New_Occurrence_Of (Left_Hi, Loc)))); - Append_To (B_Ass, - Make_Exit_Statement (Loc, - Condition => - Make_Op_Lt (Loc, - Left_Opnd => New_Occurrence_Of (Lnn, Loc), - Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)))); - - Prepend_To (Statements (Loops), - Make_If_Statement (Loc, - Condition => New_Occurrence_Of (Rev, Loc), - Then_Statements => B_Ass, - Else_Statements => F_Ass)); - end; - - -- Build the increment/decrement statements - - declare - F_Ass : constant List_Id := New_List; - B_Ass : constant List_Id := New_List; - - begin Append_To (F_Ass, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Lnn, Loc), @@ -3383,6 +3396,13 @@ package body Exp_Ch3 is Expressions => New_List ( New_Occurrence_Of (Rnn, Loc))))); + Append_To (B_Ass, + Make_Exit_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Lnn, Loc), + Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)))); + Append_To (B_Ass, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Lnn, Loc), @@ -4220,6 +4240,12 @@ package body Exp_Ch3 is and then not Suppress_Init_Proc (Typ) then + Check_Restriction (No_Default_Initialization, N); + + if Restriction_Active (No_Default_Initialization) then + return; + end if; + -- The call to the initialization procedure does NOT freeze the -- object being initialized. This is because the call is not a -- source level call. This works fine, because the only possible @@ -4260,8 +4286,9 @@ package body Exp_Ch3 is and then not Is_Internal (Def_Id) and then not Has_Init_Expression (N) then + Check_Restriction (No_Default_Initialization, N); Set_No_Initialization (N, False); - Set_Expression (N, Get_Simple_Init_Val (Typ, Loc, Esize (Def_Id))); + Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id))); Analyze_And_Resolve (Expression (N), Typ); end if; @@ -5437,10 +5464,18 @@ package body Exp_Ch3 is Set_Is_Frozen (Def_Id, False); + -- Do not add the spec of predefined primitives in case of + -- CPP tagged type derivations that have convention CPP. + + if Is_CPP_Class (Root_Type (Def_Id)) + and then Convention (Def_Id) = Convention_CPP + then + null; + -- Do not add the spec of the predefined primitives if we are -- compiling under restriction No_Dispatching_Calls - if not Restriction_Active (No_Dispatching_Calls) then + elsif not Restriction_Active (No_Dispatching_Calls) then Make_Predefined_Primitive_Specs (Def_Id, Predef_List, Renamed_Eq); Insert_List_Before_And_Analyze (N, Predef_List); @@ -5614,11 +5649,19 @@ package body Exp_Ch3 is if Is_Tagged_Type (Def_Id) and then not Is_Interface (Def_Id) then + -- Do not add the body of predefined primitives in case of + -- CPP tagged type derivations that have convention CPP. + + if Is_CPP_Class (Root_Type (Def_Id)) + and then Convention (Def_Id) = Convention_CPP + then + null; -- Do not add the body of the predefined primitives if we are - -- compiling under restriction No_Dispatching_Calls + -- compiling under restriction No_Dispatching_Calls of if we + -- are compiling a CPP tagged type. - if not Restriction_Active (No_Dispatching_Calls) then + elsif not Restriction_Active (No_Dispatching_Calls) then Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); Append_Freeze_Actions (Def_Id, Predef_List); end if; @@ -5814,28 +5857,18 @@ package body Exp_Ch3 is then declare Loc : constant Source_Ptr := Sloc (N); - Desig_Type : constant Entity_Id := Designated_Type (Def_Id); + Desig_Type : constant Entity_Id := Designated_Type (Def_Id); Pool_Object : Entity_Id; - Siz_Exp : Node_Id; Freeze_Action_Typ : Entity_Id; begin - if Has_Storage_Size_Clause (Def_Id) then - Siz_Exp := Expression (Parent (Storage_Size_Variable (Def_Id))); - else - Siz_Exp := Empty; - end if; - -- Case 1 -- Rep Clause "for Def_Id'Storage_Size use 0;" -- ---> don't use any storage pool - if Has_Storage_Size_Clause (Def_Id) - and then Compile_Time_Known_Value (Siz_Exp) - and then Expr_Value (Siz_Exp) = 0 - then + if No_Pool_Assigned (Def_Id) then null; -- Case 2 @@ -6046,9 +6079,10 @@ package body Exp_Ch3 is function Get_Simple_Init_Val (T : Entity_Id; - Loc : Source_Ptr; + N : Node_Id; Size : Uint := No_Uint) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); Val : Node_Id; Result : Node_Id; Val_RE : RE_Id; @@ -6057,6 +6091,10 @@ package body Exp_Ch3 is -- This is the size to be used for computation of the appropriate -- initial value for the Normalize_Scalars and Initialize_Scalars case. + IV_Attribute : constant Boolean := + Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Invalid_Value; + Lo_Bound : Uint; Hi_Bound : Uint; -- These are the values computed by the procedure Check_Subtype_Bounds @@ -6133,7 +6171,7 @@ package body Exp_Ch3 is -- an Unchecked_Convert to the private type. if Is_Private_Type (T) then - Val := Get_Simple_Init_Val (Underlying_Type (T), Loc, Size); + Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size); -- A special case, if the underlying value is null, then qualify it -- with the underlying type, so that the null is properly typed @@ -6160,10 +6198,11 @@ package body Exp_Ch3 is return Result; - -- For scalars, we must have normalize/initialize scalars case + -- For scalars, we must have normalize/initialize scalars case, or + -- if the node N is an 'Invalid_Value attribute node. elsif Is_Scalar_Type (T) then - pragma Assert (Init_Or_Norm_Scalars); + pragma Assert (Init_Or_Norm_Scalars or IV_Attribute); -- Compute size of object. If it is given by the caller, we can use -- it directly, otherwise we use Esize (T) as an estimate. As far as @@ -6188,7 +6227,7 @@ package body Exp_Ch3 is -- Processing for Normalize_Scalars case - if Normalize_Scalars then + if Normalize_Scalars and then not IV_Attribute then -- If zero is invalid, it is a convenient value to use that is -- for sure an appropriate invalid value in all situations. @@ -6252,7 +6291,7 @@ package body Exp_Ch3 is end; end if; - -- Here for Initialize_Scalars case + -- Here for Initialize_Scalars case (or Invalid_Value attribute used) else -- For float types, use float values from System.Scalar_Values @@ -6347,7 +6386,7 @@ package body Exp_Ch3 is Make_Others_Choice (Loc)), Expression => Get_Simple_Init_Val - (Component_Type (T), Loc, Esize (Root_Type (T)))))); + (Component_Type (T), N, Esize (Root_Type (T)))))); -- Access type is initialized to null @@ -6615,14 +6654,6 @@ package body Exp_Ch3 is New_Reference_To (Iface_Tag, Loc))); end if; - -- Issue error if Set_Offset_To_Top is not available in a - -- configurable run-time environment. - - if not RTE_Available (RE_Set_Offset_To_Top) then - Error_Msg_CRT ("abstract interface types", Typ); - return; - end if; - Comp_Typ := Scope (Tag_Comp); -- Initialize the entries of the table of interfaces. We generate a @@ -6636,17 +6667,26 @@ package body Exp_Ch3 is pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp))); + -- Issue error if Set_Dynamic_Offset_To_Top is not available in a + -- configurable run-time environment. + + if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then + Error_Msg_CRT + ("variable size record with interface types", Typ); + return; + end if; + -- Generate: - -- Set_Offset_To_Top + -- Set_Dynamic_Offset_To_Top -- (This => Init, -- Interface_T => Iface'Tag, - -- Is_Constant => False, -- Offset_Value => n, -- Offset_Func => Fn'Address) Append_To (Stmts_List, Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), + Name => New_Reference_To + (RTE (RE_Set_Dynamic_Offset_To_Top), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Copy_Tree (Target), @@ -6657,8 +6697,6 @@ package body Exp_Ch3 is (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, @@ -6700,42 +6738,63 @@ package body Exp_Ch3 is -- Normal case: No discriminants in the parent type else + -- Don't need to set any value if this interface shares + -- the primary dispatch table + + if not Is_Parent (Iface, Typ) then + Append_To (Stmts_List, + Build_Set_Static_Offset_To_Top (Loc, + Iface_Tag => + New_Reference_To (Iface_Tag, Loc), + Offset_Value => + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)), + Attribute_Name => Name_Position)))); + end if; + -- Generate: - -- Set_Offset_To_Top + -- Register_Interface_Offset -- (This => Init, -- Interface_T => Iface'Tag, -- Is_Constant => True, -- Offset_Value => n, -- Offset_Func => null); - Append_To (Stmts_List, - 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 => New_Copy_Tree (Target), - Attribute_Name => Name_Address), + if RTE_Available (RE_Register_Interface_Offset) then + Append_To (Stmts_List, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To + (RTE (RE_Register_Interface_Offset), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Target), + 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_Tag), + New_Reference_To + (Node (First_Elmt + (Access_Disp_Table (Iface))), + Loc)), - New_Occurrence_Of (Standard_True, Loc), + New_Occurrence_Of (Standard_True, Loc), - Unchecked_Convert_To - (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => - New_Reference_To (Tag_Comp, Loc)), - Attribute_Name => Name_Position)), + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)), + Attribute_Name => Name_Position)), - Make_Null (Loc)))); + Make_Null (Loc)))); + end if; end if; end Initialize_Tag; @@ -6816,6 +6875,32 @@ package body Exp_Ch3 is Comp_Typ : Entity_Id; Idx : Node_Id; + function Is_Constant_Bound (Exp : Node_Id) return Boolean; + -- To simplify handling of array components. Determines whether the + -- given bound is constant (a constant or enumeration literal, or an + -- integer literal) as opposed to per-object, through an expression + -- or a discriminant. + + ----------------------- + -- Is_Constant_Bound -- + ----------------------- + + function Is_Constant_Bound (Exp : Node_Id) return Boolean is + begin + if Nkind (Exp) = N_Integer_Literal then + return True; + else + return + Is_Entity_Name (Exp) + and then Present (Entity (Exp)) + and then + (Ekind (Entity (Exp)) = E_Constant + or else Ekind (Entity (Exp)) = E_Enumeration_Literal); + end if; + end Is_Constant_Bound; + + -- Start of processing for Is_Variable_Sized_Record + begin pragma Assert (Is_Record_Type (E)); @@ -6840,15 +6925,9 @@ package body Exp_Ch3 is Idx := First_Index (Comp_Typ); while Present (Idx) loop if Nkind (Idx) = N_Range then - if (Nkind (Low_Bound (Idx)) = N_Identifier - and then Present (Entity (Low_Bound (Idx))) - and then - Ekind (Entity (Low_Bound (Idx))) /= E_Constant) - or else - (Nkind (High_Bound (Idx)) = N_Identifier - and then Present (Entity (High_Bound (Idx))) - and then - Ekind (Entity (High_Bound (Idx))) /= E_Constant) + if not Is_Constant_Bound (Low_Bound (Idx)) + or else + not Is_Constant_Bound (High_Bound (Idx)) then return True; end if; @@ -7506,6 +7585,7 @@ package body Exp_Ch3 is if Ada_Version >= Ada_05 and then VM_Target = No_VM + and then RTE_Available (RE_Select_Specific_Data) then -- These primitives are defined abstract in interface types @@ -7608,8 +7688,14 @@ package body Exp_Ch3 is -- initialization of its dispatch table. or else (not Is_Interface (Tag_Typ) - and then - Is_Interface (Etype (Tag_Typ))) + and then Is_Interface (Etype (Tag_Typ))) + + -- Ada 205 (AI-251): We must also generate these subprograms if + -- the parent of an nonlimited interface is a limited interface + + or else (Is_Interface (Tag_Typ) + and then not Is_Limited_Interface (Tag_Typ) + and then Is_Limited_Interface (Etype (Tag_Typ))) then if not Is_Limited_Type (Tag_Typ) then Append_To (Res, @@ -7999,6 +8085,7 @@ package body Exp_Ch3 is and then Is_Limited_Record (Etype (Tag_Typ))) or else (Is_Concurrent_Record_Type (Tag_Typ) and then Has_Abstract_Interfaces (Tag_Typ))) + and then RTE_Available (RE_Select_Specific_Data) then Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 04669679893..d51724af3cd 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -133,16 +133,18 @@ package Exp_Ch3 is function Get_Simple_Init_Val (T : Entity_Id; - Loc : Source_Ptr; + N : Node_Id; Size : Uint := No_Uint) return Node_Id; -- For a type which Needs_Simple_Initialization (see above), prepares the - -- tree for an expression representing the required initial value. Loc is - -- the source location used in constructing this tree which is returned as - -- the result of the call. The Size parameter indicates the target size of - -- the object if it is known (indicated by a value that is not No_Uint and - -- is greater than zero). If Size is not given (Size set to No_Uint, or - -- non-positive), then the Esize of T is used as an estimate of the Size. - -- The object size is needed to prepare a known invalid value for use by - -- Normalize_Scalars. + -- tree for an expression representing the required initial value. N is a + -- node whose source location used in constructing this tree which is + -- returned as the result of the call. The Size parameter indicates the + -- target size of the object if it is known (indicated by a value that is + -- not No_Uint and is greater than zero). If Size is not given (Size set to + -- No_Uint, or non-positive), then the Esize of T is used as an estimate of + -- the Size. The object size is needed to prepare a known invalid value for + -- use by Normalize_Scalars. A call to this routine where T is a scalar + -- type is only valid if we are in Normalize_Scalars or Initialize_Scalars + -- mode, or if N is the node for a 'Invalid_Value attribute node. end Exp_Ch3; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index c14c7348dea..b4efbf87cc7 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -99,7 +99,15 @@ package body Exp_Disp is ------------------------ function Building_Static_DT (Typ : Entity_Id) return Boolean is + Root_Typ : Entity_Id := Root_Type (Typ); + begin + -- Handle private types + + if Present (Full_View (Root_Typ)) then + Root_Typ := Full_View (Root_Typ); + end if; + return Static_Dispatch_Tables and then Is_Library_Level_Tagged_Type (Typ) @@ -107,7 +115,7 @@ package body Exp_Disp is -- build the dispatch tables because we must inherit primitives -- from the CPP side. - and then not Is_CPP_Class (Root_Type (Typ)); + and then not Is_CPP_Class (Root_Typ); end Building_Static_DT; ---------------------------------- @@ -548,7 +556,6 @@ package body Exp_Disp is Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node); Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node); Set_Etype (Subp_Typ, Res_Typ); - Init_Size_Align (Subp_Ptr_Typ); Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); -- Create a new list of parameters which is a copy of the old formal @@ -575,18 +582,11 @@ package body Exp_Disp is Set_Etype (New_Formal, Etype (Param)); end if; - if Is_Itype (Etype (New_Formal)) then - Extra := New_Copy (Etype (New_Formal)); - - if Ekind (Extra) = E_Record_Subtype - or else Ekind (Extra) = E_Class_Wide_Subtype - then - Set_Cloned_Subtype (Extra, Etype (New_Formal)); - end if; - - Set_Etype (New_Formal, Extra); - Set_Scope (Etype (New_Formal), Subp_Typ); - end if; + -- If the type of the formal is an itype, there was code here + -- introduced in 1998 in revision 1.46, to create a new itype + -- by copy. This seems useless, and in fact leads to semantic + -- errors when the itype is the completion of a type derived + -- from a private type. Extra := New_Formal; Next_Formal (Old_Formal); @@ -780,7 +780,7 @@ package body Exp_Disp is -- Give error if configurable run time and Displace not available if not RTE_Available (RE_Displace) then - Error_Msg_CRT ("abstract interface types", N); + Error_Msg_CRT ("dynamic interface conversion", N); return; end if; @@ -839,9 +839,7 @@ package body Exp_Disp is begin New_Itype := Create_Itype (E_Anonymous_Access_Type, N); - Set_Etype (New_Itype, New_Itype); - Init_Esize (New_Itype); - Init_Size_Align (New_Itype); + Set_Etype (New_Itype, New_Itype); Set_Directly_Designated_Type (New_Itype, Etyp); Rewrite (N, @@ -1205,6 +1203,8 @@ package body Exp_Disp is Decl_1 : Node_Id; Decl_2 : Node_Id; Formal : Node_Id; + New_Arg : Node_Id; + Offset_To_Top : Node_Id; Target : Entity_Id; Target_Formal : Entity_Id; @@ -1212,13 +1212,6 @@ package body Exp_Disp is Thunk_Id := Empty; Thunk_Code := Empty; - -- Give message if configurable run-time and Offset_To_Top unavailable - - if not RTE_Available (RE_Offset_To_Top) then - Error_Msg_CRT ("abstract interface types", Prim); - return; - end if; - -- Traverse the list of alias to find the final target Target := Prim; @@ -1284,6 +1277,20 @@ package body Exp_Disp is (Directly_Designated_Type (Etype (Target_Formal)), Loc))); + New_Arg := + Unchecked_Convert_To (RTE (RE_Address), + New_Reference_To (Defining_Identifier (Formal), Loc)); + + if not RTE_Available (RE_Offset_To_Top) then + Offset_To_Top := + Build_Offset_To_Top (Loc, New_Arg); + else + Offset_To_Top := + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), + Parameter_Associations => New_List (New_Arg)); + end if; + Decl_1 := Make_Object_Declaration (Loc, Defining_Identifier => @@ -1299,14 +1306,7 @@ package body Exp_Disp is (RTE (RE_Storage_Offset), New_Reference_To (Defining_Identifier (Formal), Loc)), Right_Opnd => - Make_Function_Call (Loc, - Name => - New_Reference_To (RTE (RE_Offset_To_Top), Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To - (RTE (RE_Address), - New_Reference_To - (Defining_Identifier (Formal), Loc)))))); + Offset_To_Top)); Append_To (Decl, Decl_2); Append_To (Decl, Decl_1); @@ -1326,6 +1326,23 @@ package body Exp_Disp is -- - Offset_To_Top (Formal'Address) -- S2 : Addr_Ptr := Addr_Ptr!(S1) + New_Arg := + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Defining_Identifier (Formal), Loc), + Attribute_Name => + Name_Address); + + if not RTE_Available (RE_Offset_To_Top) then + Offset_To_Top := + Build_Offset_To_Top (Loc, New_Arg); + else + Offset_To_Top := + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), + Parameter_Associations => New_List (New_Arg)); + end if; + Decl_1 := Make_Object_Declaration (Loc, Defining_Identifier => @@ -1344,15 +1361,7 @@ package body Exp_Disp is (Defining_Identifier (Formal), Loc), Attribute_Name => Name_Address)), Right_Opnd => - Make_Function_Call (Loc, - Name => - New_Reference_To (RTE (RE_Offset_To_Top), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To - (Defining_Identifier (Formal), Loc), - Attribute_Name => Name_Address))))); + Offset_To_Top)); Decl_2 := Make_Object_Declaration (Loc, @@ -3042,6 +3051,10 @@ package body Exp_Disp is (Expression (Parent (RTE (RE_Max_Predef_Prims))))); + DT_Decl : constant Elist_Id := New_Elmt_List; + DT_Aggr : constant Elist_Id := New_Elmt_List; + -- Entities marked with attribute Is_Dispatch_Table_Entity + procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id); -- Verify that all non-tagged types in the profile of a subprogram -- are frozen at the point the subprogram is frozen. This enforces @@ -3229,6 +3242,7 @@ package body Exp_Disp is declare Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; + Decl : Node_Id; Thunk_Id : Entity_Id; Thunk_Code : Node_Id; @@ -3272,27 +3286,43 @@ package body Exp_Disp is for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := - Unchecked_Convert_To (RTE (RE_Address), + Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim_Table (J), Loc), Attribute_Name => Name_Unrestricted_Access)); else - New_Node := - New_Reference_To (RTE (RE_Null_Address), Loc); + New_Node := Make_Null (Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); end loop; + New_Node := + Make_Aggregate (Loc, + Expressions => Prim_Ops_Aggr_List); + + -- Remember aggregates initializing dispatch tables + + Append_Elmt (New_Node, DT_Aggr); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('S')), + Subtype_Indication => + New_Reference_To (RTE (RE_Address_Array), Loc)); + + Append_To (Result, Decl); + Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims, Constant_Present => Building_Static_DT (Typ), Aliased_Present => True, - Object_Definition => - New_Reference_To (RTE (RE_Address_Array), Loc), - Expression => Make_Aggregate (Loc, - Expressions => Prim_Ops_Aggr_List))); + Object_Definition => New_Reference_To + (Defining_Identifier (Decl), Loc), + Expression => New_Node)); Append_To (Result, Make_Attribute_Definition_Clause (Loc, @@ -3492,15 +3522,13 @@ package body Exp_Disp is Prim_Ops_Aggr_List := New_List; if Empty_DT then - Append_To (Prim_Ops_Aggr_List, - New_Reference_To (RTE (RE_Null_Address), Loc)); + Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); elsif Is_Abstract_Type (Typ) or else not Building_Static_DT (Typ) then for J in 1 .. Nb_Prim loop - Append_To (Prim_Ops_Aggr_List, - New_Reference_To (RTE (RE_Null_Address), Loc)); + Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); end loop; else @@ -3556,13 +3584,12 @@ package body Exp_Disp is for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := - Unchecked_Convert_To (RTE (RE_Address), + Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim_Table (J), Loc), Attribute_Name => Name_Unrestricted_Access)); else - New_Node := - New_Reference_To (RTE (RE_Null_Address), Loc); + New_Node := Make_Null (Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); @@ -3570,9 +3597,15 @@ package body Exp_Disp is end; end if; - Append_To (DT_Aggr_List, + New_Node := Make_Aggregate (Loc, - Expressions => Prim_Ops_Aggr_List)); + Expressions => Prim_Ops_Aggr_List); + + Append_To (DT_Aggr_List, New_Node); + + -- Remember aggregates initializing dispatch tables + + Append_Elmt (New_Node, DT_Aggr); Append_To (Result, Make_Object_Declaration (Loc, @@ -3635,14 +3668,10 @@ package body Exp_Disp is (RTE_Record_Component (RE_Predef_Prims), Loc)), Attribute_Name => Name_Address))); - -- Mark entities containing library level static dispatch tables. - -- This attribute is later propagated to all the access-to-subprogram - -- itypes generated to fill the dispatch table slots (see exp_attr). + -- Remember entities containing dispatch tables - if Building_Static_DT (Typ) then - Set_Is_Static_Dispatch_Table_Entity (Predef_Prims); - Set_Is_Static_Dispatch_Table_Entity (Iface_DT); - end if; + Append_Elmt (Predef_Prims, DT_Decl); + Append_Elmt (Iface_DT, DT_Decl); end Make_Secondary_DT; -- Local variables @@ -3666,6 +3695,7 @@ package body Exp_Disp is New_Node : Node_Id; No_Reg : Node_Id; Num_Ifaces : Nat := 0; + Parent_Typ : Entity_Id; Prim : Entity_Id; Prim_Elmt : Elmt_Id; Prim_Ops_Aggr_List : List_Id; @@ -3761,6 +3791,14 @@ package body Exp_Disp is end if; end if; + -- Initialize Parent_Typ handling private types + + Parent_Typ := Etype (Typ); + + if Present (Full_View (Parent_Typ)) then + Parent_Typ := Full_View (Parent_Typ); + end if; + -- Ensure that all the primitives are frozen. This is only required when -- building static dispatch tables --- the primitives must be frozen to -- be referenced (otherwise we have problems with the backend). It is @@ -4045,6 +4083,7 @@ package body Exp_Disp is -- HT_Link => HT_Link'Address, -- Transportable => <>, -- RC_Offset => <>, + -- [ Size_Func => Size_Prim'Access ] -- [ Interfaces_Table => <> ] -- [ SSD => SSD_Table'Address ] -- Tags_Table => (0 => null, @@ -4204,23 +4243,28 @@ package body Exp_Disp is -- External tag of a library-level tagged type: Check for a definition -- of External_Tag. The clause is considered only if it applies to this -- specific tagged type, as opposed to one of its ancestors. + -- If the type is an unconstrained type extension, we are building the + -- dispatch table of its anonymous base type, so the external tag, if + -- any was specified, must be retrieved from the first subtype. else declare - Def : constant Node_Id := Get_Attribute_Definition_Clause (Typ, - Attribute_External_Tag); + Def : constant Node_Id := Get_Attribute_Definition_Clause + (First_Subtype (Typ), + Attribute_External_Tag); + Old_Val : String_Id; New_Val : String_Id; E : Entity_Id; begin if not Present (Def) - or else Entity (Name (Def)) /= Typ + or else Entity (Name (Def)) /= First_Subtype (Typ) then New_Node := Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Exname, Loc), + Prefix => New_Reference_To (Exname, Loc), Attribute_Name => Name_Address)); else Old_Val := Strval (Expr_Value_S (Expression (Def))); @@ -4320,15 +4364,8 @@ package body Exp_Disp is declare RC_Offset_Node : Node_Id; - Parent_Typ : Entity_Id; begin - if Present (Full_View (Etype (Typ))) then - Parent_Typ := Full_View (Etype (Typ)); - else - Parent_Typ := Etype (Typ); - end if; - if not Has_Controlled_Component (Typ) then RC_Offset_Node := Make_Integer_Literal (Loc, 0); @@ -4368,6 +4405,52 @@ package body Exp_Disp is Append_To (TSD_Aggr_List, RC_Offset_Node); end; + -- Size_Func + + if RTE_Record_Component_Available (RE_Size_Func) then + if not Building_Static_DT (Typ) + or else Is_Interface (Typ) + then + Append_To (TSD_Aggr_List, + Unchecked_Convert_To (RTE (RE_Size_Ptr), + New_Reference_To (RTE (RE_Null_Address), Loc))); + + else + declare + Prim_Elmt : Elmt_Id; + Prim : Entity_Id; + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Chars (Prim) = Name_uSize then + while Present (Alias (Prim)) loop + Prim := Alias (Prim); + end loop; + + if Is_Abstract_Subprogram (Prim) then + Append_To (TSD_Aggr_List, + Unchecked_Convert_To (RTE (RE_Size_Ptr), + New_Reference_To (RTE (RE_Null_Address), Loc))); + else + Append_To (TSD_Aggr_List, + Unchecked_Convert_To (RTE (RE_Size_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Unrestricted_Access))); + end if; + + exit; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + end if; + end if; + -- Interfaces_Table (required for AI-405) if RTE_Record_Component_Available (RE_Interfaces_Table) then @@ -4561,34 +4644,34 @@ package body Exp_Disp is -- Initialize the table of ancestor tags. In case of interface types -- this table is not needed. - declare - Current_Typ : Entity_Id; - Parent_Typ : Entity_Id; - Pos : Nat; + TSD_Tags_List := New_List; - begin - TSD_Tags_List := New_List; + -- If we are not statically allocating the dispatch table then we must + -- fill position 0 with null because we still have not generated the + -- tag of Typ. - -- If we are not statically allocating the dispatch table then we - -- must fill position 0 with null because we still have not - -- generated the tag of Typ. + if not Building_Static_DT (Typ) + or else Is_Interface (Typ) + then + Append_To (TSD_Tags_List, + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (RTE (RE_Null_Address), Loc))); - if not Building_Static_DT (Typ) - or else Is_Interface (Typ) - then - Append_To (TSD_Tags_List, - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (RTE (RE_Null_Address), Loc))); + -- Otherwise we can safely reference the tag - -- Otherwise we can safely reference the tag + else + Append_To (TSD_Tags_List, + New_Reference_To (DT_Ptr, Loc)); + end if; - else - Append_To (TSD_Tags_List, - New_Reference_To (DT_Ptr, Loc)); - end if; + -- Fill the rest of the table with the tags of the ancestors - -- Fill the rest of the table with the tags of the ancestors + declare + Current_Typ : Entity_Id; + Parent_Typ : Entity_Id; + Pos : Nat; + begin Pos := 1; Current_Typ := Typ; @@ -4775,6 +4858,7 @@ package body Exp_Disp is declare Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; + Decl : Node_Id; E : Entity_Id; begin @@ -4808,26 +4892,43 @@ package body Exp_Disp is for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := - Unchecked_Convert_To (RTE (RE_Address), + Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim_Table (J), Loc), Attribute_Name => Name_Unrestricted_Access)); else - New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); + New_Node := Make_Null (Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); end loop; + New_Node := + Make_Aggregate (Loc, + Expressions => Prim_Ops_Aggr_List); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('S')), + Subtype_Indication => + New_Reference_To (RTE (RE_Address_Array), Loc)); + + Append_To (Result, Decl); + Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims, Aliased_Present => True, Constant_Present => Building_Static_DT (Typ), - Object_Definition => - New_Reference_To (RTE (RE_Address_Array), Loc), - Expression => Make_Aggregate (Loc, - Expressions => Prim_Ops_Aggr_List))); + Object_Definition => New_Reference_To + (Defining_Identifier (Decl), Loc), + Expression => New_Node)); + + -- Remember aggregates initializing dispatch tables + + Append_Elmt (New_Node, DT_Aggr); Append_To (Result, Make_Attribute_Definition_Clause (Loc, @@ -4880,9 +4981,7 @@ package body Exp_Disp is -- Offset_To_Top - if RTE_Record_Component_Available (RE_Offset_To_Top) then - Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); - end if; + Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); -- Typeinfo @@ -4896,13 +4995,11 @@ package body Exp_Disp is Prim_Ops_Aggr_List := New_List; if Nb_Prim = 0 then - Append_To (Prim_Ops_Aggr_List, - New_Reference_To (RTE (RE_Null_Address), Loc)); + Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); elsif not Building_Static_DT (Typ) then for J in 1 .. Nb_Prim loop - Append_To (Prim_Ops_Aggr_List, - New_Reference_To (RTE (RE_Null_Address), Loc)); + Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); end loop; else @@ -4951,12 +5048,12 @@ package body Exp_Disp is for J in Prim_Table'Range loop if Present (Prim_Table (J)) then New_Node := - Unchecked_Convert_To (RTE (RE_Address), + Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim_Table (J), Loc), Attribute_Name => Name_Unrestricted_Access)); else - New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); + New_Node := Make_Null (Loc); end if; Append_To (Prim_Ops_Aggr_List, New_Node); @@ -4964,9 +5061,15 @@ package body Exp_Disp is end; end if; - Append_To (DT_Aggr_List, + New_Node := Make_Aggregate (Loc, - Expressions => Prim_Ops_Aggr_List)); + Expressions => Prim_Ops_Aggr_List); + + Append_To (DT_Aggr_List, New_Node); + + -- Remember aggregates initializing dispatch tables + + Append_Elmt (New_Node, DT_Aggr); -- In case of locally defined tagged types we have already declared -- and uninitialized object for the dispatch table, which is now @@ -5048,26 +5151,27 @@ package body Exp_Disp is -- If the ancestor is a CPP_Class type we inherit the dispatch tables -- in the init proc, and we don't need to fill them in here. - elsif Is_CPP_Class (Etype (Typ)) then + elsif Is_CPP_Class (Parent_Typ) then null; -- Otherwise we fill in the dispatch tables here else - if Typ /= Etype (Typ) + if Typ /= Parent_Typ and then not Is_Interface (Typ) and then not Restriction_Active (No_Dispatching_Calls) then -- Inherit the dispatch table if not Is_Interface (Typ) - and then not Is_Interface (Etype (Typ)) - and then not Is_CPP_Class (Etype (Typ)) + and then not Is_Interface (Parent_Typ) + and then not Is_CPP_Class (Parent_Typ) then declare Nb_Prims : constant Int := UI_To_Int (DT_Entry_Count - (First_Tag_Component (Etype (Typ)))); + (First_Tag_Component (Parent_Typ))); + begin Append_To (Elab_Code, Build_Inherit_Predefined_Prims (Loc, @@ -5076,7 +5180,7 @@ package body Exp_Disp is (Node (Next_Elmt (First_Elmt - (Access_Disp_Table (Etype (Typ))))), Loc), + (Access_Disp_Table (Parent_Typ)))), Loc), New_Tag_Node => New_Reference_To (Node @@ -5092,7 +5196,7 @@ package body Exp_Disp is New_Reference_To (Node (First_Elmt - (Access_Disp_Table (Etype (Typ)))), Loc), + (Access_Disp_Table (Parent_Typ))), Loc), New_Tag_Node => New_Reference_To (DT_Ptr, Loc), Num_Prims => Nb_Prims)); end if; @@ -5101,13 +5205,13 @@ package body Exp_Disp is -- Inherit the secondary dispatch tables of the ancestor - if not Is_CPP_Class (Etype (Typ)) then + if not Is_CPP_Class (Parent_Typ) then declare Sec_DT_Ancestor : Elmt_Id := Next_Elmt (Next_Elmt (First_Elmt - (Access_Disp_Table (Etype (Typ))))); + (Access_Disp_Table (Parent_Typ)))); Sec_DT_Typ : Elmt_Id := Next_Elmt (Next_Elmt @@ -5327,18 +5431,49 @@ package body Exp_Disp is Make_Select_Specific_Data_Table (Typ)); end if; - -- Mark entities containing library level static dispatch tables. This - -- attribute is later propagated to all the access-to-subprogram itypes - -- generated to fill the dispatch table slots (see exp_attr). + -- Remember entities containing dispatch tables - if Building_Static_DT (Typ) then - Set_Is_Static_Dispatch_Table_Entity (Predef_Prims); - Set_Is_Static_Dispatch_Table_Entity (DT); - end if; + Append_Elmt (Predef_Prims, DT_Decl); + Append_Elmt (DT, DT_Decl); Analyze_List (Result, Suppress => All_Checks); Set_Has_Dispatch_Table (Typ); + -- Mark entities containing dispatch tables. Required by the + -- backend to handle them properly. + + if not Is_Interface (Typ) then + declare + Elmt : Elmt_Id; + + begin + -- Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have + -- the decoration required by the backend + + Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr)); + Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr)); + + -- Object declarations + + Elmt := First_Elmt (DT_Decl); + while Present (Elmt) loop + Set_Is_Dispatch_Table_Entity (Node (Elmt)); + pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype + or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype); + Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt))); + Next_Elmt (Elmt); + end loop; + + -- Aggregates initializing dispatch tables + + Elmt := First_Elmt (DT_Aggr); + while Present (Elmt) loop + Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt))); + Next_Elmt (Elmt); + end loop; + end; + end if; + return Result; end Make_DT; @@ -5763,7 +5898,7 @@ package body Exp_Disp is -- expand dispatching calls through the primary dispatch table. -- Generate: - -- type Typ_DT is array (1 .. Nb_Prims) of Address; + -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr; -- type Typ_DT_Acc is access Typ_DT; declare @@ -5791,7 +5926,7 @@ package body Exp_Disp is Component_Definition => Make_Component_Definition (Loc, Subtype_Indication => - New_Reference_To (RTE (RE_Address), Loc))))); + New_Reference_To (RTE (RE_Prim_Ptr), Loc))))); Append_To (Result, Make_Full_Type_Declaration (Loc, @@ -5810,6 +5945,11 @@ package body Exp_Disp is Analyze_List (Result); Set_Suppress_Init_Proc (Base_Type (DT_Prims)); + + -- Mark entity of dispatch table. Required by the backend to handle + -- the properly. + + Set_Is_Dispatch_Table_Entity (DT_Prims); end; Set_Ekind (DT_Ptr, E_Constant); @@ -5949,9 +6089,9 @@ package body Exp_Disp is L : List_Id; Pos : Uint; Tag : Entity_Id; + Tag_Typ : Entity_Id; Thunk_Id : Entity_Id; Thunk_Code : Node_Id; - Typ : Entity_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); @@ -5961,35 +6101,49 @@ package body Exp_Disp is end if; if not Present (Abstract_Interface_Alias (Prim)) then - Typ := Scope (DTC_Entity (Prim)); + Tag_Typ := Scope (DTC_Entity (Prim)); Pos := DT_Position (Prim); - Tag := First_Tag_Component (Typ); + Tag := First_Tag_Component (Tag_Typ); if Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (Prim) then - DT_Ptr := Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); + DT_Ptr := + Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ)))); + Insert_After (Ins_Nod, Build_Set_Predefined_Prim_Op_Address (Loc, Tag_Node => New_Reference_To (DT_Ptr, Loc), Position => Pos, Address_Node => - Unchecked_Convert_To (RTE (RE_Address), + Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim, Loc), Attribute_Name => Name_Unrestricted_Access)))); + -- Register copy of the pointer to the 'size primitive in the TSD. + + if Chars (Prim) = Name_uSize + and then RTE_Record_Component_Available (RE_Size_Func) + then + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); + Insert_After (Ins_Nod, + Build_Set_Size_Function (Loc, + Tag_Node => New_Reference_To (DT_Ptr, Loc), + Size_Func => Prim)); + end if; + else pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); - DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); Insert_After (Ins_Nod, Build_Set_Prim_Op_Address (Loc, - Typ => Typ, + Typ => Tag_Typ, Tag_Node => New_Reference_To (DT_Ptr, Loc), Position => Pos, Address_Node => - Unchecked_Convert_To (RTE (RE_Address), + Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim, Loc), Attribute_Name => Name_Unrestricted_Access)))); @@ -6002,14 +6156,14 @@ package body Exp_Disp is -- else to do here. else - Typ := Find_Dispatching_Type (Alias (Prim)); + Tag_Typ := Find_Dispatching_Type (Alias (Prim)); Iface_Typ := Find_Dispatching_Type (Abstract_Interface_Alias (Prim)); pragma Assert (Is_Interface (Iface_Typ)); Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); - if not Is_Parent (Iface_Typ, Typ) + if not Is_Parent (Iface_Typ, Tag_Typ) and then Present (Thunk_Code) then -- Comment needed on why checks are suppressed. This is not just @@ -6022,7 +6176,7 @@ package body Exp_Disp is -- the secondary dispatch table of Prim's controlling type with -- Thunk_Id's address. - Iface_DT_Elmt := Find_Interface_ADT (Typ, Iface_Typ); + Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ); Iface_DT_Ptr := Node (Iface_DT_Elmt); pragma Assert (Has_Thunks (Iface_DT_Ptr)); @@ -6040,7 +6194,7 @@ package body Exp_Disp is New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc), Position => Pos, Address_Node => - Unchecked_Convert_To (RTE (RE_Address), + Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Thunk_Id, Loc), Attribute_Name => Name_Unrestricted_Access)))); @@ -6056,7 +6210,7 @@ package body Exp_Disp is New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc), Position => Pos, Address_Node => - Unchecked_Convert_To (RTE (RE_Address), + Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Alias (Prim), Loc), Attribute_Name => Name_Unrestricted_Access)))); @@ -6073,7 +6227,7 @@ package body Exp_Disp is Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Position => Pos, Address_Node => - Unchecked_Convert_To (RTE (RE_Address), + Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Thunk_Id, Loc), Attribute_Name => Name_Unrestricted_Access)))); @@ -6089,7 +6243,7 @@ package body Exp_Disp is Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), Position => Pos, Address_Node => - Unchecked_Convert_To (RTE (RE_Address), + Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Alias (Prim), Loc), Attribute_Name => Name_Unrestricted_Access)))); diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index b26693106ad..aceb6a11e11 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -283,6 +283,9 @@ package body Rtsfind is if U_Id in Ada_Calendar_Child then Name_Buffer (13) := '.'; + elsif U_Id in Ada_Dispatching_Child then + Name_Buffer (16) := '.'; + elsif U_Id in Ada_Finalization_Child then Name_Buffer (17) := '.'; @@ -311,6 +314,10 @@ package body Rtsfind is elsif U_Id in System_Child then Name_Buffer (7) := '.'; + if U_Id in System_Strings_Child then + Name_Buffer (15) := '.'; + end if; + if U_Id in System_Tasking_Child then Name_Buffer (15) := '.'; end if; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 2388ed09870..86779cb28d2 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -78,6 +78,9 @@ package Rtsfind is -- name is System.xxx. For example, the name System_Str_Concat refers to -- package System.Str_Concat. + -- Names of the form System_Strings_xxx are second level children of the + -- package System.Strings. + -- Names of the form System_Tasking_xxx are second level children of the -- package System.Tasking. For example, System_Tasking_Stages refers to -- refers to the package System.Tasking.Stages. @@ -112,6 +115,7 @@ package Rtsfind is -- Children of Ada Ada_Calendar, + Ada_Dispatching, Ada_Exceptions, Ada_Finalization, Ada_Interrupts, @@ -125,6 +129,10 @@ package Rtsfind is Ada_Calendar_Delays, + -- Children of Ada.Dispatching + + Ada_Dispatching_EDF, + -- Children of Ada.Finalization Ada_Finalization_List_Controller, @@ -348,6 +356,10 @@ package Rtsfind is System_WWd_Enum, System_WWd_Wchar, + -- Children of System.Strings + + System_Strings_Stream_Ops, + -- Children of System.Tasking System_Tasking_Async_Delays, @@ -369,6 +381,10 @@ package Rtsfind is range Ada_Calendar_Delays .. Ada_Calendar_Delays; -- Range of values for children of Ada.Calendar + subtype Ada_Dispatching_Child is RTU_Id + range Ada_Dispatching_EDF .. Ada_Dispatching_EDF; + -- Range of values for children of Ada.Dispatching + subtype Ada_Finalization_Child is Ada_Child range Ada_Finalization_List_Controller .. Ada_Finalization_List_Controller; -- Range of values for children of Ada.Finalization @@ -404,6 +420,9 @@ package Rtsfind is range System_Address_Image .. System_Tasking_Stages; -- Range of values for children or grandchildren of System + subtype System_Strings_Child is RTU_Id + range System_Strings_Stream_Ops .. System_Strings_Stream_Ops; + subtype System_Tasking_Child is System_Child range System_Tasking_Async_Delays .. System_Tasking_Stages; -- Range of values for children of System.Tasking @@ -451,6 +470,8 @@ package Rtsfind is RE_Null, + RE_Set_Deadline, -- Ada.Dispatching.EDF + RE_Code_Loc, -- Ada.Exceptions RE_Current_Target_Exception, -- Ada.Exceptions (JGNAT use only) RE_Exception_Id, -- Ada.Exceptions @@ -497,6 +518,7 @@ package Rtsfind is RE_Dispatch_Table_Wrapper, -- Ada.Tags RE_Displace, -- Ada.Tags RE_DT, -- Ada.Tags + RE_DT_Offset_To_Top_Offset, -- Ada.Tags RE_DT_Predef_Prims_Offset, -- Ada.Tags RE_DT_Typeinfo_Ptr_Size, -- Ada.Tags RE_External_Tag, -- Ada.Tags @@ -520,6 +542,7 @@ package Rtsfind is RE_Num_Prims, -- Ada.Tags RE_Object_Specific_Data, -- Ada.Tags RE_Offset_To_Top, -- Ada.Tags + RE_Offset_To_Top_Ptr, -- Ada.Tags RE_Offset_To_Top_Function_Ptr, -- Ada.Tags RE_OSD_Table, -- Ada.Tags RE_OSD_Num_Prims, -- Ada.Tags @@ -534,20 +557,24 @@ package Rtsfind is RE_Predef_Prims, -- Ada.Tags RE_Predef_Prims_Table_Ptr, -- Ada.Tags RE_Prim_Op_Kind, -- Ada.Tags + RE_Prim_Ptr, -- Ada.Tags RE_Prims_Ptr, -- Ada.Tags RE_Primary_DT, -- Ada.Tags RE_Signature, -- Ada.Tags RE_SSD, -- Ada.Tags RE_TSD, -- Ada.Tags RE_Type_Specific_Data, -- Ada.Tags + RE_Register_Interface_Offset, -- Ada.Tags RE_Register_Tag, -- Ada.Tags RE_Transportable, -- Ada.Tags RE_Secondary_DT, -- Ada.Tags RE_Secondary_Tag, -- Ada.Tags RE_Select_Specific_Data, -- Ada.Tags RE_Set_Entry_Index, -- Ada.Tags - RE_Set_Offset_To_Top, -- Ada.Tags + RE_Set_Dynamic_Offset_To_Top, -- Ada.Tags RE_Set_Prim_Op_Kind, -- Ada.Tags + RE_Size_Func, -- Ada.Tags + RE_Size_Ptr, -- Ada.Tags RE_Tag, -- Ada.Tags RE_Tag_Error, -- Ada.Tags RE_Tag_Kind, -- Ada.Tags @@ -573,6 +600,9 @@ package Rtsfind is RO_CA_Delay_Until, -- Ada.Calendar.Delays RO_CA_To_Duration, -- Ada.Calendar.Delays + RE_Clock, -- Ada.Real_Time + RE_Time_Span, -- Ada.Real_Time + RE_Time_Span_Zero, -- Ada.Real_Time RO_RT_Time, -- Ada.Real_Time RO_RT_Delay_Until, -- Ada.Real_Time.Delays @@ -749,6 +779,7 @@ package Rtsfind is RE_Default_Interrupt_Priority, -- System.Interrupts RE_Dynamic_Interrupt_Protection, -- System.Interrupts RE_Install_Handlers, -- System.Interrupts + RE_Install_Restricted_Handlers, -- System.Interrupts RE_Register_Interrupt_Handler, -- System.Interrupts RE_Static_Interrupt_Protection, -- System.Interrupts RE_System_Interrupt_Id, -- System.Interrupts @@ -1233,11 +1264,10 @@ package Rtsfind is RE_Storage_Offset, -- System.Storage_Elements RE_Storage_Array, -- System.Storage_Elements RE_To_Address, -- System.Storage_Elements - RE_Dummy_Communication_Block, -- System.Storage_Elements RE_Root_Storage_Pool, -- System.Storage_Pools - RE_Allocate_Any, -- System_Storage_Pools, - RE_Deallocate_Any, -- System_Storage_Pools, + RE_Allocate_Any, -- System.Storage_Pools, + RE_Deallocate_Any, -- System.Storage_Pools, RE_I_AD, -- System.Stream_Attributes RE_I_AS, -- System.Stream_Attributes @@ -1292,6 +1322,19 @@ package Rtsfind is RE_Str_Concat_5, -- System.String_Ops_Concat_5 + RE_String_Input, -- System.Strings.Stream_Ops + RE_String_Output, -- System.Strings.Stream_Ops + RE_String_Read, -- System.Strings.Stream_Ops + RE_String_Write, -- System.Strings.Stream_Ops + RE_Wide_String_Input, -- System.Strings.Stream_Ops + RE_Wide_String_Output, -- System.Strings.Stream_Ops + RE_Wide_String_Read, -- System.Strings.Stream_Ops + RE_Wide_String_Write, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Input, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Output, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Read, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Write, -- System.Strings.Stream_Ops + RE_Task_Info_Type, -- System.Task_Info RE_Unspecified_Task_Info, -- System.Task_Info @@ -1331,6 +1374,7 @@ package Rtsfind is RE_Abort_Undefer, -- System.Soft_Links RE_Complete_Master, -- System.Soft_Links RE_Current_Master, -- System.Soft_Links + RE_Dummy_Communication_Block, -- System.Soft_Links RE_Enter_Master, -- System.Soft_Links RE_Get_Current_Excep, -- System.Soft_Links RE_Get_GNAT_Exception, -- System.Soft_Links @@ -1555,6 +1599,8 @@ package Rtsfind is RE_Null => RTU_Null, + RE_Set_Deadline => Ada_Dispatching_EDF, + RE_Code_Loc => Ada_Exceptions, RE_Current_Target_Exception => Ada_Exceptions, -- of JGNAT RE_Exception_Id => Ada_Exceptions, @@ -1601,6 +1647,7 @@ package Rtsfind is RE_Dispatch_Table_Wrapper => Ada_Tags, RE_Displace => Ada_Tags, RE_DT => Ada_Tags, + RE_DT_Offset_To_Top_Offset => Ada_Tags, RE_DT_Predef_Prims_Offset => Ada_Tags, RE_DT_Typeinfo_Ptr_Size => Ada_Tags, RE_External_Tag => Ada_Tags, @@ -1624,6 +1671,7 @@ package Rtsfind is RE_Num_Prims => Ada_Tags, RE_Object_Specific_Data => Ada_Tags, RE_Offset_To_Top => Ada_Tags, + RE_Offset_To_Top_Ptr => Ada_Tags, RE_Offset_To_Top_Function_Ptr => Ada_Tags, RE_OSD_Table => Ada_Tags, RE_OSD_Num_Prims => Ada_Tags, @@ -1638,20 +1686,24 @@ package Rtsfind is RE_Predef_Prims => Ada_Tags, RE_Predef_Prims_Table_Ptr => Ada_Tags, RE_Prim_Op_Kind => Ada_Tags, + RE_Prim_Ptr => Ada_Tags, RE_Prims_Ptr => Ada_Tags, RE_Primary_DT => Ada_Tags, RE_Signature => Ada_Tags, RE_SSD => Ada_Tags, RE_TSD => Ada_Tags, RE_Type_Specific_Data => Ada_Tags, + RE_Register_Interface_Offset => Ada_Tags, RE_Register_Tag => Ada_Tags, RE_Transportable => Ada_Tags, RE_Secondary_DT => Ada_Tags, RE_Secondary_Tag => Ada_Tags, RE_Select_Specific_Data => Ada_Tags, RE_Set_Entry_Index => Ada_Tags, - RE_Set_Offset_To_Top => Ada_Tags, + RE_Set_Dynamic_Offset_To_Top => Ada_Tags, RE_Set_Prim_Op_Kind => Ada_Tags, + RE_Size_Func => Ada_Tags, + RE_Size_Ptr => Ada_Tags, RE_Tag => Ada_Tags, RE_Tag_Error => Ada_Tags, RE_Tag_Kind => Ada_Tags, @@ -1676,6 +1728,9 @@ package Rtsfind is RO_CA_Delay_Until => Ada_Calendar_Delays, RO_CA_To_Duration => Ada_Calendar_Delays, + RE_Clock => Ada_Real_Time, + RE_Time_Span => Ada_Real_Time, + RE_Time_Span_Zero => Ada_Real_Time, RO_RT_Time => Ada_Real_Time, RO_RT_Delay_Until => Ada_Real_Time_Delays, RO_RT_To_Duration => Ada_Real_Time_Delays, @@ -1851,6 +1906,7 @@ package Rtsfind is RE_Default_Interrupt_Priority => System_Interrupts, RE_Dynamic_Interrupt_Protection => System_Interrupts, RE_Install_Handlers => System_Interrupts, + RE_Install_Restricted_Handlers => System_Interrupts, RE_Register_Interrupt_Handler => System_Interrupts, RE_Static_Interrupt_Protection => System_Interrupts, RE_System_Interrupt_Id => System_Interrupts, @@ -2335,7 +2391,6 @@ package Rtsfind is RE_Storage_Offset => System_Storage_Elements, RE_Storage_Array => System_Storage_Elements, RE_To_Address => System_Storage_Elements, - RE_Dummy_Communication_Block => System_Storage_Elements, RE_Root_Storage_Pool => System_Storage_Pools, RE_Allocate_Any => System_Storage_Pools, @@ -2394,6 +2449,19 @@ package Rtsfind is RE_Str_Concat_5 => System_String_Ops_Concat_5, + RE_String_Input => System_Strings_Stream_Ops, + RE_String_Output => System_Strings_Stream_Ops, + RE_String_Read => System_Strings_Stream_Ops, + RE_String_Write => System_Strings_Stream_Ops, + RE_Wide_String_Input => System_Strings_Stream_Ops, + RE_Wide_String_Output => System_Strings_Stream_Ops, + RE_Wide_String_Read => System_Strings_Stream_Ops, + RE_Wide_String_Write => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Input => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Output => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Read => System_Strings_Stream_Ops, + RE_Wide_Wide_String_Write => System_Strings_Stream_Ops, + RE_Task_Info_Type => System_Task_Info, RE_Unspecified_Task_Info => System_Task_Info, @@ -2433,6 +2501,7 @@ package Rtsfind is RE_Abort_Undefer => System_Soft_Links, RE_Complete_Master => System_Soft_Links, RE_Current_Master => System_Soft_Links, + RE_Dummy_Communication_Block => System_Soft_Links, RE_Enter_Master => System_Soft_Links, RE_Get_Current_Excep => System_Soft_Links, RE_Get_GNAT_Exception => System_Soft_Links, -- 2.30.2