diff options
author | Hristian Kirtchev <kirtchev@adacore.com> | 2005-11-15 14:54:36 +0100 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2005-11-15 14:54:36 +0100 |
commit | f4d379b8df138d05368dded1c6368ef549d65088 (patch) | |
tree | 873996443f0c7e7119eead6a25a380b1d3b5441a | |
parent | 748d8778ede2249ee70323886d36fcdd5c08248d (diff) | |
download | gcc-f4d379b8df138d05368dded1c6368ef549d65088.zip gcc-f4d379b8df138d05368dded1c6368ef549d65088.tar.gz gcc-f4d379b8df138d05368dded1c6368ef549d65088.tar.bz2 |
rtsfind.ads, [...]: Complete support for Ada 2005 interfaces.
2005-11-14 Hristian Kirtchev <kirtchev@adacore.com>
Javier Miranda <miranda@adacore.com>
* rtsfind.ads, exp_util.adb, exp_util.ads, exp_disp.adb, exp_disp.ads,
exp_ch7.adb, sem_ch9.adb, snames.adb, snames.ads,
exp_ch9.adb, exp_ch9.ads, exp_ch6.adb, exp_ch3.adb, exp_ch3.ads,
einfo.ads, einfo.adb: Complete support for Ada 2005 interfaces.
* a-tags.ads, a-tags.adb: Major rewrite and additions to implement
properly new Ada 2005 interfaces (AI-345) and add run-time checks (via
assertions).
* exp_dbug.ads, exp_dbug.adb (Get_Secondary_DT_External_Name): New
subprogram that generates the external name associated with a
secondary dispatch table.
(Get_Secondary_DT_External_Name): New subprogram that generates the
external name associated with a secondary dispatch table.
From-SVN: r106965
-rw-r--r-- | gcc/ada/a-tags.adb | 556 | ||||
-rw-r--r-- | gcc/ada/a-tags.ads | 204 | ||||
-rw-r--r-- | gcc/ada/einfo.adb | 148 | ||||
-rw-r--r-- | gcc/ada/einfo.ads | 103 | ||||
-rw-r--r-- | gcc/ada/exp_ch3.adb | 276 | ||||
-rw-r--r-- | gcc/ada/exp_ch3.ads | 66 | ||||
-rw-r--r-- | gcc/ada/exp_ch6.adb | 298 | ||||
-rw-r--r-- | gcc/ada/exp_ch7.adb | 27 | ||||
-rw-r--r-- | gcc/ada/exp_ch9.adb | 1913 | ||||
-rw-r--r-- | gcc/ada/exp_ch9.ads | 16 | ||||
-rw-r--r-- | gcc/ada/exp_dbug.adb | 68 | ||||
-rw-r--r-- | gcc/ada/exp_dbug.ads | 74 | ||||
-rw-r--r-- | gcc/ada/exp_disp.adb | 2342 | ||||
-rw-r--r-- | gcc/ada/exp_disp.ads | 205 | ||||
-rw-r--r-- | gcc/ada/exp_util.adb | 271 | ||||
-rw-r--r-- | gcc/ada/exp_util.ads | 47 | ||||
-rw-r--r-- | gcc/ada/rtsfind.ads | 85 | ||||
-rw-r--r-- | gcc/ada/sem_ch9.adb | 155 | ||||
-rw-r--r-- | gcc/ada/snames.adb | 4 | ||||
-rw-r--r-- | gcc/ada/snames.ads | 1418 |
20 files changed, 5168 insertions, 3108 deletions
diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 4a21e15..8c9312e 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-2005, 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- -- @@ -39,43 +39,64 @@ pragma Elaborate_All (System.HTable); package body Ada.Tags is --- Structure of the GNAT Dispatch Table +-- Structure of the GNAT Primary Dispatch Table -- +-----------------------+ +-- | Signature | +-- +-----------------------+ -- | Offset_To_Top | -- +-----------------------+ --- | Typeinfo_Ptr/TSD_Ptr |----> Type Specific Data +-- | Typeinfo_Ptr/TSD_Ptr | ---> Type Specific Data -- Tag ---> +-----------------------+ +-------------------+ -- | table of | | inheritance depth | -- : primitive ops : +-------------------+ --- | pointers | | expanded name | +-- | pointers | | access level | -- +-----------------------+ +-------------------+ --- | external tag | --- +-------------------+ --- | Hash table link | +-- | expanded name | -- +-------------------+ --- | Remotely Callable | --- +-------------------+ --- | Rec Ctrler offset | +-- | external tag | -- +-------------------+ --- | Num_Interfaces | +-- | hash table link | -- +-------------------+ --- | table of | --- : ancestor : --- | tags | +-- | remotely callable | -- +-------------------+ --- | table of | --- : interface : --- | tags | +-- | rec ctrler offset | -- +-------------------+ --- | table of | --- : primitive op : --- | kinds | +-- | num prim ops | -- +-------------------+ --- | table of | --- : entry : --- | indices | +-- | num interfaces | -- +-------------------+ +-- Select Specific Data <--- | SSD_Ptr | +-- +-----------------------+ +-------------------+ +-- | table of primitive | | table of | +-- : operation : : ancestor : +-- | kinds | | tags | +-- +-----------------------+ +-------------------+ +-- | table of | | table of | +-- : entry : : interface : +-- | indices | | tags | +-- +-----------------------+ +-------------------+ + +-- Structure of the GNAT Secondary Dispatch Table + +-- +-----------------------+ +-- | Signature | +-- +-----------------------+ +-- | Offset_To_Top | +-- +-----------------------+ +-- | OSD_Ptr |---> Object Specific Data +-- Tag ---> +-----------------------+ +---------------+ +-- | table of | | num prim ops | +-- : primitive op : +---------------+ +-- | thunk pointers | | table of | +-- +-----------------------+ + primitive | +-- | op offsets | +-- +---------------+ + + Offset_To_Signature : constant SSE.Storage_Count := + DT_Typeinfo_Ptr_Size + + DT_Offset_To_Top_Size + + DT_Signature_Size; subtype Cstring is String (Positive); type Cstring_Ptr is access all Cstring; @@ -87,13 +108,39 @@ package body Ada.Tags is pragma Suppress_Initialization (Tag_Table); pragma Suppress (Index_Check, On => Tag_Table); - type Prim_Op_Kind_Table is array (Natural range <>) of Prim_Op_Kind; - pragma Suppress_Initialization (Prim_Op_Kind_Table); - pragma Suppress (Index_Check, On => Prim_Op_Kind_Table); + -- Object specific data types + + type Object_Specific_Data_Array is array (Positive range <>) of Positive; + + type Object_Specific_Data (Nb_Prim : Positive) is record + Num_Prim_Ops : Natural; + -- Number of primitive operations of the dispatch table. This field is + -- used by the run-time check routines that are activated when the + -- run-time is compiled with assertions enabled. + + OSD_Table : Object_Specific_Data_Array (1 .. Nb_Prim); + -- Table used in secondary DT to reference their counterpart in the + -- select specific data (in the TSD of the primary DT). This construct + -- is used in the handling of dispatching triggers in select statements. + -- Nb_Prim is the number of non-predefined primitive operations. + end record; + + -- Select specific data types + + type Select_Specific_Data_Element is record + Index : Positive; + Kind : Prim_Op_Kind; + end record; + + type Select_Specific_Data_Array is + array (Positive range <>) of Select_Specific_Data_Element; + + type Select_Specific_Data (Nb_Prim : Positive) is record + SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim); + -- NOTE: Nb_Prim is the number of non-predefined primitive operations + end record; - type Entry_Index_Table is array (Natural range <>) of Positive; - pragma Suppress_Initialization (Entry_Index_Table); - pragma Suppress (Index_Check, On => Entry_Index_Table); + -- Type specific data types type Type_Specific_Data is record Idepth : Natural; @@ -124,11 +171,22 @@ package body Ada.Tags is -- Controller Offset: Used to give support to tagged controlled objects -- (see Get_Deep_Controller at s-finimp) + Num_Prim_Ops : Natural; + -- Number of primitive operations of the dispatch table. This field is + -- used for additional run-time checks when the run-time is compiled + -- with assertions enabled. + Num_Interfaces : Natural; -- Number of abstract interface types implemented by the tagged type. -- The value Idepth+Num_Interfaces indicates the end of the second table -- stored in the Tags_Table component. It is used to implement the - -- membership test associated with interfaces (Ada 2005:AI-251) + -- membership test associated with interfaces (Ada 2005:AI-251). + + SSD_Ptr : System.Address; + -- Pointer to a table of records used in dispatching selects. This + -- field has a meaningful value for all tagged types that implement + -- a limited, protected, synchronized or task interfaces and have + -- non-predefined primitive operations. Tags_Table : Tag_Table (0 .. 1); -- The size of the Tags_Table array actually depends on the tagged type @@ -138,21 +196,9 @@ package body Ada.Tags is -- purpose we are using the same mechanism as for the Prims_Ptr array in -- the Dispatch_Table record. See comments below on Prims_Ptr for -- further details. - - POK_Table : Prim_Op_Kind_Table (1 .. 1); - Ent_Index_Table : Entry_Index_Table (1 .. 1); - -- Two auxiliary tables used for dispatching in asynchronous, - -- conditional and timed selects. Their size depends on the number - -- of primitive operations. Indexing in these two tables is performed - -- by subtracting the number of predefined primitive operations from - -- the given index value. POK_Table contains the callable entity kinds - -- of all non-predefined primitive operations. Ent_Index_Table contains - -- the entry index of primitive entry wrappers. end record; type Dispatch_Table is record - -- Offset_To_Top : Natural; - -- Typeinfo_Ptr : System.Address; -- According to the C++ ABI the components Offset_To_Top and -- Typeinfo_Ptr are stored just "before" the dispatch table (that is, @@ -164,6 +210,9 @@ package body Ada.Tags is -- enough space for these additional components, and generates code that -- displaces the _Tag to point after these components. + -- Offset_To_Top : Natural; + -- Typeinfo_Ptr : System.Address; + Prims_Ptr : Address_Array (1 .. 1); -- The size of the Prims_Ptr array actually depends on the tagged type -- to which it applies. For each tagged type, the expander computes the @@ -185,6 +234,20 @@ 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, + Must_Be_Primary_Or_Secondary_DT, + Must_Be_Interface, + Must_Be_Primary_Or_Interface); + -- Type of signature accepted by primitives in this package that are called + -- during the elaboration of tagged types. This type is used by the routine + -- Check_Signature that is called only when the run-time is compiled with + -- assertions enabled. + --------------------------------------------- -- Unchecked Conversions for String Fields -- --------------------------------------------- @@ -199,6 +262,12 @@ package body Ada.Tags is -- 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 + type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset; function To_Storage_Offset_Ptr is @@ -208,6 +277,30 @@ 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. + + function Check_Size + (Old_T : Tag; + New_T : Tag; + Entry_Count : Natural) return Boolean; + -- Verify that Old_T and New_T have at least Entry_Count entries + + function Get_Num_Prim_Ops (T : Tag) return Natural; + -- Retrieve the number of primitive operations in the dispatch table of T + + function Is_Primary_DT (T : Tag) return Boolean; + pragma Inline_Always (Is_Primary_DT); + -- Given a tag returns True if it has the signature of a primary dispatch + -- table. This is Inline_Always since it is called from other Inline_ + -- Always subprograms where we want no out of line code to be generated. + function Length (Str : Cstring_Ptr) return Natural; -- Length of string represented by the given pointer (treating the string -- as a C-style string, which is Nul terminated). @@ -261,9 +354,9 @@ package body Ada.Tags is package body HTable_Subprograms is - ----------- - -- Equal -- - ----------- + ----------- + -- Equal -- + ----------- function Equal (A, B : System.Address) return Boolean is Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A); @@ -313,6 +406,93 @@ 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 -- + --------------------- + + function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean is + Offset_To_Top_Ptr : constant Storage_Offset_Ptr := + To_Storage_Offset_Ptr (To_Address (T) + - Offset_To_Signature); + + Signature : constant Signature_Values := + To_Signature_Values (Offset_To_Top_Ptr.all); + + Signature_Id : Signature_Kind; + + begin + if Signature (1) /= Valid_Signature then + Signature_Id := Unknown; + + elsif Signature (2) in Primary_DT .. Abstract_Interface then + Signature_Id := Signature (2); + + else + Signature_Id := Unknown; + end if; + + case Signature_Id is + when Primary_DT => + if Kind = Must_Be_Secondary_DT + or else Kind = Must_Be_Interface + then + return False; + end if; + + when Secondary_DT => + if Kind = Must_Be_Primary_DT + or else Kind = Must_Be_Interface + then + return False; + end if; + + when Abstract_Interface => + if Kind = Must_Be_Primary_DT + or else Kind = Must_Be_Secondary_DT + or else Kind = Must_Be_Primary_Or_Secondary_DT + then + return False; + end if; + + when others => + return False; + + end case; + + return True; + end Check_Signature; + + ---------------- + -- Check_Size -- + ---------------- + + function Check_Size + (Old_T : Tag; + New_T : Tag; + Entry_Count : Natural) return Boolean + is + Max_Entries_Old : constant Natural := Get_Num_Prim_Ops (Old_T); + Max_Entries_New : constant Natural := Get_Num_Prim_Ops (New_T); + + begin + return Entry_Count <= Max_Entries_Old + and then Entry_Count <= Max_Entries_New; + end Check_Size; + ------------------- -- CW_Membership -- ------------------- @@ -334,8 +514,11 @@ package body Ada.Tags is -- = Typ'tag function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is - Pos : constant Integer := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth; + Pos : Integer; begin + pragma Assert (Check_Signature (Obj_Tag, Must_Be_Primary_DT)); + pragma Assert (Check_Signature (Typ_Tag, Must_Be_Primary_DT)); + Pos := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth; return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag; end CW_Membership; @@ -353,23 +536,34 @@ package body Ada.Tags is -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces -- that are contained in the dispatch table referenced by Obj'Tag. - function IW_Membership - (This : System.Address; - T : Tag) return Boolean - is + function IW_Membership (This : System.Address; T : Tag) return Boolean is Curr_DT : constant Tag := To_Tag_Ptr (This).all; - Obj_Base : constant System.Address := This - Offset_To_Top (Curr_DT); - Obj_DT : constant Tag := To_Tag_Ptr (Obj_Base).all; - - Obj_TSD : constant Type_Specific_Data_Ptr := TSD (Obj_DT); - Last_Id : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces; - Id : Natural; + Id : Natural; + Last_Id : Natural; + Obj_Base : System.Address; + Obj_DT : Tag; + Obj_TSD : Type_Specific_Data_Ptr; begin + pragma Assert + (Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT)); + pragma Assert + (Check_Signature (T, Must_Be_Primary_Or_Interface)); + + Obj_Base := This - Offset_To_Top (Curr_DT); + Obj_DT := To_Tag_Ptr (Obj_Base).all; + + pragma Assert + (Check_Signature (Curr_DT, Must_Be_Primary_DT)); + + Obj_TSD := TSD (Obj_DT); + Last_Id := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces; + if Obj_TSD.Num_Interfaces > 0 then -- Traverse the ancestor tags table plus the interface tags table. - -- The former part is required to give support to: + -- The former part is required for: + -- Iface_CW in Typ'Class Id := 0; @@ -391,9 +585,13 @@ package body Ada.Tags is -------------------- function Descendant_Tag (External : String; Ancestor : Tag) return Tag is - Int_Tag : constant Tag := Internal_Tag (External); + Int_Tag : Tag; begin + pragma Assert (Check_Signature (Ancestor, Must_Be_Primary_DT)); + Int_Tag := Internal_Tag (External); + pragma Assert (Check_Signature (Int_Tag, Must_Be_Primary_DT)); + if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then raise Tag_Error; end if; @@ -413,6 +611,7 @@ package body Ada.Tags is raise Tag_Error; end if; + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); Result := TSD (T).Expanded_Name; return Result (1 .. Length (Result)); end Expanded_Name; @@ -423,11 +622,13 @@ package body Ada.Tags is function External_Tag (T : Tag) return String is Result : Cstring_Ptr; + begin if T = No_Tag then raise Tag_Error; end if; + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); Result := TSD (T).External_Tag; return Result (1 .. Length (Result)); @@ -439,6 +640,7 @@ package body Ada.Tags is function Get_Access_Level (T : Tag) return Natural is begin + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); return TSD (T).Access_Level; end Get_Access_Level; @@ -446,11 +648,12 @@ package body Ada.Tags is -- Get_Entry_Index -- --------------------- - function Get_Entry_Index - (T : Tag; - Position : Positive) return Positive is + function Get_Entry_Index (T : Tag; Position : Positive) return Positive is + Index : constant Integer := Position - Default_Prim_Op_Count; begin - return TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count); + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); + pragma Assert (Index > 0); + return SSD (T).SSD_Table (Index).Index; end Get_Entry_Index; ---------------------- @@ -459,17 +662,36 @@ package body Ada.Tags is function Get_External_Tag (T : Tag) return System.Address is begin + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); return To_Address (TSD (T).External_Tag); end Get_External_Tag; + ---------------------- + -- Get_Num_Prim_Ops -- + ---------------------- + + function Get_Num_Prim_Ops (T : Tag) return Natural is + begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); + + if Is_Primary_DT (T) then + return TSD (T).Num_Prim_Ops; + else + return OSD (Interface_Tag (T)).Num_Prim_Ops; + end if; + end Get_Num_Prim_Ops; + ------------------------- -- Get_Prim_Op_Address -- ------------------------- function Get_Prim_Op_Address (T : Tag; - Position : Positive) return System.Address is + Position : Positive) return System.Address + is begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); + pragma Assert (Check_Index (T, Position)); return T.Prims_Ptr (Position); end Get_Prim_Op_Address; @@ -479,17 +701,37 @@ package body Ada.Tags is function Get_Prim_Op_Kind (T : Tag; - Position : Positive) return Prim_Op_Kind is + Position : Positive) return Prim_Op_Kind + is + Index : constant Integer := Position - Default_Prim_Op_Count; begin - return TSD (T).POK_Table (Position - Default_Prim_Op_Count); + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); + pragma Assert (Index > 0); + return SSD (T).SSD_Table (Index).Kind; end Get_Prim_Op_Kind; + ---------------------- + -- Get_Offset_Index -- + ---------------------- + + function Get_Offset_Index + (T : Interface_Tag; + Position : Positive) return Positive + is + Index : constant Integer := Position - Default_Prim_Op_Count; + begin + pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT)); + pragma Assert (Index > 0); + return OSD (T).OSD_Table (Index); + end Get_Offset_Index; + ------------------- -- Get_RC_Offset -- ------------------- function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is begin + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); return TSD (T).RC_Offset; end Get_RC_Offset; @@ -499,6 +741,7 @@ package body Ada.Tags is function Get_Remotely_Callable (T : Tag) return Boolean is begin + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); return TSD (T).Remotely_Callable; end Get_Remotely_Callable; @@ -506,12 +749,12 @@ package body Ada.Tags is -- Inherit_DT -- ---------------- - procedure Inherit_DT - (Old_T : Tag; - New_T : Tag; - Entry_Count : Natural) - is + procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is 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)); + pragma Assert (Check_Size (Old_T, New_T, Entry_Count)); + if Old_T /= null then New_T.Prims_Ptr (1 .. Entry_Count) := Old_T.Prims_Ptr (1 .. Entry_Count); @@ -523,17 +766,22 @@ package body Ada.Tags is ----------------- procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag) is - New_TSD_Ptr : constant Type_Specific_Data_Ptr := TSD (New_Tag); + New_TSD_Ptr : Type_Specific_Data_Ptr; Old_TSD_Ptr : Type_Specific_Data_Ptr; begin + pragma Assert (Check_Signature (New_Tag, Must_Be_Primary_Or_Interface)); + New_TSD_Ptr := TSD (New_Tag); + if Old_Tag /= null then + pragma Assert + (Check_Signature (Old_Tag, Must_Be_Primary_Or_Interface)); Old_TSD_Ptr := TSD (Old_Tag); New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1; New_TSD_Ptr.Num_Interfaces := Old_TSD_Ptr.Num_Interfaces; -- Copy the "table of ancestor tags" plus the "table of interfaces" - -- of the parent + -- of the parent. New_TSD_Ptr.Tags_Table (1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces) := @@ -557,7 +805,7 @@ package body Ada.Tags is begin -- Make a copy of the string representing the external tag with - -- a null at the end + -- a null at the end. Ext_Copy (External'Range) := External; Ext_Copy (Ext_Copy'Last) := ASCII.NUL; @@ -567,6 +815,7 @@ package body Ada.Tags is declare Msg1 : constant String := "unknown tagged type: "; Msg2 : String (1 .. Msg1'Length + External'Length); + begin Msg2 (1 .. Msg1'Length) := Msg1; Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) := @@ -591,6 +840,20 @@ package body Ada.Tags is and then TSD (Descendant).Access_Level = TSD (Ancestor).Access_Level; end Is_Descendant_At_Same_Level; + ------------------- + -- Is_Primary_DT -- + ------------------- + + function Is_Primary_DT (T : Tag) return Boolean is + Offset_To_Top_Ptr : constant Storage_Offset_Ptr := + To_Storage_Offset_Ptr (To_Address (T) + - Offset_To_Signature); + Signature : constant Signature_Values := + To_Signature_Values (Offset_To_Top_Ptr.all); + begin + return Signature (2) = Primary_DT; + end Is_Primary_DT; + ------------ -- Length -- ------------ @@ -617,32 +880,45 @@ package body Ada.Tags is To_Storage_Offset_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size - DT_Offset_To_Top_Size); + begin return Offset_To_Top_Ptr.all; end Offset_To_Top; + --------- + -- OSD -- + --------- + + function OSD + (T : Interface_Tag) return Object_Specific_Data_Ptr + is + OSD_Ptr : Addr_Ptr; + + begin + OSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + return To_Object_Specific_Data_Ptr (OSD_Ptr.all); + end OSD; + ----------------- -- Parent_Size -- ----------------- - 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 - function Parent_Size (Obj : System.Address; T : Tag) return SSE.Storage_Count is - Parent_Tag : constant Tag := TSD (T).Tags_Table (1); + Parent_Tag : Tag; -- The tag of the parent type through the dispatch table - F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1)); + 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 + -- 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)); + -- Here we compute the size of the _parent field of the object return SSE.Storage_Count (F.all (Obj)); @@ -658,6 +934,8 @@ package body Ada.Tags is raise Tag_Error; end if; + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); + -- The Parent_Tag of a root-level tagged type is defined to be No_Tag. -- The first entry in the Ancestors_Tags array will be null for such -- a type, but it's better to be explicit about returning No_Tag in @@ -674,20 +952,24 @@ package body Ada.Tags is -- Register_Interface_Tag -- ---------------------------- - procedure Register_Interface_Tag - (T : Tag; - Interface_T : Tag) - is - New_T_TSD : constant Type_Specific_Data_Ptr := TSD (T); + procedure Register_Interface_Tag (T : Tag; Interface_T : Tag) is + New_T_TSD : Type_Specific_Data_Ptr; Index : Natural; + begin + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); + pragma Assert (Check_Signature (Interface_T, Must_Be_Interface)); + + New_T_TSD := TSD (T); + -- Check if the interface is already registered if New_T_TSD.Num_Interfaces > 0 then declare - Id : Natural := New_T_TSD.Idepth + 1; - Last_Id : constant Natural := New_T_TSD.Idepth + Id : Natural := New_T_TSD.Idepth + 1; + Last_Id : constant Natural := New_T_TSD.Idepth + New_T_TSD.Num_Interfaces; + begin loop if New_T_TSD.Tags_Table (Id) = Interface_T then @@ -720,6 +1002,7 @@ package body Ada.Tags is procedure Set_Access_Level (T : Tag; Value : Natural) is begin + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); TSD (T).Access_Level := Value; end Set_Access_Level; @@ -730,9 +1013,14 @@ package body Ada.Tags is procedure Set_Entry_Index (T : Tag; Position : Positive; - Value : Positive) is + Value : Positive) + is + Index : constant Integer := Position - Default_Prim_Op_Count; + begin - TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count) := Value; + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); + pragma Assert (Index > 0); + SSD (T).SSD_Table (Index).Index := Value; end Set_Entry_Index; ----------------------- @@ -741,6 +1029,8 @@ package body Ada.Tags is procedure Set_Expanded_Name (T : Tag; Value : System.Address) is begin + pragma Assert + (Check_Signature (T, Must_Be_Primary_Or_Interface)); TSD (T).Expanded_Name := To_Cstring_Ptr (Value); end Set_Expanded_Name; @@ -750,9 +1040,41 @@ package body Ada.Tags is procedure Set_External_Tag (T : Tag; Value : System.Address) is begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); TSD (T).External_Tag := To_Cstring_Ptr (Value); end Set_External_Tag; + ---------------------- + -- Set_Num_Prim_Ops -- + ---------------------- + + procedure Set_Num_Prim_Ops (T : Tag; Value : Natural) is + begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); + + if Is_Primary_DT (T) then + TSD (T).Num_Prim_Ops := Value; + else + OSD (Interface_Tag (T)).Num_Prim_Ops := Value; + end if; + end Set_Num_Prim_Ops; + + ---------------------- + -- Set_Offset_Index -- + ---------------------- + + procedure Set_Offset_Index + (T : Interface_Tag; + Position : Positive; + Value : Positive) + is + Index : constant Integer := Position - Default_Prim_Op_Count; + begin + pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT)); + pragma Assert (Index > 0); + OSD (T).OSD_Table (Index) := Value; + end Set_Offset_Index; + ----------------------- -- Set_Offset_To_Top -- ----------------------- @@ -766,9 +1088,22 @@ package body Ada.Tags is - DT_Typeinfo_Ptr_Size - DT_Offset_To_Top_Size); begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); Offset_To_Top_Ptr.all := Value; end Set_Offset_To_Top; + ------------- + -- Set_OSD -- + ------------- + + procedure Set_OSD (T : Interface_Tag; Value : System.Address) is + OSD_Ptr : Addr_Ptr; + begin + pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT)); + OSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + OSD_Ptr.all := Value; + end Set_OSD; + ------------------------- -- Set_Prim_Op_Address -- ------------------------- @@ -776,8 +1111,11 @@ package body Ada.Tags is procedure Set_Prim_Op_Address (T : Tag; Position : Positive; - Value : System.Address) is + Value : System.Address) + is begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); + pragma Assert (Check_Index (T, Position)); T.Prims_Ptr (Position) := Value; end Set_Prim_Op_Address; @@ -788,9 +1126,13 @@ package body Ada.Tags is procedure Set_Prim_Op_Kind (T : Tag; Position : Positive; - Value : Prim_Op_Kind) is + Value : Prim_Op_Kind) + is + Index : constant Integer := Position - Default_Prim_Op_Count; begin - TSD (T).POK_Table (Position - Default_Prim_Op_Count) := Value; + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); + pragma Assert (Index > 0); + SSD (T).SSD_Table (Index).Kind := Value; end Set_Prim_Op_Kind; ------------------- @@ -799,6 +1141,7 @@ package body Ada.Tags is procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is begin + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); TSD (T).RC_Offset := Value; end Set_RC_Offset; @@ -808,20 +1151,41 @@ package body Ada.Tags is procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is begin + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); TSD (T).Remotely_Callable := Value; end Set_Remotely_Callable; ------------- + -- Set_SSD -- + ------------- + + procedure Set_SSD (T : Tag; Value : System.Address) is + begin + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); + TSD (T).SSD_Ptr := Value; + end Set_SSD; + + ------------- -- Set_TSD -- ------------- procedure Set_TSD (T : Tag; Value : System.Address) is - TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD_Ptr : Addr_Ptr; begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); TSD_Ptr.all := Value; end Set_TSD; + --------- + -- SSD -- + --------- + + function SSD (T : Tag) return Select_Specific_Data_Ptr is + begin + return To_Select_Specific_Data_Ptr (TSD (T).SSD_Ptr); + end SSD; + ------------------ -- Typeinfo_Ptr -- ------------------ diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 34d7d63..46e6c20 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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 -- @@ -53,31 +53,38 @@ package Ada.Tags is function Internal_Tag (External : String) return Tag; - function Descendant_Tag (External : String; Ancestor : Tag) return Tag; + function Descendant_Tag + (External : String; + Ancestor : Tag) return Tag; + pragma Ada_05 (Descendant_Tag); function Is_Descendant_At_Same_Level (Descendant : Tag; Ancestor : Tag) return Boolean; + pragma Ada_05 (Is_Descendant_At_Same_Level); function Parent_Tag (T : Tag) return Tag; + pragma Ada_05 (Parent_Tag); Tag_Error : exception; private + -- The following subprogram specifications are placed here instead of + -- the package body to see them from the frontend through rtsfind. --------------------------------------------------------------- -- Abstract Procedural Interface For The GNAT Dispatch Table -- --------------------------------------------------------------- -- GNAT's Dispatch Table format is customizable in order to match the - -- format used in another language. GNAT supports programs that use - -- two different dispatch table formats at the same time: the native - -- format that supports Ada 95 tagged types and which is described in - -- Ada.Tags, and a foreign format for types that are imported from some - -- other language (typically C++) which is described in Interfaces.CPP. - -- The runtime information kept for each tagged type is separated into - -- two objects: the Dispatch Table and the Type Specific Data record. - -- These two objects are allocated statically using the constants: + -- format used in another language. GNAT supports programs that use two + -- different dispatch table formats at the same time: the native format + -- that supports Ada 95 tagged types and which is described in Ada.Tags, + -- and a foreign format for types that are imported from some other + -- language (typically C++) which is described in Interfaces.CPP. The + -- runtime information kept for each tagged type is separated into two + -- objects: the Dispatch Table and the Type Specific Data record. These + -- two objects are allocated statically using the constants: -- DT Size = DT_Prologue_Size + Nb_Prim * DT_Entry_Size -- TSD Size = TSD_Prologue_Size + (1 + Idepth) * TSD_Entry_Size @@ -85,9 +92,9 @@ private -- where Nb_prim is the number of primitive operations of the given -- type and Idepth its inheritance depth. - -- The compiler generates calls to the following SET routines to - -- initialize those structures and uses the GET functions to - -- retreive the information when needed + -- In order to set or retrieve information from the Dispatch Table or + -- the Type Specific Data record, GNAT generates calls to Set_XXX or + -- Get_XXX routines, where XXX is the name of the field of interest. type Dispatch_Table; type Tag is access all Dispatch_Table; @@ -95,6 +102,19 @@ private No_Tag : constant Tag := null; + type Object_Specific_Data (Nb_Prim : Positive); + type Object_Specific_Data_Ptr is access all Object_Specific_Data; + -- Information associated with the secondary dispatch table of tagged-type + -- objects implementing abstract interfaces. + + type Select_Specific_Data (Nb_Prim : Positive); + type Select_Specific_Data_Ptr is access all Select_Specific_Data; + -- A table used to store the primitive operation kind and entry index of + -- primitive subprograms of a type that implements a limited interface. + -- The Select Specific Data table resides in the Type Specific Data of a + -- type. This construct is used in the handling of dispatching triggers + -- in select statements. + type Type_Specific_Data; type Type_Specific_Data_Ptr is access all Type_Specific_Data; @@ -109,17 +129,16 @@ private POK_Protected_Function, POK_Protected_Procedure, POK_Task_Entry, + POK_Task_Function, POK_Task_Procedure); - -- 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 efficien, indexing is performed by - -- subtracting this constant value from the provided position in the - -- auxiliary tables. - -- This value is mirrored from Exp_Disp.ads. - - Default_Prim_Op_Count : constant Positive := 14; + 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). package SSE renames System.Storage_Elements; @@ -127,9 +146,7 @@ private -- Given the tag of an object and the tag associated to a type, return -- true if Obj is in Typ'Class. - function IW_Membership - (This : System.Address; - T : Tag) return Boolean; + function IW_Membership (This : System.Address; T : Tag) return Boolean; -- Ada 2005 (AI-251): General routine that checks if a given object -- implements a tagged type. Its common usage is to check if Obj is in -- Iface'Class, but it is also used to check if a class-wide interface @@ -147,22 +164,27 @@ private -- Given the tag associated with a type, returns the accessibility level -- of the type. - function Get_Entry_Index - (T : Tag; - Position : Positive) return Positive; + function Get_Entry_Index (T : Tag; Position : Positive) return Positive; -- Return a primitive operation's entry index (if entry) given a dispatch -- table T and a position of a primitive operation in T. function Get_External_Tag (T : Tag) return System.Address; -- Retrieve the address of a null terminated string containing - -- the external name + -- the external name. + + function Get_Offset_Index + (T : Interface_Tag; + Position : Positive) return Positive; + -- Given a pointer to a secondary dispatch table (T) and a position of an + -- 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_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) + -- in it (used for dispatching calls). function Get_Prim_Op_Kind (T : Tag; @@ -182,10 +204,7 @@ private function Get_Remotely_Callable (T : Tag) return Boolean; -- Return the value previously set by Set_Remotely_Callable - procedure Inherit_DT - (Old_T : Tag; - New_T : Tag; - Entry_Count : Natural); + procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural); -- Entry point used to initialize the DT of a type knowing the tag -- of the direct ancestor and the number of primitive ops that are -- inherited (Entry_Count). @@ -193,21 +212,23 @@ private procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag); -- Initialize the TSD of a type knowing the tag of the direct ancestor + function OSD (T : Interface_Tag) return Object_Specific_Data_Ptr; + -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table, + -- retrieve the address of the record containing the Objet Specific + -- Data table. + function Parent_Size (Obj : System.Address; T : Tag) return SSE.Storage_Count; - -- Computes the size the ancestor part of a tagged extension object - -- whose address is 'obj' by calling the indirectly _size function of - -- the ancestor. The ancestor is the parent of the type represented by - -- tag T. This function assumes that _size is always in slot 1 of - -- the dispatch table. + -- Computes the size the ancestor part of a tagged extension object whose + -- address is 'obj' by calling indirectly the ancestor _size function. The + -- ancestor is the parent of the type represented by tag T. This function + -- assumes that _size is always in slot one of the dispatch table. pragma Export (Ada, Parent_Size, "ada__tags__parent_size"); -- This procedure is used in s-finimp and is thus exported manually - procedure Register_Interface_Tag - (T : Tag; - Interface_T : Tag); + procedure Register_Interface_Tag (T : Tag; Interface_T : Tag); -- Ada 2005 (AI-251): Used to initialize the table of interfaces -- implemented by a type. Required to give support to IW_Membership. @@ -215,13 +236,21 @@ private -- 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); + procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive); -- Set the entry index of a primitive operation in T's TSD table indexed -- by Position. + procedure Set_Num_Prim_Ops (T : Tag; Value : Natural); + -- Set the number of primitive operations in the dispatch table of T. This + -- is used for debugging purposes. + + procedure Set_Offset_Index + (T : Interface_Tag; + Position : Positive; + Value : Positive); + -- Set the offset value of a primitive operation in a secondary dispatch + -- table denoted by T, indexed by Position. + procedure Set_Offset_To_Top (T : Tag; Value : System.Storage_Elements.Storage_Offset); @@ -230,6 +259,10 @@ private -- is always 0; in secondary dispatch tables this is the offset to the base -- of the enclosing type. + procedure Set_OSD (T : Interface_Tag; Value : System.Address); + -- 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_Prim_Op_Address (T : Tag; Position : Positive; @@ -245,6 +278,10 @@ private -- Set the kind of a primitive operation in T's TSD table indexed by -- Position. + 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. + procedure Set_TSD (T : Tag; Value : System.Address); -- Given a pointer T to a dispatch Table, stores the address of the record -- containing the Type Specific Data generated by GNAT. @@ -269,15 +306,24 @@ private -- Set to true if the type has been declared in a context described -- in E.4 (18). + function SSD (T : Tag) return Select_Specific_Data_Ptr; + -- Given a pointer T to a dispatch Table, retrieves the address of the + -- record containing the Select Specific Data in T's TSD. + function TSD (T : Tag) return Type_Specific_Data_Ptr; - -- Given a pointer T to a dispatch Table, retreives the address of the - -- record containing the Type Specific Data generated by GNAT + -- Given a pointer T to a dispatch Table, retrieves the address of the + -- record containing the Type Specific Data generated by GNAT. DT_Prologue_Size : constant SSE.Storage_Count := SSE.Storage_Count - (2 * (Standard'Address_Size / System.Storage_Unit)); + (3 * (Standard'Address_Size / System.Storage_Unit)); -- Size of the first part of the dispatch table + DT_Signature_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (Standard'Address_Size / System.Storage_Unit); + -- Size of the Signature field of the dispatch table + DT_Offset_To_Top_Size : constant SSE.Storage_Count := SSE.Storage_Count (Standard'Address_Size / System.Storage_Unit); @@ -295,7 +341,7 @@ private TSD_Prologue_Size : constant SSE.Storage_Count := SSE.Storage_Count - (8 * (Standard'Address_Size / System.Storage_Unit)); + (10 * (Standard'Address_Size / System.Storage_Unit)); -- Size of the first part of the type specific data TSD_Entry_Size : constant SSE.Storage_Count := @@ -308,22 +354,57 @@ private -- of this type are declared with a dummy size of 1, the actual size -- depending on the number of primitive operations. - -- Unchecked Conversions for Tag and TSD + 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; + type Tag_Ptr is access Tag; + + type Signature_Values is + array (1 .. DT_Signature_Size) of Signature_Kind; + -- Type used to see the signature as a sequence of Signature_Kind values + + function To_Addr_Ptr is + new Unchecked_Conversion (System.Address, Addr_Ptr); function To_Type_Specific_Data_Ptr is new Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); function To_Address is - new Unchecked_Conversion (Type_Specific_Data_Ptr, System.Address); + new Unchecked_Conversion (Interface_Tag, System.Address); function To_Address is new Unchecked_Conversion (Tag, System.Address); - type Addr_Ptr is access System.Address; - type Tag_Ptr is access Tag; + function To_Address is + new Unchecked_Conversion (Type_Specific_Data_Ptr, System.Address); - function To_Addr_Ptr is - new Unchecked_Conversion (System.Address, Addr_Ptr); + function To_Object_Specific_Data_Ptr is + new Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); + + function To_Select_Specific_Data_Ptr is + new Unchecked_Conversion (System.Address, Select_Specific_Data_Ptr); + + function To_Signature_Values is + new Unchecked_Conversion (System.Storage_Elements.Storage_Offset, + Signature_Values); function To_Tag_Ptr is new Unchecked_Conversion (System.Address, Tag_Ptr); @@ -334,21 +415,32 @@ private pragma Inline_Always (CW_Membership); pragma Inline_Always (IW_Membership); pragma Inline_Always (Get_Access_Level); + pragma Inline_Always (Get_Entry_Index); + pragma Inline_Always (Get_Offset_Index); pragma Inline_Always (Get_Prim_Op_Address); + pragma Inline_Always (Get_Prim_Op_Kind); pragma Inline_Always (Get_RC_Offset); pragma Inline_Always (Get_Remotely_Callable); pragma Inline_Always (Inherit_DT); pragma Inline_Always (Inherit_TSD); + pragma Inline_Always (OSD); pragma Inline_Always (Register_Interface_Tag); pragma Inline_Always (Register_Tag); pragma Inline_Always (Set_Access_Level); + pragma Inline_Always (Set_Entry_Index); pragma Inline_Always (Set_Expanded_Name); pragma Inline_Always (Set_External_Tag); + pragma Inline_Always (Set_Num_Prim_Ops); + pragma Inline_Always (Set_Offset_Index); pragma Inline_Always (Set_Offset_To_Top); 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_OSD); + pragma Inline_Always (Set_SSD); pragma Inline_Always (Set_TSD); + pragma Inline_Always (SSD); pragma Inline_Always (TSD); end Ada.Tags; diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index db44614..c126bd8 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -214,8 +214,10 @@ package body Einfo is -- Abstract_Interfaces Elist24 -- Abstract_Interface_Alias Node25 + -- Current_Use_Clause Node25 -- Overridden_Operation Node26 + -- Package_Instantiation Node26 -- Wrapped_Entity Node27 @@ -388,7 +390,7 @@ package body Einfo is -- Has_Recursive_Call Flag143 -- Is_Unsigned_Type Flag144 -- Strict_Alignment Flag145 - -- Elaborate_All_Desirable Flag146 + -- (unused) Flag146 -- Needs_Debug_Info Flag147 -- Suppress_Elaboration_Warnings Flag148 -- Is_Compilation_Unit Flag149 @@ -444,12 +446,13 @@ package body Einfo is -- Is_Local_Anonymous_Access Flag194 -- Is_Primitive_Wrapper Flag195 -- Was_Hidden Flag196 + -- Is_Limited_Interface Flag197 + -- Is_Protected_Interface Flag198 + -- Is_Synchronized_Interface Flag199 + -- Is_Task_Interface Flag200 + + -- Has_Anon_Block_Suffix Flag201 - -- (unused) Flag197 - -- (unused) Flag198 - -- (unused) Flag199 - -- (unused) Flag200 - -- (unused) Flag201 -- (unused) Flag202 -- (unused) Flag203 -- (unused) Flag204 @@ -698,6 +701,12 @@ package body Einfo is return Node22 (Id); end Corresponding_Remote_Type; + function Current_Use_Clause (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Package); + return Node25 (Id); + end Current_Use_Clause; + function Current_Value (Id : E) return N is begin pragma Assert (Ekind (Id) in Object_Kind); @@ -839,11 +848,6 @@ package body Einfo is return Node16 (Id); end DTC_Entity; - function Elaborate_All_Desirable (Id : E) return B is - begin - return Flag146 (Id); - end Elaborate_All_Desirable; - function Elaboration_Entity (Id : E) return E is begin pragma Assert @@ -1073,6 +1077,11 @@ package body Einfo is return Flag79 (Id); end Has_All_Calls_Remote; + function Has_Anon_Block_Suffix (Id : E) return B is + begin + return Flag201 (Id); + end Has_Anon_Block_Suffix; + function Has_Atomic_Components (Id : E) return B is begin return Flag86 (Implementation_Base_Type (Id)); @@ -1667,6 +1676,12 @@ package body Einfo is return Flag106 (Id); end Is_Limited_Composite; + function Is_Limited_Interface (Id : E) return B is + begin + pragma Assert (Is_Interface (Id)); + return Flag197 (Id); + end Is_Limited_Interface; + function Is_Limited_Record (Id : E) return B is begin return Flag25 (Id); @@ -1750,6 +1765,12 @@ package body Einfo is return Flag53 (Id); end Is_Private_Descendant; + function Is_Protected_Interface (Id : E) return B is + begin + pragma Assert (Is_Interface (Id)); + return Flag198 (Id); + end Is_Protected_Interface; + function Is_Public (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -1792,6 +1813,12 @@ package body Einfo is return Flag28 (Id); end Is_Statically_Allocated; + function Is_Synchronized_Interface (Id : E) return B is + begin + pragma Assert (Is_Interface (Id)); + return Flag199 (Id); + end Is_Synchronized_Interface; + function Is_Tag (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -1803,6 +1830,12 @@ package body Einfo is return Flag55 (Id); end Is_Tagged_Type; + function Is_Task_Interface (Id : E) return B is + begin + pragma Assert (Is_Interface (Id)); + return Flag200 (Id); + end Is_Task_Interface; + function Is_Thread_Body (Id : E) return B is begin return Flag77 (Id); @@ -2016,7 +2049,8 @@ package body Einfo is function Obsolescent_Warning (Id : E) return N is begin - pragma Assert (Is_Subprogram (Id)); + pragma Assert + (Is_Subprogram (Id) or else Is_Package_Or_Generic_Package (Id)); return Node24 (Id); end Obsolescent_Warning; @@ -2048,6 +2082,15 @@ package body Einfo is return Node26 (Id); end Overridden_Operation; + function Package_Instantiation (Id : E) return N is + begin + pragma Assert + (False + or else Ekind (Id) = E_Generic_Package + or else Ekind (Id) = E_Package); + return Node26 (Id); + end Package_Instantiation; + function Packed_Array_Type (Id : E) return E is begin pragma Assert (Is_Array_Type (Id)); @@ -2744,7 +2787,13 @@ package body Einfo is Set_Node22 (Id, V); end Set_Corresponding_Remote_Type; - procedure Set_Current_Value (Id : E; V : E) is + procedure Set_Current_Use_Clause (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Package); + Set_Node25 (Id, V); + end Set_Current_Use_Clause; + + procedure Set_Current_Value (Id : E; V : N) is begin pragma Assert (Ekind (Id) in Object_Kind or else Ekind (Id) = E_Void); Set_Node9 (Id, V); @@ -2888,11 +2937,6 @@ package body Einfo is Set_Node16 (Id, V); end Set_DTC_Entity; - procedure Set_Elaborate_All_Desirable (Id : E; V : B := True) is - begin - Set_Flag146 (Id, V); - end Set_Elaborate_All_Desirable; - procedure Set_Elaboration_Entity (Id : E; V : E) is begin pragma Assert @@ -3126,6 +3170,11 @@ package body Einfo is Set_Flag79 (Id, V); end Set_Has_All_Calls_Remote; + procedure Set_Has_Anon_Block_Suffix (Id : E; V : B := True) is + begin + Set_Flag201 (Id, V); + end Set_Has_Anon_Block_Suffix; + procedure Set_Has_Atomic_Components (Id : E; V : B := True) is begin pragma Assert (not Is_Type (Id) or else Base_Type (Id) = Id); @@ -3754,6 +3803,12 @@ package body Einfo is Set_Flag106 (Id, V); end Set_Is_Limited_Composite; + procedure Set_Is_Limited_Interface (Id : E; V : B := True) is + begin + pragma Assert (Is_Interface (Id)); + Set_Flag197 (Id, V); + end Set_Is_Limited_Interface; + procedure Set_Is_Limited_Record (Id : E; V : B := True) is begin Set_Flag25 (Id, V); @@ -3838,6 +3893,12 @@ package body Einfo is Set_Flag53 (Id, V); end Set_Is_Private_Descendant; + procedure Set_Is_Protected_Interface (Id : E; V : B := True) is + begin + pragma Assert (Is_Interface (Id)); + Set_Flag198 (Id, V); + end Set_Is_Protected_Interface; + procedure Set_Is_Public (Id : E; V : B := True) is begin pragma Assert (Nkind (Id) in N_Entity); @@ -3886,6 +3947,12 @@ package body Einfo is Set_Flag28 (Id, V); end Set_Is_Statically_Allocated; + procedure Set_Is_Synchronized_Interface (Id : E; V : B := True) is + begin + pragma Assert (Is_Interface (Id)); + Set_Flag199 (Id, V); + end Set_Is_Synchronized_Interface; + procedure Set_Is_Tag (Id : E; V : B := True) is begin pragma Assert (Nkind (Id) in N_Entity); @@ -3902,6 +3969,12 @@ package body Einfo is Set_Flag77 (Id, V); end Set_Is_Thread_Body; + procedure Set_Is_Task_Interface (Id : E; V : B := True) is + begin + pragma Assert (Is_Interface (Id)); + Set_Flag200 (Id, V); + end Set_Is_Task_Interface; + procedure Set_Is_True_Constant (Id : E; V : B := True) is begin Set_Flag163 (Id, V); @@ -4108,7 +4181,8 @@ package body Einfo is procedure Set_Obsolescent_Warning (Id : E; V : N) is begin - pragma Assert (Is_Subprogram (Id)); + pragma Assert + (Is_Subprogram (Id) or else Is_Package_Or_Generic_Package (Id)); Set_Node24 (Id, V); end Set_Obsolescent_Warning; @@ -4140,6 +4214,15 @@ package body Einfo is Set_Node26 (Id, V); end Set_Overridden_Operation; + procedure Set_Package_Instantiation (Id : E; V : N) is + begin + pragma Assert + (Ekind (Id) = E_Void + or else Ekind (Id) = E_Generic_Package + or else Ekind (Id) = E_Package); + Set_Node26 (Id, V); + end Set_Package_Instantiation; + procedure Set_Packed_Array_Type (Id : E; V : E) is begin pragma Assert (Is_Array_Type (Id)); @@ -5693,17 +5776,17 @@ package body Einfo is end if; end Is_Limited_Type; - ---------------- - -- Is_Package -- - ---------------- + ----------------------------------- + -- Is_Package_Or_Generic_Package -- + ----------------------------------- - function Is_Package (Id : E) return B is + function Is_Package_Or_Generic_Package (Id : E) return B is begin return Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package; - end Is_Package; + end Is_Package_Or_Generic_Package; -------------------------- -- Is_Protected_Private -- @@ -6466,7 +6549,6 @@ package body Einfo is W ("Delay_Subprogram_Descriptors", Flag50 (Id)); W ("Depends_On_Private", Flag14 (Id)); W ("Discard_Names", Flag88 (Id)); - W ("Elaborate_All_Desirable", Flag146 (Id)); W ("Elaboration_Entity_Required", Flag174 (Id)); W ("Entry_Accepted", Flag152 (Id)); W ("Finalize_Storage_Only", Flag158 (Id)); @@ -6475,6 +6557,7 @@ package body Einfo is W ("Has_Aliased_Components", Flag135 (Id)); W ("Has_Alignment_Clause", Flag46 (Id)); W ("Has_All_Calls_Remote", Flag79 (Id)); + W ("Has_Anon_Block_Suffix", Flag201 (Id)); W ("Has_Atomic_Components", Flag86 (Id)); W ("Has_Biased_Representation", Flag139 (Id)); W ("Has_Completion", Flag26 (Id)); @@ -6580,6 +6663,7 @@ package body Einfo is W ("Is_Known_Valid", Flag37 (Id)); W ("Is_Known_Valid", Flag170 (Id)); W ("Is_Limited_Composite", Flag106 (Id)); + W ("Is_Limited_Interface", Flag197 (Id)); W ("Is_Limited_Record", Flag25 (Id)); W ("Is_Machine_Code_Subprogram", Flag137 (Id)); W ("Is_Non_Static_Subtype", Flag109 (Id)); @@ -6595,6 +6679,7 @@ package body Einfo is W ("Is_Primitive_Wrapper", Flag195 (Id)); W ("Is_Private_Composite", Flag107 (Id)); W ("Is_Private_Descendant", Flag53 (Id)); + W ("Is_Protected_Interface", Flag198 (Id)); W ("Is_Public", Flag10 (Id)); W ("Is_Pure", Flag44 (Id)); W ("Is_Pure_Unit_Access_Type", Flag189 (Id)); @@ -6602,9 +6687,11 @@ package body Einfo is W ("Is_Remote_Types", Flag61 (Id)); W ("Is_Renaming_Of_Object", Flag112 (Id)); W ("Is_Shared_Passive", Flag60 (Id)); + W ("Is_Synchronized_Interface", Flag199 (Id)); W ("Is_Statically_Allocated", Flag28 (Id)); W ("Is_Tag", Flag78 (Id)); W ("Is_Tagged_Type", Flag55 (Id)); + W ("Is_Task_Interface", Flag200 (Id)); W ("Is_Thread_Body", Flag77 (Id)); W ("Is_True_Constant", Flag163 (Id)); W ("Is_Unchecked_Union", Flag117 (Id)); @@ -7526,7 +7613,9 @@ package body Einfo is E_Record_Subtype_With_Private => Write_Str ("Abstract_Interfaces"); - when Subprogram_Kind => + when Subprogram_Kind | + E_Package | + E_Generic_Package => Write_Str ("Obsolescent_Warning"); when Task_Kind => @@ -7548,6 +7637,9 @@ package body Einfo is E_Function => Write_Str ("Abstract_Interface_Alias"); + when E_Package => + Write_Str ("Current_Use_Clause"); + when others => Write_Str ("Field25??"); end case; @@ -7560,6 +7652,10 @@ package body Einfo is procedure Write_Field26_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Generic_Package | + E_Package => + Write_Str ("Package_Instantiation"); + when E_Procedure | E_Function => Write_Str ("Overridden_Operation"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 189a9ec..fa1e584 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -594,6 +594,11 @@ package Einfo is -- created at the same time as the discriminal, and used to replace -- occurrences of the discriminant within the type declaration. +-- Current_Use_Clause (Node25) +-- Present in packages. Indicates the use clause currently in scope +-- that makes the package use_visible. Used to detect redundant use +-- clauses for the same package. + -- Current_Value (Node9) -- Present in E_Variable, E_Out_Parameter and E_In_Out_Parameter -- entities. Set non-Empty if the (constant) current value of the @@ -801,13 +806,6 @@ package Einfo is -- Present in all entities. Contains a value of the enumeration type -- Entity_Kind declared in a subsequent section in this spec. --- Elaborate_All_Desirable (Flag146) --- Present in package and subprogram entities, and in generic package --- and subprogram entities. Set if internal analysis of a client that --- with's this unit determines that Elaborate_All is desirable, i.e. --- that there is a possibility that Program_Error may be raised if --- Elaborate_All conditions cannot be met. - -- Elaboration_Entity (Node13) -- Present in generic and non-generic package and subprogram -- entities. This is a boolean entity associated with the unit that @@ -1230,6 +1228,11 @@ package Einfo is -- be RCI entities, so the flag Is_Remote_Call_Interface will always -- be set if this flag is set. +-- Has_Anon_Block_Suffix (Flag201) +-- Present in all entities. Set if the entity is nested within one or +-- more anonymous blocks and the Chars field contains a name with an +-- anonymous block suffix (see Exp_Dbug for furthert details). + -- Has_Atomic_Components (Flag86) [implementation base type only] -- Present in all types and objects. Set only for an array type or -- an array object if a valid pragma Atomic_Components applies to the @@ -2106,6 +2109,10 @@ package Einfo is -- do not become visible until the immediate scope of the composite -- type itself (RM 7.3.1 (5)). +-- Is_Limited_Interface (Flag197) +-- Present in types that are interfaces. True if interface is declared +-- limited, or is derived from limited interfaces. + -- Is_Limited_Record (Flag25) -- Present in all entities. Set to true for record (sub)types if the -- record is declared to be limited. Note that this flag is not set @@ -2159,8 +2166,8 @@ package Einfo is -- including generic formal parameters. -- Is_Obsolescent (Flag153) --- Present in all entities. Set only for subprograms when a valid pragma --- Obsolescent applies to the subprogram. +-- Present in all entities. Set only for packages and subprograms to +-- which a valid pragma Obsolescent applies. -- Is_Optional_Parameter (Flag134) -- Present in parameter entities. Set if the parameter is specified as @@ -2175,7 +2182,7 @@ package Einfo is -- Present in subprograms. Set if the subprogram is a primitive -- operation of a derived type, that overrides an inherited operation. --- Is_Package (synthesized) +-- Is_Package_Or_Generic_Package (synthesized) -- Applies to all entities. True for packages and generic packages. -- False for all other entities. @@ -2264,6 +2271,10 @@ package Einfo is -- Applies to all entities, true for private types and subtypes, -- as well as for record with private types as subtypes +-- Is_Protected_Interface (Flag198) +-- Present in types that are interfaces. True if interface is declared +-- protected, or is derived from protected interfaces. + -- Is_Protected_Type (synthesized) -- Applies to all entities, true for protected types and subtypes @@ -2358,6 +2369,10 @@ package Einfo is -- or a string slice type, or an array type with one dimension and a -- component type that is a character type. +-- Is_Synchronized_Interface (Flag199) +-- Present_types that are interfaces. True is interface is declared +-- synchronized, or is derived from synchronized interfaces. + -- Is_Tag (Flag78) -- Present in E_Component. For regular tagged type this flag is set on -- the tag component (whose name is Name_uTag) and for CPP_Class tagged @@ -2367,6 +2382,10 @@ package Einfo is -- Is_Tagged_Type (Flag55) -- Present in all entities, true for an entity for a tagged type. +-- Is_Task_Interface (Flag200) +-- Present in types that are interfaces. True is interface is declared +-- as such, or if it is derived from task interfaces. + -- Is_Task_Record_Type (synthesized) -- Applies to all entities, true if Is_Concurrent_Record_Type -- Corresponding_Concurrent_Type is a task type. @@ -2732,8 +2751,8 @@ package Einfo is -- formals as a value of type Pos. -- Obsolescent_Warning (Node24) --- Present in subprogram entities. Set non-empty only if the pragma --- Obsolescent had a string argument, in which case it records the +-- Present in package and subprogram entities. Set non-empty only if the +-- pragma Obsolescent had a string argument, in which case it records the -- contents of the corresponding string literal node. -- Original_Access_Type (Node21) @@ -2778,6 +2797,18 @@ package Einfo is -- Present in subprograms. For overriding operations, points to the -- user-defined parent subprogram that is being overridden. +-- Package_Instantiation (Node26) +-- Present in packages and generic packages. When present, this field +-- references an N_Package_Instantiation node associated with an +-- instantiated package. In the case where the referenced node has +-- been rewritten to an N_Package_Specification, the instantiation +-- node is available from the Original_Node field of the package spec +-- node. This is currently not guaranteed to be set in all cases, but +-- when set, the field is used in Get_Package_Instantiation_Node as +-- one of the means of obtaining the instantiation node. Eventually +-- it should be set in all cases, including package entities associated +-- with formal packages. ??? + -- Packed_Array_Type (Node23) -- Present in array types and subtypes, including the string literal -- subtype case, if the corresponding type is packed (either bit packed @@ -4009,6 +4040,7 @@ package Einfo is -- Can_Never_Be_Null (Flag38) -- Checks_May_Be_Suppressed (Flag31) -- Debug_Info_Off (Flag166) + -- Has_Anon_Block_Suffix (Flag201) -- Has_Controlled_Component (Flag43) (base type only) -- Has_Convention_Pragma (Flag119) -- Has_Delayed_Freeze (Flag18) @@ -4123,6 +4155,10 @@ package Einfo is -- Is_Frozen (Flag4) -- Is_Generic_Actual_Type (Flag94) -- Is_Generic_Type (Flag13) + -- Is_Limited_Interface (Flag197) + -- Is_Protected_Interface (Flag198) + -- Is_Synchronized_Interface (Flag199) + -- Is_Task_Interface (Flag200) -- Is_Non_Static_Subtype (Flag109) -- Is_Packed (Flag51) (base type only) -- Is_Private_Composite (Flag107) @@ -4428,7 +4464,6 @@ package Einfo is -- Delay_Cleanups (Flag114) -- Delay_Subprogram_Descriptors (Flag50) -- Discard_Names (Flag88) - -- Elaborate_All_Desirable (Flag146) -- Has_Completion (Flag26) -- Has_Controlling_Result (Flag98) -- Has_Master_Entity (Flag21) @@ -4596,10 +4631,12 @@ package Einfo is -- Generic_Renamings (Elist23) (for an instance) -- Inner_Instances (Elist23) (generic case only) -- Limited_View (Node23) (non-generic, not instance) + -- Obsolescent_Warning (Node24) + -- Current_Use_Clause (Node25) + -- Package_Instantiation (Node26) -- Delay_Subprogram_Descriptors (Flag50) -- Body_Needed_For_SAL (Flag40) -- Discard_Names (Flag88) - -- Elaborate_All_Desirable (Flag146) -- Elaboration_Entity_Required (Flag174) -- From_With_Type (Flag159) -- Has_All_Calls_Remote (Flag79) @@ -4678,7 +4715,6 @@ package Einfo is -- Delay_Cleanups (Flag114) -- Delay_Subprogram_Descriptors (Flag50) -- Discard_Names (Flag88) - -- Elaborate_All_Desirable (Flag146) -- Has_Completion (Flag26) -- Has_Master_Entity (Flag21) -- Has_Nested_Block_With_Handler (Flag101) @@ -5145,6 +5181,7 @@ package Einfo is function Corresponding_Equality (Id : E) return E; function Corresponding_Record_Type (Id : E) return E; function Corresponding_Remote_Type (Id : E) return E; + function Current_Use_Clause (Id : E) return E; function Current_Value (Id : E) return N; function Debug_Info_Off (Id : E) return B; function Debug_Renaming_Link (Id : E) return E; @@ -5168,7 +5205,6 @@ package Einfo is function Discriminant_Constraint (Id : E) return L; function Discriminant_Default_Value (Id : E) return N; function Discriminant_Number (Id : E) return U; - function Elaborate_All_Desirable (Id : E) return B; function Elaboration_Entity (Id : E) return E; function Elaboration_Entity_Required (Id : E) return B; function Enclosing_Scope (Id : E) return E; @@ -5208,6 +5244,7 @@ package Einfo is function Has_Aliased_Components (Id : E) return B; function Has_Alignment_Clause (Id : E) return B; function Has_All_Calls_Remote (Id : E) return B; + function Has_Anon_Block_Suffix (Id : E) return B; function Has_Atomic_Components (Id : E) return B; function Has_Biased_Representation (Id : E) return B; function Has_Completion (Id : E) return B; @@ -5314,6 +5351,7 @@ package Einfo is function Is_Known_Non_Null (Id : E) return B; function Is_Known_Valid (Id : E) return B; function Is_Limited_Composite (Id : E) return B; + function Is_Limited_Interface (Id : E) return B; function Is_Machine_Code_Subprogram (Id : E) return B; function Is_Non_Static_Subtype (Id : E) return B; function Is_Null_Init_Proc (Id : E) return B; @@ -5328,6 +5366,7 @@ package Einfo is function Is_Private_Composite (Id : E) return B; function Is_Private_Descendant (Id : E) return B; + function Is_Protected_Interface (Id : E) return B; function Is_Public (Id : E) return B; function Is_Pure (Id : E) return B; function Is_Pure_Unit_Access_Type (Id : E) return B; @@ -5336,8 +5375,10 @@ package Einfo is function Is_Renaming_Of_Object (Id : E) return B; function Is_Shared_Passive (Id : E) return B; function Is_Statically_Allocated (Id : E) return B; + function Is_Synchronized_Interface (Id : E) return B; function Is_Tag (Id : E) return B; function Is_Tagged_Type (Id : E) return B; + function Is_Task_Interface (Id : E) return B; function Is_Thread_Body (Id : E) return B; function Is_True_Constant (Id : E) return B; function Is_Unchecked_Union (Id : E) return B; @@ -5379,6 +5420,7 @@ package Einfo is function Original_Array_Type (Id : E) return E; function Original_Record_Component (Id : E) return E; function Overridden_Operation (Id : E) return E; + function Package_Instantiation (Id : E) return N; function Packed_Array_Type (Id : E) return E; function Parent_Subtype (Id : E) return E; function Primitive_Operations (Id : E) return L; @@ -5519,7 +5561,7 @@ package Einfo is function Is_Dynamic_Scope (Id : E) return B; function Is_Indefinite_Subtype (Id : E) return B; function Is_Limited_Type (Id : E) return B; - function Is_Package (Id : E) return B; + function Is_Package_Or_Generic_Package (Id : E) return B; function Is_Protected_Private (Id : E) return B; function Is_Protected_Record_Type (Id : E) return B; function Is_Return_By_Reference_Type (Id : E) return B; @@ -5638,6 +5680,7 @@ package Einfo is procedure Set_Corresponding_Equality (Id : E; V : E); procedure Set_Corresponding_Record_Type (Id : E; V : E); procedure Set_Corresponding_Remote_Type (Id : E; V : E); + procedure Set_Current_Use_Clause (Id : E; V : E); procedure Set_Current_Value (Id : E; V : N); procedure Set_Debug_Info_Off (Id : E; V : B := True); procedure Set_Debug_Renaming_Link (Id : E; V : E); @@ -5661,7 +5704,6 @@ package Einfo is procedure Set_Discriminant_Constraint (Id : E; V : L); procedure Set_Discriminant_Default_Value (Id : E; V : N); procedure Set_Discriminant_Number (Id : E; V : U); - procedure Set_Elaborate_All_Desirable (Id : E; V : B := True); procedure Set_Elaboration_Entity (Id : E; V : E); procedure Set_Elaboration_Entity_Required (Id : E; V : B := True); procedure Set_Enclosing_Scope (Id : E; V : E); @@ -5700,6 +5742,7 @@ package Einfo is procedure Set_Has_Aliased_Components (Id : E; V : B := True); procedure Set_Has_Alignment_Clause (Id : E; V : B := True); procedure Set_Has_All_Calls_Remote (Id : E; V : B := True); + procedure Set_Has_Anon_Block_Suffix (Id : E; V : B := True); procedure Set_Has_Atomic_Components (Id : E; V : B := True); procedure Set_Has_Biased_Representation (Id : E; V : B := True); procedure Set_Has_Completion (Id : E; V : B := True); @@ -5810,6 +5853,7 @@ package Einfo is procedure Set_Is_Known_Non_Null (Id : E; V : B := True); procedure Set_Is_Known_Valid (Id : E; V : B := True); procedure Set_Is_Limited_Composite (Id : E; V : B := True); + procedure Set_Is_Limited_Interface (Id : E; V : B := True); procedure Set_Is_Limited_Record (Id : E; V : B := True); procedure Set_Is_Machine_Code_Subprogram (Id : E; V : B := True); procedure Set_Is_Non_Static_Subtype (Id : E; V : B := True); @@ -5823,9 +5867,9 @@ package Einfo is procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True); procedure Set_Is_Preelaborated (Id : E; V : B := True); procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True); - procedure Set_Is_Private_Composite (Id : E; V : B := True); procedure Set_Is_Private_Descendant (Id : E; V : B := True); + procedure Set_Is_Protected_Interface (Id : E; V : B := True); procedure Set_Is_Public (Id : E; V : B := True); procedure Set_Is_Pure (Id : E; V : B := True); procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True); @@ -5834,8 +5878,10 @@ package Einfo is procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True); procedure Set_Is_Shared_Passive (Id : E; V : B := True); procedure Set_Is_Statically_Allocated (Id : E; V : B := True); + procedure Set_Is_Synchronized_Interface (Id : E; V : B := True); procedure Set_Is_Tag (Id : E; V : B := True); procedure Set_Is_Tagged_Type (Id : E; V : B := True); + procedure Set_Is_Task_Interface (Id : E; V : B := True); procedure Set_Is_Thread_Body (Id : E; V : B := True); procedure Set_Is_True_Constant (Id : E; V : B := True); procedure Set_Is_Unchecked_Union (Id : E; V : B := True); @@ -5876,6 +5922,7 @@ package Einfo is procedure Set_Original_Array_Type (Id : E; V : E); procedure Set_Original_Record_Component (Id : E; V : E); procedure Set_Overridden_Operation (Id : E; V : E); + procedure Set_Package_Instantiation (Id : E; V : N); procedure Set_Packed_Array_Type (Id : E; V : E); procedure Set_Parent_Subtype (Id : E; V : E); procedure Set_Primitive_Operations (Id : E; V : L); @@ -6185,6 +6232,7 @@ package Einfo is pragma Inline (Corresponding_Equality); pragma Inline (Corresponding_Record_Type); pragma Inline (Corresponding_Remote_Type); + pragma Inline (Current_Use_Clause); pragma Inline (Current_Value); pragma Inline (Debug_Info_Off); pragma Inline (Debug_Renaming_Link); @@ -6208,7 +6256,6 @@ package Einfo is pragma Inline (Discriminant_Constraint); pragma Inline (Discriminant_Default_Value); pragma Inline (Discriminant_Number); - pragma Inline (Elaborate_All_Desirable); pragma Inline (Elaboration_Entity); pragma Inline (Elaboration_Entity_Required); pragma Inline (Enclosing_Scope); @@ -6247,6 +6294,7 @@ package Einfo is pragma Inline (Has_Aliased_Components); pragma Inline (Has_Alignment_Clause); pragma Inline (Has_All_Calls_Remote); + pragma Inline (Has_Anon_Block_Suffix); pragma Inline (Has_Atomic_Components); pragma Inline (Has_Biased_Representation); pragma Inline (Has_Completion); @@ -6377,6 +6425,7 @@ package Einfo is pragma Inline (Is_Known_Non_Null); pragma Inline (Is_Known_Valid); pragma Inline (Is_Limited_Composite); + pragma Inline (Is_Limited_Interface); pragma Inline (Is_Limited_Record); pragma Inline (Is_Machine_Code_Subprogram); pragma Inline (Is_Modular_Integer_Type); @@ -6400,6 +6449,7 @@ package Einfo is pragma Inline (Is_Private_Composite); pragma Inline (Is_Private_Descendant); pragma Inline (Is_Private_Type); + pragma Inline (Is_Protected_Interface); pragma Inline (Is_Protected_Type); pragma Inline (Is_Public); pragma Inline (Is_Pure); @@ -6414,8 +6464,10 @@ package Einfo is pragma Inline (Is_Signed_Integer_Type); pragma Inline (Is_Statically_Allocated); pragma Inline (Is_Subprogram); + pragma Inline (Is_Synchronized_Interface); pragma Inline (Is_Tag); pragma Inline (Is_Tagged_Type); + pragma Inline (Is_Task_Interface); pragma Inline (Is_Thread_Body); pragma Inline (Is_True_Constant); pragma Inline (Is_Task_Type); @@ -6459,6 +6511,7 @@ package Einfo is pragma Inline (Original_Array_Type); pragma Inline (Original_Record_Component); pragma Inline (Overridden_Operation); + pragma Inline (Package_Instantiation); pragma Inline (Packed_Array_Type); pragma Inline (Parameter_Mode); pragma Inline (Parent_Subtype); @@ -6552,6 +6605,7 @@ package Einfo is pragma Inline (Set_Corresponding_Equality); pragma Inline (Set_Corresponding_Record_Type); pragma Inline (Set_Corresponding_Remote_Type); + pragma Inline (Set_Current_Use_Clause); pragma Inline (Set_Current_Value); pragma Inline (Set_Debug_Info_Off); pragma Inline (Set_Debug_Renaming_Link); @@ -6574,7 +6628,6 @@ package Einfo is pragma Inline (Set_Discriminant_Constraint); pragma Inline (Set_Discriminant_Default_Value); pragma Inline (Set_Discriminant_Number); - pragma Inline (Set_Elaborate_All_Desirable); pragma Inline (Set_Elaboration_Entity); pragma Inline (Set_Elaboration_Entity_Required); pragma Inline (Set_Enclosing_Scope); @@ -6611,6 +6664,7 @@ package Einfo is pragma Inline (Set_Has_Aliased_Components); pragma Inline (Set_Has_Alignment_Clause); pragma Inline (Set_Has_All_Calls_Remote); + pragma Inline (Set_Has_Anon_Block_Suffix); pragma Inline (Set_Has_Atomic_Components); pragma Inline (Set_Has_Biased_Representation); pragma Inline (Set_Has_Completion); @@ -6720,6 +6774,7 @@ package Einfo is pragma Inline (Set_Is_Known_Non_Null); pragma Inline (Set_Is_Known_Valid); pragma Inline (Set_Is_Limited_Composite); + pragma Inline (Set_Is_Limited_Interface); pragma Inline (Set_Is_Limited_Record); pragma Inline (Set_Is_Machine_Code_Subprogram); pragma Inline (Set_Is_Non_Static_Subtype); @@ -6736,6 +6791,7 @@ package Einfo is pragma Inline (Set_Is_Private_Composite); pragma Inline (Set_Is_Private_Descendant); + pragma Inline (Set_Is_Protected_Interface); pragma Inline (Set_Is_Public); pragma Inline (Set_Is_Pure); pragma Inline (Set_Is_Pure_Unit_Access_Type); @@ -6744,8 +6800,10 @@ package Einfo is pragma Inline (Set_Is_Renaming_Of_Object); pragma Inline (Set_Is_Shared_Passive); pragma Inline (Set_Is_Statically_Allocated); + pragma Inline (Set_Is_Synchronized_Interface); pragma Inline (Set_Is_Tag); pragma Inline (Set_Is_Tagged_Type); + pragma Inline (Set_Is_Task_Interface); pragma Inline (Set_Is_Thread_Body); pragma Inline (Set_Is_True_Constant); pragma Inline (Set_Is_Unchecked_Union); @@ -6786,6 +6844,7 @@ package Einfo is pragma Inline (Set_Original_Array_Type); pragma Inline (Set_Original_Record_Component); pragma Inline (Set_Overridden_Operation); + pragma Inline (Set_Package_Instantiation); pragma Inline (Set_Packed_Array_Type); pragma Inline (Set_Parent_Subtype); pragma Inline (Set_Primitive_Operations); @@ -6849,7 +6908,7 @@ package Einfo is -- things here which are small, but not of the canonical attribute -- access/set format that can be handled by xeinfo. - pragma Inline (Is_Package); + pragma Inline (Is_Package_Or_Generic_Package); pragma Inline (Is_Wrapper_Package); pragma Inline (Known_RM_Size); pragma Inline (Known_Static_Component_Bit_Offset); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 4b82921..3feb7d3 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-2005, 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- -- @@ -79,13 +79,6 @@ package body Exp_Ch3 is -- used for attachment of any actions required in its construction. -- It also supplies the source location used for the procedure. - procedure Build_Class_Wide_Master (T : Entity_Id); - -- for access to class-wide limited types we must build a task master - -- because some subsequent extension may add a task component. To avoid - -- bringing in the tasking run-time whenever an access-to-class-wide - -- limited type is used, we use the soft-link mechanism and add a level - -- of indirection to calls to routines that manipulate Master_Ids. - function Build_Discriminant_Formals (Rec_Id : Entity_Id; Use_Dl : Boolean) return List_Id; @@ -651,6 +644,7 @@ package body Exp_Ch3 is M_Id : Entity_Id; Decl : Node_Id; P : Node_Id; + Par : Node_Id; begin -- Nothing to do if there is no task hierarchy @@ -659,6 +653,16 @@ package body Exp_Ch3 is return; end if; + -- Find declaration that created the access type: either a + -- type declaration, or an object declaration with an + -- access definition, in which case the type is anonymous. + + if Is_Itype (T) then + P := Associated_Node_For_Itype (T); + else + P := Parent (T); + end if; + -- Nothing to do if we already built a master entity for this scope if not Has_Master_Entity (Scope (T)) then @@ -677,24 +681,24 @@ package body Exp_Ch3 is Make_Explicit_Dereference (Loc, New_Reference_To (RTE (RE_Current_Master), Loc))); - P := Parent (T); Insert_Before (P, Decl); Analyze (Decl); Set_Has_Master_Entity (Scope (T)); -- Now mark the containing scope as a task master - while Nkind (P) /= N_Compilation_Unit loop - P := Parent (P); + Par := P; + while Nkind (Par) /= N_Compilation_Unit loop + Par := Parent (Par); -- If we fall off the top, we are at the outer level, and the -- environment task is our effective master, so nothing to mark. - if Nkind (P) = N_Task_Body - or else Nkind (P) = N_Block_Statement - or else Nkind (P) = N_Subprogram_Body + if Nkind (Par) = N_Task_Body + or else Nkind (Par) = N_Block_Statement + or else Nkind (Par) = N_Subprogram_Body then - Set_Is_Task_Master (P, True); + Set_Is_Task_Master (Par, True); exit; end if; end loop; @@ -711,7 +715,7 @@ package body Exp_Ch3 is Defining_Identifier => M_Id, Subtype_Mark => New_Reference_To (Standard_Integer, Loc), Name => Make_Identifier (Loc, Name_uMaster)); - Insert_Before (Parent (T), Decl); + Insert_Before (P, Decl); Analyze (Decl); Set_Master_Id (T, M_Id); @@ -1758,10 +1762,18 @@ package body Exp_Ch3 is Aux_N : Node_Id; begin - if not Is_Interface (Typ) - and then Etype (Typ) /= Typ - then - Init_Secondary_Tags_Internal (Etype (Typ)); + if not Is_Interface (Typ) then + + -- Climb to the ancestor (if any) handling private types + + if Present (Full_View (Etype (Typ))) then + if Full_View (Etype (Typ)) /= Typ then + Init_Secondary_Tags_Internal (Full_View (Etype (Typ))); + end if; + + elsif Etype (Typ) /= Typ then + Init_Secondary_Tags_Internal (Etype (Typ)); + end if; end if; if Present (Abstract_Interfaces (Typ)) @@ -1824,7 +1836,14 @@ package body Exp_Ch3 is -- interfaces. ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); - Init_Secondary_Tags_Internal (Typ); + + -- Handle private types + + if Present (Full_View (Typ)) then + Init_Secondary_Tags_Internal (Full_View (Typ)); + else + Init_Secondary_Tags_Internal (Typ); + end if; end Init_Secondary_Tags; -- Start of processing for Build_Init_Procedure @@ -2478,6 +2497,13 @@ package body Exp_Ch3 is return False; end if; + -- If it is a type derived from a type with unknown discriminants, + -- we cannot build an initialization procedure for it. + + if Has_Unknown_Discriminants (Rec_Id) then + return False; + end if; + -- Otherwise we need to generate an initialization procedure if -- Is_CPP_Class is False and at least one of the following applies: @@ -4547,34 +4573,52 @@ package body Exp_Ch3 is ADT : Elist_Id := Access_Disp_Table (Def_Id); procedure Add_Secondary_Tables (Typ : Entity_Id); - -- Comment required ??? + -- Internal subprogram, recursively climb to the ancestors -------------------------- -- Add_Secondary_Tables -- -------------------------- procedure Add_Secondary_Tables (Typ : Entity_Id) is - E : Entity_Id; - Result : List_Id; + E : Entity_Id; + Iface : Elmt_Id; + Result : List_Id; + Suffix_Index : Int; begin - if Etype (Typ) /= Typ then + -- Climb to the ancestor (if any) handling private types + + if Present (Full_View (Etype (Typ))) then + if Full_View (Etype (Typ)) /= Typ then + Add_Secondary_Tables (Full_View (Etype (Typ))); + end if; + + elsif Etype (Typ) /= Typ then Add_Secondary_Tables (Etype (Typ)); end if; if Present (Abstract_Interfaces (Typ)) - and then not Is_Empty_Elmt_List - (Abstract_Interfaces (Typ)) + and then + not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) then + Iface := First_Elmt (Abstract_Interfaces (Typ)); + Suffix_Index := 0; + E := First_Entity (Typ); while Present (E) loop if Is_Tag (E) and then Chars (E) /= Name_uTag then - Make_Abstract_Interface_DT - (AI_Tag => E, + Make_Secondary_DT + (Typ => Def_Id, + Ancestor_Typ => Typ, + Suffix_Index => Suffix_Index, + Iface => Node (Iface), + AI_Tag => E, Acc_Disp_Tables => ADT, Result => Result); Append_Freeze_Actions (Def_Id, Result); + Suffix_Index := Suffix_Index + 1; + Next_Elmt (Iface); end if; Next_Entity (E); @@ -4585,7 +4629,14 @@ package body Exp_Ch3 is -- Start of processing to build secondary dispatch tables begin - Add_Secondary_Tables (Def_Id); + -- Handle private types + + if Present (Full_View (Def_Id)) then + Add_Secondary_Tables (Full_View (Def_Id)); + else + Add_Secondary_Tables (Def_Id); + end if; + Set_Access_Disp_Table (Def_Id, ADT); Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); end; @@ -4699,9 +4750,14 @@ package body Exp_Ch3 is and then not Is_Interface (Def_Id) and then not Is_Abstract (Def_Id) and then not Is_Controlled (Def_Id) - and then Implements_Limited_Interface (Def_Id) + and then + Implements_Interface + (Typ => Def_Id, + Kind => Any_Limited_Interface, + Check_Parent => True) then - Append_Freeze_Actions (Def_Id, Make_Disp_Select_Tables (Def_Id)); + Append_Freeze_Actions (Def_Id, + Make_Select_Specific_Data_Table (Def_Id)); end if; end if; end Freeze_Record_Type; @@ -5897,6 +5953,7 @@ package body Exp_Ch3 is -- disp_asynchronous_select -- disp_conditional_select -- disp_get_prim_op_kind + -- disp_get_task_id -- disp_timed_select -- for limited interfaces and tagged types that implement a limited -- interface. @@ -5908,50 +5965,36 @@ package body Exp_Ch3 is or else (not Is_Abstract (Tag_Typ) and then not Is_Controlled (Tag_Typ) - and then Implements_Limited_Interface (Tag_Typ))) + and then + Implements_Interface + (Typ => Tag_Typ, + Kind => Any_Limited_Interface, + Check_Parent => True))) then - if Is_Interface (Tag_Typ) then - Append_To (Res, - Make_Abstract_Subprogram_Declaration (Loc, - Specification => - Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); - - Append_To (Res, - Make_Abstract_Subprogram_Declaration (Loc, - Specification => - Make_Disp_Conditional_Select_Spec (Tag_Typ))); - - Append_To (Res, - Make_Abstract_Subprogram_Declaration (Loc, - Specification => - Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); - - Append_To (Res, - Make_Abstract_Subprogram_Declaration (Loc, - Specification => - Make_Disp_Timed_Select_Spec (Tag_Typ))); + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); - else - Append_To (Res, - Make_Subprogram_Declaration (Loc, - Specification => - Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Conditional_Select_Spec (Tag_Typ))); - Append_To (Res, - Make_Subprogram_Declaration (Loc, - Specification => - Make_Disp_Conditional_Select_Spec (Tag_Typ))); + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); - Append_To (Res, - Make_Subprogram_Declaration (Loc, - Specification => - Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Get_Task_Id_Spec (Tag_Typ))); - Append_To (Res, - Make_Subprogram_Declaration (Loc, - Specification => - Make_Disp_Timed_Select_Spec (Tag_Typ))); - end if; + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Timed_Select_Spec (Tag_Typ))); end if; -- Specs for finalization actions that may be required in case a @@ -6310,26 +6353,33 @@ package body Exp_Ch3 is end if; -- Generate the bodies for the following primitive operations: + -- disp_asynchronous_select -- disp_conditional_select -- disp_get_prim_op_kind + -- disp_get_task_id -- disp_timed_select - -- for tagged types that implement a limited interface. + + -- for limited interfaces and tagged types that implement a limited + -- interface. The interface versions will have null bodies. if Ada_Version >= Ada_05 - and then not Is_Interface (Tag_Typ) - and then not Is_Abstract (Tag_Typ) - and then not Is_Controlled (Tag_Typ) - and then Implements_Limited_Interface (Tag_Typ) + and then + ((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ)) + or else + (not Is_Abstract (Tag_Typ) + and then not Is_Controlled (Tag_Typ) + and then + Implements_Interface + (Typ => Tag_Typ, + Kind => Any_Limited_Interface, + Check_Parent => True))) then - Append_To (Res, - Make_Disp_Asynchronous_Select_Body (Tag_Typ)); - Append_To (Res, - Make_Disp_Conditional_Select_Body (Tag_Typ)); - Append_To (Res, - Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ)); - Append_To (Res, - Make_Disp_Timed_Select_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ)); end if; if not Is_Limited_Type (Tag_Typ) then @@ -6337,23 +6387,23 @@ package body Exp_Ch3 is -- Body for equality if Eq_Needed then + Decl := + Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Eq_Name, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), - Decl := Predef_Spec_Or_Body (Loc, - Tag_Typ => Tag_Typ, - Name => Eq_Name, - Profile => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_X), - Parameter_Type => New_Reference_To (Tag_Typ, Loc)), - - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Y), - Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), - Ret_Type => Standard_Boolean, - For_Body => True); + Ret_Type => Standard_Boolean, + For_Body => True); declare Def : constant Node_Id := Parent (Tag_Typ); @@ -6403,19 +6453,20 @@ package body Exp_Ch3 is -- Body for dispatching assignment - Decl := Predef_Spec_Or_Body (Loc, - Tag_Typ => Tag_Typ, - Name => Name_uAssign, - Profile => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), - Out_Present => True, - Parameter_Type => New_Reference_To (Tag_Typ, Loc)), - - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), - Parameter_Type => New_Reference_To (Tag_Typ, Loc))), - For_Body => True); + Decl := + Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Name_uAssign, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), + Out_Present => True, + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + For_Body => True); Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, New_List ( @@ -6541,6 +6592,7 @@ package body Exp_Ch3 is return not (Is_Limited_Type (Typ) and then not Has_Inheritable_Stream_Attribute) + and then not Has_Unknown_Discriminants (Typ) and then RTE_Available (RE_Tag) and then RTE_Available (RE_Root_Stream_Type) and then not Restriction_Active (No_Dispatch) diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index f4d6097..ce2b799 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -40,12 +40,21 @@ package Exp_Ch3 is procedure Expand_Previous_Access_Type (Def_Id : Entity_Id); -- For a full type declaration that contains tasks, or that is a task, -- check whether there exists an access type whose designated type is an - -- incomplete declarations for the current composite type. If so, build - -- the master for that access type, now that it is known to denote an - -- object with tasks. + -- incomplete declarations for the current composite type. If so, build the + -- master for that access type, now that it is known to denote an object + -- with tasks. procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id); - -- Add a field _parent in the extension part of the record. + -- Add a field _parent in the extension part of the record + + procedure Build_Class_Wide_Master (T : Entity_Id); + -- For access to class-wide limited types we must build a task master + -- because some subsequent extension may add a task component. To avoid + -- bringing in the tasking run-time whenever an access-to-class-wide + -- limited type is used, we use the soft-link mechanism and add a level of + -- indirection to calls to routines that manipulate Master_Ids. This must + -- also be used for anonymous access types whose designated type is a task + -- or synchronized interface. procedure Build_Discr_Checking_Funcs (N : Node_Id); -- Builds function which checks whether the component name is consistent @@ -66,10 +75,10 @@ package Exp_Ch3 is -- constructed tree, and Typ is the type of the entity (the initialization -- procedure of the base type is the procedure that actually gets called). -- In_Init_Proc has to be set to True when the call is itself in an init - -- proc in order to enable the use of discriminals. Enclos_type is the - -- type of the init proc and it is used for various expansion cases - -- including the case where Typ is a task type which is a array component, - -- the indices of the enclosing type are used to build the string that + -- proc in order to enable the use of discriminals. Enclos_type is the type + -- of the init proc and it is used for various expansion cases including + -- the case where Typ is a task type which is a array component, the + -- indices of the enclosing type are used to build the string that -- identifies each task at runtime. -- -- Discr_Map is used to replace discriminants by their discriminals in @@ -84,33 +93,32 @@ package Exp_Ch3 is function Freeze_Type (N : Node_Id) return Boolean; -- This function executes the freezing actions associated with the given - -- freeze type node N and returns True if the node is to be deleted. - -- We delete the node if it is present just for front end purpose and - -- we don't want Gigi to see the node. This function can't delete the - -- node itself since it would confuse any remaining processing of the - -- freeze node. + -- freeze type node N and returns True if the node is to be deleted. We + -- delete the node if it is present just for front end purpose and we don't + -- want Gigi to see the node. This function can't delete the node itself + -- since it would confuse any remaining processing of the freeze node. function Needs_Simple_Initialization (T : Entity_Id) return Boolean; -- Certain types need initialization even though there is no specific - -- initialization routine. In this category are access types (which - -- need initializing to null), packed array types whose implementation - -- is a modular type, and all scalar types if Normalize_Scalars is set, - -- as well as private types whose underlying type is present and meets - -- any of these criteria. Finally, descendants of String and Wide_String - -- also need initialization in Initialize/Normalize_Scalars mode. + -- initialization routine. In this category are access types (which need + -- initializing to null), packed array types whose implementation is a + -- modular type, and all scalar types if Normalize_Scalars is set, as well + -- as private types whose underlying type is present and meets any of these + -- criteria. Finally, descendants of String and Wide_String also need + -- initialization in Initialize/Normalize_Scalars mode. function Get_Simple_Init_Val (T : Entity_Id; Loc : Source_Ptr; 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. + -- 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. end Exp_Ch3; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 884d549..76dde0e 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -99,10 +99,11 @@ package body Exp_Ch6 is -- we have an infinite recursion. procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id); - -- For each actual of an in-out parameter which is a numeric conversion - -- of the form T(A), where A denotes a variable, we insert the declaration: + -- For each actual of an in-out or out parameter which is a numeric + -- (view) conversion of the form T (A), where A denotes a variable, + -- we insert the declaration: -- - -- Temp : T := T (A); + -- Temp : T[ := T (A)]; -- -- prior to the call. Then we replace the actual with a reference to Temp, -- and append the assignment: @@ -1464,6 +1465,48 @@ package body Exp_Ch6 is end if; end if; + -- Ada 2005 (AI-345): We have a procedure call as a triggering + -- alternative in an asynchronous select or as an entry call in + -- a conditional or timed select. Check whether the procedure call + -- is a renaming of an entry and rewrite it as an entry call. + + if Ada_Version >= Ada_05 + and then Nkind (N) = N_Procedure_Call_Statement + and then + ((Nkind (Parent (N)) = N_Triggering_Alternative + and then Triggering_Statement (Parent (N)) = N) + or else + (Nkind (Parent (N)) = N_Entry_Call_Alternative + and then Entry_Call_Statement (Parent (N)) = N)) + then + declare + Ren_Decl : Node_Id; + Ren_Root : Entity_Id := Subp; + + begin + -- This may be a chain of renamings, find the root + + if Present (Alias (Ren_Root)) then + Ren_Root := Alias (Ren_Root); + end if; + + if Present (Original_Node (Parent (Parent (Ren_Root)))) then + Ren_Decl := Original_Node (Parent (Parent (Ren_Root))); + + if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then + Rewrite (N, + Make_Entry_Call_Statement (Loc, + Name => + New_Copy_Tree (Name (Ren_Decl)), + Parameter_Associations => + New_Copy_List_Tree (Parameter_Associations (N)))); + + return; + end if; + end if; + end; + end if; + -- First step, compute extra actuals, corresponding to any -- Extra_Formals present. Note that we do not access Extra_Formals -- directly, instead we simply note the presence of the extra @@ -1558,13 +1601,29 @@ package body Exp_Ch6 is Act_Prev := Expression (Act_Prev); end loop; - Add_Extra_Actual ( - Make_Attribute_Reference (Sloc (Prev), - Prefix => - Duplicate_Subexpr_No_Checks - (Act_Prev, Name_Req => True), - Attribute_Name => Name_Constrained), - Extra_Constrained (Formal)); + -- If the expression is a conversion of a dereference, + -- this is internally generated code that manipulates + -- addresses, e.g. when building interface tables. No + -- check should occur in this case, and the discriminated + -- object is not directly a hand. + + if not Comes_From_Source (Actual) + and then Nkind (Actual) = N_Unchecked_Type_Conversion + and then Nkind (Act_Prev) = N_Explicit_Dereference + then + Add_Extra_Actual + (New_Occurrence_Of (Standard_False, Loc), + Extra_Constrained (Formal)); + + else + Add_Extra_Actual + (Make_Attribute_Reference (Sloc (Prev), + Prefix => + Duplicate_Subexpr_No_Checks + (Act_Prev, Name_Req => True), + Attribute_Name => Name_Constrained), + Extra_Constrained (Formal)); + end if; end; end if; end if; @@ -1591,10 +1650,10 @@ package body Exp_Ch6 is pragma Assert (Present (Parm_Ent)); if Present (Extra_Accessibility (Parm_Ent)) then - Add_Extra_Actual ( - New_Occurrence_Of - (Extra_Accessibility (Parm_Ent), Loc), - Extra_Accessibility (Formal)); + Add_Extra_Actual + (New_Occurrence_Of + (Extra_Accessibility (Parm_Ent), Loc), + Extra_Accessibility (Formal)); -- If the actual access parameter does not have an -- associated extra formal providing its scope level, @@ -1602,10 +1661,10 @@ package body Exp_Ch6 is -- accessibility. else - Add_Extra_Actual ( - Make_Integer_Literal (Loc, - Intval => Scope_Depth (Standard_Standard)), - Extra_Accessibility (Formal)); + Add_Extra_Actual + (Make_Integer_Literal (Loc, + Intval => Scope_Depth (Standard_Standard)), + Extra_Accessibility (Formal)); end if; end; @@ -1613,10 +1672,10 @@ package body Exp_Ch6 is -- level of the actual's access type. else - Add_Extra_Actual ( - Make_Integer_Literal (Loc, - Intval => Type_Access_Level (Etype (Prev_Orig))), - Extra_Accessibility (Formal)); + Add_Extra_Actual + (Make_Integer_Literal (Loc, + Intval => Type_Access_Level (Etype (Prev_Orig))), + Extra_Accessibility (Formal)); end if; else @@ -3092,6 +3151,12 @@ package body Exp_Ch6 is -- If the call is the right side of an assignment or the expression in -- an object declaration, we don't need to create a temp as the left -- side will already trigger stack checking if necessary. + -- + -- If the call is a component in an extension aggregate, it will be + -- expanded into assignments as well, so no temporary is needed. This + -- also solves the problem of functions returning types with unknown + -- discriminants, where it is not possible to declare an object of the + -- type altogether. --------------------------- -- Returned_By_Reference -- @@ -3143,6 +3208,9 @@ package body Exp_Ch6 is and then Expression (Parent (N)) = N and then Nkind (Parent (Parent (N))) = N_Aggregate and then Rhs_Of_Assign_Or_Decl (Parent (Parent (N)))) + or else + (Nkind (Parent (N)) = N_Extension_Aggregate + and then Is_Private_Type (Etype (Typ))) then return True; else @@ -4052,8 +4120,8 @@ package body Exp_Ch6 is ----------------------- procedure Freeze_Subprogram (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - E : constant Entity_Id := Entity (N); + Loc : constant Source_Ptr := Sloc (N); + E : constant Entity_Id := Entity (N); procedure Check_Overriding_Inherited_Interfaces (E : Entity_Id); -- (Ada 2005): Check if the primitive E covers some interface already @@ -4068,6 +4136,10 @@ package body Exp_Ch6 is -- immediate ancestor associated with the interface; otherwise Prim and -- Ancestor_Iface_Prim have the same info. + procedure Register_Predefined_DT_Entry (Prim : Entity_Id); + -- (Ada 2005): Register a predefined primitive in all the secondary + -- dispatch tables of its primitive type. + ------------------------------------------- -- Check_Overriding_Inherited_Interfaces -- ------------------------------------------- @@ -4090,11 +4162,18 @@ package body Exp_Ch6 is -- Get the entity associated with this primitive operation Typ := Scope (DTC_Entity (E)); - while Etype (Typ) /= Typ loop + loop + exit when Etype (Typ) = Typ + or else (Present (Full_View (Etype (Typ))) + and then Full_View (Etype (Typ)) = Typ); - -- Climb to the immediate ancestor + -- Climb to the immediate ancestor handling private types - Typ := Etype (Typ); + if Present (Full_View (Etype (Typ))) then + Typ := Full_View (Etype (Typ)); + else + Typ := Etype (Typ); + end if; if Present (Abstract_Interfaces (Typ)) then @@ -4192,35 +4271,40 @@ package body Exp_Ch6 is if not Present (Ancestor_Iface_Prim) then Prim_Typ := Scope (DTC_Entity (Alias (Prim))); Iface_Typ := Scope (DTC_Entity (Abstract_Interface_Alias (Prim))); - Iface_Tag := Find_Interface_Tag - (T => Prim_Typ, - Iface => Iface_Typ); -- Generate the code of the thunk only when this primitive -- operation is associated with a secondary dispatch table. - if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then - Thunk_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('T')); - New_Thunk := - Expand_Interface_Thunk - (N => Prim, - Thunk_Alias => Alias (Prim), - Thunk_Id => Thunk_Id, - Thunk_Tag => Iface_Tag); - - Insert_After (N, New_Thunk); - - Iface_DT_Ptr := - Find_Interface_ADT - (T => Prim_Typ, - Iface => Iface_Typ); - - Insert_After (New_Thunk, - Fill_Secondary_DT_Entry (Sloc (Prim), - Prim => Prim, - Iface_DT_Ptr => Iface_DT_Ptr, - Thunk_Id => Thunk_Id)); + if Is_Interface (Iface_Typ) then + Iface_Tag := Find_Interface_Tag + (T => Prim_Typ, + Iface => Iface_Typ); + + if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then + Thunk_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + + New_Thunk := + Expand_Interface_Thunk + (N => Prim, + Thunk_Alias => Alias (Prim), + Thunk_Id => Thunk_Id, + Thunk_Tag => Iface_Tag); + + Insert_After (N, New_Thunk); + + Iface_DT_Ptr := + Find_Interface_ADT + (T => Prim_Typ, + Iface => Iface_Typ); + + Insert_After (New_Thunk, + Fill_Secondary_DT_Entry (Sloc (Prim), + Prim => Prim, + Iface_DT_Ptr => Iface_DT_Ptr, + Thunk_Id => Thunk_Id)); + end if; end if; else @@ -4243,8 +4327,9 @@ package body Exp_Ch6 is -- type T is new I with ... if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then - Thunk_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('T')); + Thunk_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); if Present (Alias (Prim)) then Prim_Op := Alias (Prim); @@ -4275,6 +4360,70 @@ package body Exp_Ch6 is end if; end Register_Interface_DT_Entry; + ---------------------------------- + -- Register_Predefined_DT_Entry -- + ---------------------------------- + + procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is + Iface_DT_Ptr : Elmt_Id; + Iface_Tag : Entity_Id; + Iface_Typ : Elmt_Id; + New_Thunk : Entity_Id; + Prim_Typ : Entity_Id; + Thunk_Id : Entity_Id; + + begin + Prim_Typ := Scope (DTC_Entity (Prim)); + + if not Present (Access_Disp_Table (Prim_Typ)) + or else not Present (Abstract_Interfaces (Prim_Typ)) + then + return; + end if; + + -- Skip the first acces-to-dispatch-table pointer since it leads + -- to the primary dispatch table. We are only concerned with the + -- secondary dispatch table pointers. Note that the access-to- + -- dispatch-table pointer corresponds to the first implemented + -- interface retrieved below. + + Iface_DT_Ptr := Next_Elmt (First_Elmt (Access_Disp_Table (Prim_Typ))); + Iface_Typ := First_Elmt (Abstract_Interfaces (Prim_Typ)); + while Present (Iface_DT_Ptr) and then Present (Iface_Typ) loop + Iface_Tag := Find_Interface_Tag (Prim_Typ, Node (Iface_Typ)); + pragma Assert (Present (Iface_Tag)); + + if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then + Thunk_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('T')); + + New_Thunk := + Expand_Interface_Thunk + (N => Prim, + Thunk_Alias => Prim, + Thunk_Id => Thunk_Id, + Thunk_Tag => Iface_Tag); + + Insert_After (N, New_Thunk); + Insert_After (New_Thunk, + Make_DT_Access_Action (Node (Iface_Typ), + Action => Set_Prim_Op_Address, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Node (Iface_DT_Ptr), Loc)), + + Make_Integer_Literal (Loc, DT_Position (Prim)), + + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Address)))); + end if; + + Next_Elmt (Iface_DT_Ptr); + Next_Elmt (Iface_Typ); + end loop; + end Register_Predefined_DT_Entry; + -- Start of processing for Freeze_Subprogram begin @@ -4297,19 +4446,38 @@ package body Exp_Ch6 is Fill_DT_Entry (Sloc (N), Prim => E)); else - -- Ada 2005 (AI-251): Check if this entry corresponds with - -- a subprogram that covers an abstract interface type. + declare + Typ : constant Entity_Id := Scope (DTC_Entity (E)); - if Present (Abstract_Interface_Alias (E)) then - Register_Interface_DT_Entry (E); + begin + -- There is no dispatch table associated with abstract + -- interface types; each type implementing interfaces + -- will fill the associated secondary DT entries. - -- Common case: Primitive subprogram + if not Is_Interface (Typ) + or else Present (Alias (E)) + then + -- Ada 2005 (AI-251): Check if this entry corresponds with + -- a subprogram that covers an abstract interface type. - else - Insert_After (N, - Fill_DT_Entry (Sloc (N), Prim => E)); - Check_Overriding_Inherited_Interfaces (E); - end if; + if Present (Abstract_Interface_Alias (E)) then + Register_Interface_DT_Entry (E); + + -- Common case: Primitive subprogram + + else + -- Generate thunks for all the predefined operations + + if Is_Predefined_Dispatching_Operation (E) then + Register_Predefined_DT_Entry (E); + end if; + + Insert_After (N, + Fill_DT_Entry (Sloc (N), Prim => E)); + Check_Overriding_Inherited_Interfaces (E); + end if; + end if; + end; end if; end if; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index f7d0119..b0bad8c 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1793,6 +1793,13 @@ package body Exp_Ch7 is return The_Parent; end if; + -- A raise statement can be wrapped. This will arise when the + -- expression in a raise_with_expression uses the secondary + -- stack, for example. + + when N_Raise_Statement => + return The_Parent; + -- If the expression is within the iteration scheme of a loop, -- we must create a declaration for it, followed by an assignment -- in order to have a usable statement to wrap. @@ -2728,13 +2735,27 @@ package body Exp_Ch7 is Utyp := Underlying_Type (Base_Type (Utyp)); Set_Assignment_OK (Cref); - -- Deal with non-tagged derivation of private views + -- Deal with non-tagged derivation of private views. If the parent is + -- now known to be protected, the finalization routine is the one + -- defined on the corresponding record of the ancestor (corresponding + -- records do not automatically inherit operations, but maybe they + -- should???) if Is_Untagged_Derivation (Typ) then - Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); + if Is_Protected_Type (Typ) then + Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); + else + Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); + end if; + Cref := Unchecked_Convert_To (Utyp, Cref); + + -- We need to set Assignment_OK to prevent problems with unchecked + -- conversions, where we do not want them to be converted back in the + -- case of untagged record derivation (see code in Make_*_Call + -- procedures for similar situations). + Set_Assignment_OK (Cref); - -- To prevent problems with UC see 1.156 RH ??? end if; -- If the underlying_type is a subtype, we are dealing with diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 6911d86..3943dc4 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -65,21 +65,33 @@ package body Exp_Ch9 is -- Select_Expansion_Utilities -- -------------------------------- + -- The following constant establishes the upper bound for the index of + -- an entry family. It is used to limit the allocated size of protected + -- types with defaulted discriminant of an integer type, when the bound + -- of some entry family depends on a discriminant. The limitation to + -- entry families of 128K should be reasonable in all cases, and is a + -- documented implementation restriction. It will be lifted when protected + -- entry families are re-implemented as a single ordered queue. + + Entry_Family_Bound : constant Int := 2**16; + -- The following package contains helper routines used in the expansion of -- dispatching asynchronous, conditional and timed selects. package Select_Expansion_Utilities is function Build_Abort_Block - (Loc : Source_Ptr; - Blk_Ent : Entity_Id; - Blk : Node_Id) return Node_Id; + (Loc : Source_Ptr; + Abr_Blk_Ent : Entity_Id; + Cln_Blk_Ent : Entity_Id; + Blk : Node_Id) return Node_Id; -- Generate: -- begin -- Blk -- exception -- when Abort_Signal => Abort_Undefer; -- end; - -- Blk_Ent is the name of the encapsulated block, Blk is the actual + -- Abr_Blk_Ent is the name of the generated block, Cln_Blk_Ent is + -- the name of the encapsulated cleanup block, Blk is the actual -- block node. function Build_B @@ -121,28 +133,23 @@ package body Exp_Ch9 is function Build_S (Loc : Source_Ptr; Decls : List_Id; + Obj : Entity_Id; Call_Ent : Entity_Id) return Entity_Id; -- Generate: - -- S : constant Integer := DT_Position (Call_Ent); - -- where Call_Ent is the entity of the dispatching call name. Append - -- the object declaration to the list and return the name of the - -- object. + -- S : constant Integer := + -- Ada.Tags.Get_Offset_Index ( + -- Unchecked_Convert_To (Ada.Tags.Interface_Tag, Obj), + -- DT_Position (Call_Ent)); + -- where Obj is the pointer to a secondary table, Call_Ent is the + -- entity of the dispatching call name. Append the object declaration + -- to the list and return its defining identifier. - function Build_Wrapping_Procedure - (Loc : Source_Ptr; - Nam : Character; - Decls : List_Id; - Stmts : List_Id) return Entity_Id; - -- Generate: - -- procedure <temp>Nam is - -- begin - -- Stmts - -- end <temp>Nam; - -- where Nam is the generated procedure name and Stmts are the - -- encapsulated statements. Append the procedure body to Decls. - -- Return the internally generated procedure name. end Select_Expansion_Utilities; + ----------------------------------------- + -- Body for Select_Expansion_Utilities -- + ----------------------------------------- + package body Select_Expansion_Utilities is ----------------------- @@ -150,15 +157,17 @@ package body Exp_Ch9 is ----------------------- function Build_Abort_Block - (Loc : Source_Ptr; - Blk_Ent : Entity_Id; - Blk : Node_Id) return Node_Id + (Loc : Source_Ptr; + Abr_Blk_Ent : Entity_Id; + Cln_Blk_Ent : Entity_Id; + Blk : Node_Id) return Node_Id is begin return Make_Block_Statement (Loc, - Declarations => - No_List, + Identifier => New_Reference_To (Abr_Blk_Ent, Loc), + + Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, @@ -166,7 +175,7 @@ package body Exp_Ch9 is New_List ( Make_Implicit_Label_Declaration (Loc, Defining_Identifier => - Blk_Ent, + Cln_Blk_Ent, Label_Construct => Blk), Blk), @@ -194,7 +203,8 @@ package body Exp_Ch9 is (Loc : Source_Ptr; Decls : List_Id) return Entity_Id is - B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); + B : constant Entity_Id := Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('B')); begin Append_To (Decls, @@ -217,7 +227,8 @@ package body Exp_Ch9 is (Loc : Source_Ptr; Decls : List_Id) return Entity_Id is - C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC); + C : constant Entity_Id := Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('C')); begin Append_To (Decls, @@ -262,52 +273,30 @@ package body Exp_Ch9 is function Build_S (Loc : Source_Ptr; Decls : List_Id; + Obj : Entity_Id; Call_Ent : Entity_Id) return Entity_Id is - S : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uS); + S : constant Entity_Id := Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); begin Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => S, Constant_Present => True, + Object_Definition => New_Reference_To (Standard_Integer, Loc), + Expression => - Make_Integer_Literal (Loc, - Intval => DT_Position (Call_Ent)))); + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Interface_Tag), Obj), + Make_Integer_Literal (Loc, DT_Position (Call_Ent)))))); return S; end Build_S; - - ------------------------------ - -- Build_Wrapping_Procedure -- - ------------------------------ - - function Build_Wrapping_Procedure - (Loc : Source_Ptr; - Nam : Character; - Decls : List_Id; - Stmts : List_Id) return Entity_Id - is - Proc_Nam : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name (Nam)); - begin - Append_To (Decls, - Make_Subprogram_Body (Loc, - Specification => - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Proc_Nam), - Declarations => - No_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => - New_Copy_List (Stmts)))); - - return Proc_Nam; - end Build_Wrapping_Procedure; end Select_Expansion_Utilities; package SEU renames Select_Expansion_Utilities; @@ -335,6 +324,18 @@ package body Exp_Ch9 is -- of the System.Address pointer passed to entry barrier functions -- and entry body procedures. + procedure Add_Formal_Renamings + (Spec : Node_Id; + Decls : List_Id; + Ent : Entity_Id; + Loc : Source_Ptr); + -- Create renaming declarations for the formals, inside the procedure + -- that implements an entry body. The renamings make the original names + -- of the formals accessible to gdb, and serve no other purpose. + -- Spec is the specification of the procedure being built. + -- Decls is the list of declarations to be enhanced. + -- Ent is the entity for the original entry body. + function Build_Accept_Body (Astat : Node_Id) return Node_Id; -- Transform accept statement into a block with added exception handler. -- Used both for simple accept statements and for accept alternatives in @@ -463,8 +464,9 @@ package body Exp_Ch9 is -- The object is a limited record and therefore a by_reference type. function Build_Selected_Name - (Prefix, Selector : Name_Id; - Append_Char : Character := ' ') return Name_Id; + (Prefix : Entity_Id; + Selector : Entity_Id; + Append_Char : Character := ' ') return Name_Id; -- Build a name in the form of Prefix__Selector, with an optional -- character appended. This is used for internal subprograms generated -- for operations of protected types, including barrier functions. @@ -572,7 +574,7 @@ package body Exp_Ch9 is Actuals : List_Id; Formals : List_Id; Decls : List_Id; - Stmts : List_Id) return Node_Id; + Stmts : List_Id) return Entity_Id; -- Set the components of the generated parameter block with the values of -- the actual parameters. Generate aliased temporaries to capture the -- values for types that are passed by copy. Otherwise generate a reference @@ -588,6 +590,7 @@ package body Exp_Ch9 is function Parameter_Block_Unpack (Loc : Source_Ptr; + P : Entity_Id; Actuals : List_Id; Formals : List_Id) return List_Id; -- Retrieve the values of the components from the parameter block and @@ -795,6 +798,7 @@ package body Exp_Ch9 is Pid : Entity_Id; Loc : Source_Ptr) is + Decl : Node_Id; Obj_Ptr : Node_Id; begin @@ -812,14 +816,16 @@ package body Exp_Ch9 is New_External_Name (Chars (Corresponding_Record_Type (Pid)), 'P')); - Prepend_To (Decls, + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uObject), Object_Definition => New_Reference_To (Obj_Ptr, Loc), Expression => Unchecked_Convert_To (Obj_Ptr, - Make_Identifier (Loc, Name_uO)))); + Make_Identifier (Loc, Name_uO))); + Set_Needs_Debug_Info (Defining_Identifier (Decl)); + Prepend_To (Decls, Decl); Prepend_To (Decls, Make_Full_Type_Declaration (Loc, @@ -829,6 +835,65 @@ package body Exp_Ch9 is New_Reference_To (Corresponding_Record_Type (Pid), Loc)))); end Add_Object_Pointer; + -------------------------- + -- Add_Formal_Renamings -- + -------------------------- + + procedure Add_Formal_Renamings + (Spec : Node_Id; + Decls : List_Id; + Ent : Entity_Id; + Loc : Source_Ptr) + is + Ptr : constant Entity_Id := + Defining_Identifier + (Next (First (Parameter_Specifications (Spec)))); + -- The name of the formal that holds the address of the parameter block + -- for the call. + + Comp : Entity_Id; + Decl : Node_Id; + Formal : Entity_Id; + New_F : Entity_Id; + + begin + Formal := First_Formal (Ent); + while Present (Formal) loop + Comp := Entry_Component (Formal); + New_F := + Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); + Set_Etype (New_F, Etype (Formal)); + Set_Scope (New_F, Ent); + Set_Needs_Debug_Info (New_F); -- That's the whole point. + + if Ekind (Formal) = E_In_Parameter then + Set_Ekind (New_F, E_Constant); + else + Set_Ekind (New_F, E_Variable); + Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); + end if; + + Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => New_F, + Subtype_Mark => New_Reference_To (Etype (Formal), Loc), + Name => + Make_Explicit_Dereference (Loc, + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Entry_Parameters_Type (Ent), + Make_Identifier (Loc, Chars (Ptr))), + Selector_Name => + New_Reference_To (Comp, Loc)))); + + Append (Decl, Decls); + Set_Renamed_Object (Formal, New_F); + Next_Formal (Formal); + end loop; + end Add_Formal_Renamings; + ------------------------------ -- Add_Private_Declarations -- ------------------------------ @@ -840,6 +905,7 @@ package body Exp_Ch9 is Loc : Source_Ptr) is Def : constant Node_Id := Protected_Definition (Parent (Typ)); + Decl : Node_Id; Body_Ent : constant Entity_Id := Corresponding_Body (Parent (Typ)); P : Node_Id; Pdef : Entity_Id; @@ -849,28 +915,30 @@ package body Exp_Ch9 is if Present (Private_Declarations (Def)) then P := First (Private_Declarations (Def)); - while Present (P) loop if Nkind (P) = N_Component_Declaration then Pdef := Defining_Identifier (P); - Prepend_To (Decls, + Decl := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Prival (Pdef), Subtype_Mark => New_Reference_To (Etype (Pdef), Loc), Name => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name), - Selector_Name => Make_Identifier (Loc, Chars (Pdef))))); + Selector_Name => Make_Identifier (Loc, Chars (Pdef)))); + Set_Needs_Debug_Info (Defining_Identifier (Decl)); + Prepend_To (Decls, Decl); end if; + Next (P); end loop; end if; - -- One more "prival" for the object itself, with the right protection - -- type. + -- One more "prival" for object itself, with the right protection type declare Protection_Type : RE_Id; + begin if Has_Attach_Handler (Typ) then if Restricted_Profile then @@ -906,14 +974,16 @@ package body Exp_Ch9 is Protection_Type := RE_Protection; end if; - Prepend_To (Decls, + Decl := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Object_Ref (Body_Ent), Subtype_Mark => New_Reference_To (RTE (Protection_Type), Loc), Name => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name), - Selector_Name => Make_Identifier (Loc, Name_uObject)))); + Selector_Name => Make_Identifier (Loc, Name_uObject))); + Set_Needs_Debug_Info (Defining_Identifier (Decl)); + Prepend_To (Decls, Decl); end; end Add_Private_Declarations; @@ -931,9 +1001,9 @@ package body Exp_Ch9 is begin -- At the end of the statement sequence, Complete_Rendezvous is called. - -- A label skipping the Complete_Rendezvous, and all other - -- accept processing, has already been added for the expansion - -- of requeue statements. + -- A label skipping the Complete_Rendezvous, and all other accept + -- processing, has already been added for the expansion of requeue + -- statements. Call := Build_Runtime_Call (Loc, RE_Complete_Rendezvous); Insert_Before (Last (Statements (Stats)), Call); @@ -1161,7 +1231,6 @@ package body Exp_Ch9 is E : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); - begin return Make_Function_Call (Loc, @@ -1247,7 +1316,8 @@ package body Exp_Ch9 is Component_List => Make_Component_List (Loc, Component_Items => Cdecls), - Tagged_Present => Ada_Version >= Ada_05, + Tagged_Present => + Ada_Version >= Ada_05 and then Is_Tagged_Type (Ctyp), Limited_Present => True)); end Build_Corresponding_Record; @@ -1269,11 +1339,10 @@ package body Exp_Ch9 is Typ : Entity_Id; begin - Ent := First_Entity (Concurrent_Type); - Eindx := 0; - -- Count number of non-family entries + Eindx := 0; + Ent := First_Entity (Concurrent_Type); while Present (Ent) loop if Ekind (Ent) = E_Entry then Eindx := Eindx + 1; @@ -1288,7 +1357,6 @@ package body Exp_Ch9 is Ent := First_Entity (Concurrent_Type); Comp := First (Component_List); - while Present (Ent) loop if Ekind (Ent) = E_Entry_Family then while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop @@ -1323,75 +1391,97 @@ package body Exp_Ch9 is is Actual : Entity_Id; Comp_Nam : Node_Id; - Comp_Rec : Node_Id; Comps : List_Id; Formal : Entity_Id; + Has_Comp : Boolean := False; + Rec_Nam : Node_Id; begin Actual := First (Actuals); Comps := New_List; Formal := Defining_Identifier (First (Formals)); + while Present (Actual) loop - -- Generate: - -- type Ann is access all <actual-type> + if not Is_Controlling_Actual (Actual) then - Comp_Nam := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + -- Generate: + -- type Ann is access all <actual-type> - Append_To (Decls, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Comp_Nam, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => - True, - Constant_Present => - Ekind (Formal) = E_In_Parameter, - Subtype_Indication => - New_Reference_To (Etype (Actual), Loc)))); + Comp_Nam := + Make_Defining_Identifier (Loc, New_Internal_Name ('A')); - -- Generate: - -- Param : Ann; + Append_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Comp_Nam, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => + True, + Constant_Present => + Ekind (Formal) = E_In_Parameter, + Subtype_Indication => + New_Reference_To (Etype (Actual), Loc)))); - Append_To (Comps, - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Chars (Formal)), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => - False, - Subtype_Indication => - New_Reference_To (Comp_Nam, Loc)))); + -- Generate: + -- Param : Ann; + + Append_To (Comps, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Formal)), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => + False, + Subtype_Indication => + New_Reference_To (Comp_Nam, Loc)))); + + Has_Comp := True; + end if; Next_Actual (Actual); Next_Formal_With_Extras (Formal); end loop; - -- Generate: - -- type Pnn is record - -- Param1 : Ann1; - -- ... - -- ParamN : AnnN; + Rec_Nam := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - -- where Pnn is a parameter wrapping record, Param1 .. ParamN are the - -- original parameter names and Ann1 .. AnnN are the access to actual - -- types. + if Has_Comp then - Comp_Rec := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + -- Generate: + -- type Pnn is record + -- Param1 : Ann1; + -- ... + -- ParamN : AnnN; - Append_To (Decls, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Comp_Rec, - Type_Definition => - Make_Record_Definition (Loc, - Component_List => - Make_Component_List (Loc, Comps)))); + -- where Pnn is a parameter wrapping record, Param1 .. ParamN are + -- the original parameter names and Ann1 .. AnnN are the access to + -- actual types. + + Append_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Rec_Nam, + Type_Definition => + Make_Record_Definition (Loc, + Component_List => + Make_Component_List (Loc, Comps)))); + else + -- Generate: + -- type Pnn is null record; - return Comp_Rec; + Append_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Rec_Nam, + Type_Definition => + Make_Record_Definition (Loc, + Null_Present => True, + Component_List => Empty))); + end if; + + return Rec_Nam; end Build_Parameter_Block; ------------------------ @@ -1579,8 +1669,8 @@ package body Exp_Ch9 is -- The two parameters must be mode conformant and have -- the exact same types. - if Out_Present (Prim_Op_Param) /= Out_Present (Proc_Param) - or else In_Present (Prim_Op_Param) /= In_Present (Proc_Param) + if Ekind (Defining_Identifier (Prim_Op_Param)) /= + Ekind (Defining_Identifier (Proc_Param)) or else Etype (Parameter_Type (Prim_Op_Param)) /= Etype (Parameter_Type (Proc_Param)) then @@ -1637,7 +1727,6 @@ package body Exp_Ch9 is return Type_Conformant_Parameters ( Parameter_Specifications (Prim_Op_Spec), Parameter_Specifications (Proc_Spec)); - end Overriding_Possible; ----------------------------- @@ -1653,25 +1742,22 @@ package body Exp_Ch9 is begin Formal := First (Formals); + while Present (Formal) loop - if Present (Formal) then - while Present (Formal) loop + -- Create an explicit copy of the entry parameter - -- Create an explicit copy of the entry parameter + Append_To (New_Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Formal))), + In_Present => In_Present (Formal), + Out_Present => Out_Present (Formal), + Parameter_Type => New_Reference_To (Etype ( + Parameter_Type (Formal)), Loc))); - Append_To (New_Formals, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Identifier (Formal))), - In_Present => In_Present (Formal), - Out_Present => Out_Present (Formal), - Parameter_Type => New_Reference_To (Etype ( - Parameter_Type (Formal)), Loc))); - - Next (Formal); - end loop; - end if; + Next (Formal); + end loop; return New_Formals; end Replicate_Entry_Formals; @@ -1697,10 +1783,13 @@ package body Exp_Ch9 is if Present (Primitive_Operations (Iface)) then Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); - while Present (Iface_Prim_Op_Elmt) loop Iface_Prim_Op := Node (Iface_Prim_Op_Elmt); + while Present (Alias (Iface_Prim_Op)) loop + Iface_Prim_Op := Alias (Iface_Prim_Op); + end loop; + -- The current primitive operation can be overriden by the -- generated entry wrapper. @@ -1897,9 +1986,7 @@ package body Exp_Ch9 is Spec := Build_Find_Body_Index_Spec (Typ); Ent := First_Entity (Typ); - while Present (Ent) loop - if Ekind (Ent) = E_Entry_Family then Has_F := True; exit; @@ -1955,12 +2042,10 @@ package body Exp_Ch9 is elsif Nkind (Ret) = N_If_Statement then - -- Ranges are in increasing order, so last one doesn't need a - -- guard. + -- Ranges are in increasing order, so last one doesn't need guard declare Nod : constant Node_Id := Last (Elsif_Parts (Ret)); - begin Remove (Nod); Set_Else_Statements (Ret, Then_Statements (Nod)); @@ -2021,7 +2106,8 @@ package body Exp_Ch9 is S := Scope (E); -- Ada 2005 (AI-287): Do not set/get the has_master_entity reminder - -- in internal scopes. Required for nested limited aggregates. + -- in internal scopes, unless present already.. Required for nested + -- limited aggregates. This could use some more explanation ???? if Ada_Version >= Ada_05 then while Is_Internal (S) loop @@ -2110,12 +2196,17 @@ package body Exp_Ch9 is Espec := Build_Protected_Entry_Specification (Edef, Empty, Loc); -- <object pointer declaration> - -- Add object pointer declaration. This is needed by the - -- discriminal and prival renamings, which should already - -- have been inserted into the declaration list. + + -- Add object pointer declaration. This is needed by the discriminal and + -- prival renamings, which should already have been inserted into the + -- declaration list. Add_Object_Pointer (Op_Decls, Pid, Loc); + -- Add renamings for formals for use by debugger + + Add_Formal_Renamings (Espec, Op_Decls, Ent, Loc); + if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False or else Number_Entries (Pid) > 1 @@ -2169,6 +2260,9 @@ package body Exp_Ch9 is RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc); end if; + -- Create body of entry procedure. The renaming declarations are + -- placed ahead of the block that contains the actual entry body. + return Make_Subprogram_Body (Loc, Specification => Espec, @@ -2248,6 +2342,7 @@ package body Exp_Ch9 is Ident : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; Formal : Entity_Id; New_Plist : List_Id; New_Param : Node_Id; @@ -2255,7 +2350,6 @@ package body Exp_Ch9 is begin New_Plist := New_List; Formal := First_Formal (Ident); - while Present (Formal) loop New_Param := Make_Parameter_Specification (Loc, @@ -2278,7 +2372,7 @@ package body Exp_Ch9 is -- to protected subprogram, the parameter is in-out. Otherwise it is -- an in parameter. - Prepend_To (New_Plist, + Decl := Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uObject), @@ -2286,7 +2380,9 @@ package body Exp_Ch9 is Out_Present => (Etype (Ident) = Standard_Void_Type and then not Is_RTE (Obj_Type, RE_Address)), - Parameter_Type => New_Reference_To (Obj_Type, Loc))); + Parameter_Type => New_Reference_To (Obj_Type, Loc)); + Set_Needs_Debug_Info (Defining_Identifier (Decl)); + Prepend_To (New_Plist, Decl); return New_Plist; end Build_Protected_Spec; @@ -2302,9 +2398,7 @@ package body Exp_Ch9 is is Loc : constant Source_Ptr := Sloc (N); Decl : Node_Id; - Protnm : constant Name_Id := Chars (Prottyp); Ident : Entity_Id; - Nam : Name_Id; New_Id : Entity_Id; New_Plist : List_Id; New_Spec : Node_Id; @@ -2324,7 +2418,6 @@ package body Exp_Ch9 is end if; Ident := Defining_Unit_Name (Specification (Decl)); - Nam := Chars (Ident); New_Plist := Build_Protected_Spec (Decl, @@ -2333,7 +2426,7 @@ package body Exp_Ch9 is New_Id := Make_Defining_Identifier (Loc, - Chars => Build_Selected_Name (Protnm, Nam, Append_Chr (Mode))); + Chars => Build_Selected_Name (Prottyp, Ident, Append_Chr (Mode))); -- The unprotected operation carries the user code, and debugging -- information must be generated for it, even though this spec does @@ -2397,24 +2490,28 @@ package body Exp_Ch9 is function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is function Has_Side_Effect (N : Node_Id) return Boolean; - -- Return True whenever encountering a subprogram call or a - -- raise statement of any kind in the sequence of statements N + -- Return True whenever encountering a subprogram call or raise + -- statement of any kind in the sequence of statements --------------------- -- Has_Side_Effect -- --------------------- - -- What is this doing buried two levels down in exp_ch9. It - -- seems like a generally useful function, and indeed there - -- may be code duplication going on here ??? + -- What is this doing buried two levels down in exp_ch9. It seems + -- like a generally useful function, and indeed there may be code + -- duplication going on here ??? function Has_Side_Effect (N : Node_Id) return Boolean is - Stmt : Node_Id := N; + Stmt : Node_Id; Expr : Node_Id; function Is_Call_Or_Raise (N : Node_Id) return Boolean; -- Indicate whether N is a subprogram call or a raise statement + ---------------------- + -- Is_Call_Or_Raise -- + ---------------------- + function Is_Call_Or_Raise (N : Node_Id) return Boolean is begin return Nkind (N) = N_Procedure_Call_Statement @@ -2428,6 +2525,7 @@ package body Exp_Ch9 is -- Start of processing for Has_Side_Effect begin + Stmt := N; while Present (Stmt) loop if Is_Call_Or_Raise (Stmt) then return True; @@ -2485,13 +2583,12 @@ package body Exp_Ch9 is P_Op_Spec := Build_Protected_Sub_Specification (N, Pid, Protected_Mode); - -- Build a list of the formal parameters of the protected - -- version of the subprogram to use as the actual parameters - -- of the unprotected version. + -- Build a list of the formal parameters of the protected version of + -- the subprogram to use as the actual parameters of the unprotected + -- version. Uactuals := New_List; Pformal := First (Parameter_Specifications (P_Op_Spec)); - while Present (Pformal) loop Append ( Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))), @@ -2499,8 +2596,8 @@ package body Exp_Ch9 is Next (Pformal); end loop; - -- Make a call to the unprotected version of the subprogram - -- built above for use by the protected version built below. + -- Make a call to the unprotected version of the subprogram built above + -- for use by the protected version built below. if Nkind (Op_Spec) = N_Function_Specification then if Exc_Safe then @@ -2711,17 +2808,18 @@ package body Exp_Ch9 is ------------------------- function Build_Selected_Name - (Prefix, Selector : Name_Id; - Append_Char : Character := ' ') return Name_Id + (Prefix : Entity_Id; + Selector : Entity_Id; + Append_Char : Character := ' ') return Name_Id is Select_Buffer : String (1 .. Hostparm.Max_Name_Length); Select_Len : Natural; begin - Get_Name_String (Selector); + Get_Name_String (Chars (Selector)); Select_Len := Name_Len; Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len); - Get_Name_String (Prefix); + Get_Name_String (Chars (Prefix)); -- If scope is anonymous type, discard suffix to recover name of -- single protected object. Otherwise use protected type name. @@ -2739,12 +2837,28 @@ package body Exp_Ch9 is Name_Buffer (Name_Len) := Select_Buffer (J); end loop; + -- Now add the Append_Char if specified. The encoding to follow + -- depends on the type of entity. If Append_Char is either 'N' or 'P', + -- then the entity is associated to a protected type subprogram. + -- Otherwise, it is a protected type entry. For each case, the + -- encoding to follow for the suffix is documented in exp_dbug.ads. + + -- It would be better to encapsulate this as a routine in Exp_Dbug ??? + if Append_Char /= ' ' then - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := Append_Char; + if Append_Char = 'P' or Append_Char = 'N' then + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Append_Char; + return Name_Find; + else + Name_Buffer (Name_Len + 1) := '_'; + Name_Buffer (Name_Len + 2) := Append_Char; + Name_Len := Name_Len + 2; + return New_External_Name (Name_Find, ' ', -1); + end if; + else + return Name_Find; end if; - - return Name_Find; end Build_Selected_Name; ----------------------------- @@ -2815,24 +2929,26 @@ package body Exp_Ch9 is Loc : constant Source_Ptr := Sloc (N); Parms : constant List_Id := Parameter_Associations (N); Stats : constant List_Id := New_List; - Pdecl : Node_Id; - Xdecl : Node_Id; - Decls : List_Id; + Actual : Node_Id; + Call : Node_Id; + Comm_Name : Entity_Id; Conctyp : Node_Id; + Decls : List_Id; Ent : Entity_Id; Ent_Acc : Entity_Id; + Formal : Node_Id; + Iface_Tag : Entity_Id; + Iface_Typ : Entity_Id; + N_Node : Node_Id; + N_Var : Node_Id; P : Entity_Id; - X : Entity_Id; - Plist : List_Id; Parm1 : Node_Id; Parm2 : Node_Id; Parm3 : Node_Id; - Call : Node_Id; - Actual : Node_Id; - Formal : Node_Id; - N_Node : Node_Id; - N_Var : Node_Id; - Comm_Name : Entity_Id; + Pdecl : Node_Id; + Plist : List_Id; + X : Entity_Id; + Xdecl : Node_Id; begin -- Simple entry and entry family cases merge here @@ -2899,7 +3015,7 @@ package body Exp_Ch9 is end if; -- The third parameter is the packaged parameters. If there are - -- none, then it is just the null address, since nothing is passed + -- none, then it is just the null address, since nothing is passed. if No (Parms) then Parm3 := New_Reference_To (RTE (RE_Null_Address), Loc); @@ -2909,8 +3025,8 @@ package body Exp_Ch9 is -- of a packaged record containing the required parameter values. else - -- First build a list of parameter values, which are - -- references to objects of the parameter types. + -- First build a list of parameter values, which are references to + -- objects of the parameter types. Plist := New_List; @@ -2932,9 +3048,9 @@ package body Exp_Ch9 is Object_Definition => New_Reference_To (Etype (Formal), Loc)); - -- We have to make an assignment statement separate for - -- the case of limited type. We can not assign it unless - -- the Assignment_OK flag is set first. + -- We have to make an assignment statement separate for the + -- case of limited type. We cannot assign it unless the + -- Assignment_OK flag is set first. if Ekind (Formal) /= E_Out_Parameter then N_Var := @@ -2954,8 +3070,36 @@ package body Exp_Ch9 is Prefix => New_Reference_To (Defining_Identifier (N_Node), Loc))); else - Append_To (Plist, - Make_Reference (Loc, Prefix => Relocate_Node (Actual))); + -- Interface class-wide formal + + if Ada_Version >= Ada_05 + and then Ekind (Etype (Formal)) = E_Class_Wide_Type + and then Is_Interface (Etype (Formal)) + then + Iface_Typ := Etype (Etype (Formal)); + + -- Generate: + -- formal_iface_type! (actual.iface_tag)'reference + + Iface_Tag := + Find_Interface_Tag (Etype (Actual), Iface_Typ); + pragma Assert (Present (Iface_Tag)); + + Append_To (Plist, + Make_Reference (Loc, + Unchecked_Convert_To (Iface_Typ, + Make_Selected_Component (Loc, + Prefix => + Relocate_Node (Actual), + Selector_Name => + New_Reference_To (Iface_Tag, Loc))))); + else + -- Generate: + -- actual'reference + + Append_To (Plist, + Make_Reference (Loc, Relocate_Node (Actual))); + end if; end if; Next_Actual (Actual); @@ -3066,8 +3210,8 @@ package body Exp_Ch9 is Append_To (Stats, Call); - -- If there are out or in/out parameters by copy - -- add assignment statements for the result values. + -- If there are out or in/out parameters by copy add assignment + -- statements for the result values. if Present (Parms) then Actual := First_Actual (N); @@ -3088,17 +3232,17 @@ package body Exp_Ch9 is Selector_Name => Make_Identifier (Loc, Chars (Formal))))); - -- In all cases (including limited private types) we - -- want the assignment to be valid. + -- In all cases (including limited private types) we want + -- the assignment to be valid. Set_Assignment_OK (Name (N_Node)); -- If the call is the triggering alternative in an - -- asynchronous select, or the entry_call alternative - -- of a conditional entry call, the assignments for in-out - -- parameters are incorporated into the statement list - -- that follows, so that there are executed only if the - -- entry call succeeds. + -- asynchronous select, or the entry_call alternative of a + -- conditional entry call, the assignments for in-out + -- parameters are incorporated into the statement list that + -- follows, so that there are executed only if the entry + -- call succeeds. if (Nkind (Parent (N)) = N_Triggering_Alternative and then N = Triggering_Statement (Parent (N))) @@ -3394,9 +3538,9 @@ package body Exp_Ch9 is Op_Decls : List_Id; begin - -- Make an unprotected version of the subprogram for use - -- within the same object, with a new name and an additional - -- parameter representing the object. + -- Make an unprotected version of the subprogram for use within the same + -- object, with a new name and an additional parameter representing the + -- object. Op_Decls := Declarations (N); N_Op_Spec := @@ -3434,22 +3578,61 @@ package body Exp_Ch9 is Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('F')); - Efam_Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Efam_Type, - Type_Definition => - Make_Unconstrained_Array_Definition (Loc, - Subtype_Marks => (New_List ( - New_Occurrence_Of ( + declare + Bas : Entity_Id := Base_Type - (Etype (Discrete_Subtype_Definition - (Parent (Efam)))), Loc))), + (Etype (Discrete_Subtype_Definition (Parent (Efam)))); + Bas_Decl : Node_Id := Empty; + Lo, Hi : Node_Id; + + begin + Get_Index_Bounds + (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi); + if Scope (Bas) = Standard_Standard + and then Bas = Base_Type (Standard_Integer) + and then Has_Discriminants (Conctyp) + and then Present + (Discriminant_Default_Value (First_Discriminant (Conctyp))) + and then + (Denotes_Discriminant (Lo, True) + or else Denotes_Discriminant (Hi, True)) + then + Bas := + Make_Defining_Identifier (Loc, New_Internal_Name ('B')); + Bas_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Bas, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Standard_Integer, Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => Make_Range (Loc, + Make_Integer_Literal + (Loc, -Entry_Family_Bound), + Make_Integer_Literal + (Loc, Entry_Family_Bound - 1))))); + + Insert_After (Current_Node, Bas_Decl); + Current_Node := Bas_Decl; + Analyze (Bas_Decl); + end if; + + Efam_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Efam_Type, + Type_Definition => + Make_Unconstrained_Array_Definition (Loc, + Subtype_Marks => + (New_List (New_Occurrence_Of (Bas, Loc))), Component_Definition => Make_Component_Definition (Loc, Aliased_Present => False, Subtype_Indication => New_Reference_To (Standard_Character, Loc)))); + end; Insert_After (Current_Node, Efam_Decl); Current_Node := Efam_Decl; @@ -3485,8 +3668,8 @@ package body Exp_Ch9 is -- Concurrent_Ref -- -------------------- - -- The expression returned for a reference to a concurrent - -- object has the form: + -- The expression returned for a reference to a concurrent object has the + -- form: -- taskV!(name)._Task_Id @@ -3501,8 +3684,8 @@ package body Exp_Ch9 is -- objectV!(name.all)._Object -- here taskV and objectV are the types for the associated records, which - -- contain the required _Task_Id and _Object fields for tasks and - -- protected objects, respectively. + -- contain the required _Task_Id and _Object fields for tasks and protected + -- objects, respectively. -- For the case of a task type name, the expression is @@ -3514,8 +3697,8 @@ package body Exp_Ch9 is -- objectR - -- which is a renaming of the _object field of the current object - -- object record, passed into protected operations as a parameter. + -- which is a renaming of the _object field of the current object object + -- record, passed into protected operations as a parameter. function Concurrent_Ref (N : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); @@ -3560,8 +3743,8 @@ package body Exp_Ch9 is end if; end loop; - -- We know that we are within the task body, so should have - -- found it in scope. + -- We know that we are within the task body, so should have found it + -- in scope. raise Program_Error; end Is_Current_Task; @@ -3598,10 +3781,11 @@ package body Exp_Ch9 is else declare Decl : Node_Id; - T_Self : constant Entity_Id - := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); - T_Body : constant Node_Id - := Parent (Corresponding_Body (Parent (Entity (N)))); + T_Self : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + T_Body : constant Node_Id := + Parent (Corresponding_Body (Parent (Entity (N)))); begin Decl := Make_Object_Declaration (Loc, @@ -3680,22 +3864,22 @@ package body Exp_Ch9 is S : Node_Id; begin - -- The queues of entries and entry families appear in textual - -- order in the associated record. The entry index is computed as - -- the sum of the number of queues for all entries that precede the - -- designated one, to which is added the index expression, if this - -- expression denotes a member of a family. + -- The queues of entries and entry families appear in textual order in + -- the associated record. The entry index is computed as the sum of the + -- number of queues for all entries that precede the designated one, to + -- which is added the index expression, if this expression denotes a + -- member of a family. -- The following is a place holder for the count of simple entries Num := Make_Integer_Literal (Sloc, 1); - -- We construct an expression which is a series of addition - -- operations. The first operand is the number of single entries that - -- precede this one, the second operand is the index value relative - -- to the start of the referenced family, and the remaining operands - -- are the lengths of the entry families that precede this entry, i.e. - -- the constructed expression is: + -- We construct an expression which is a series of addition operations. + -- The first operand is the number of single entries that precede this + -- one, the second operand is the index value relative to the start of + -- the referenced family, and the remaining operands are the lengths of + -- the entry families that precede this entry, i.e. the constructed + -- expression is: -- number_simple_entries + -- (s'pos (index-value) - s'pos (family'first)) + 1 + @@ -3703,8 +3887,8 @@ package body Exp_Ch9 is -- where index-value is the given index value, and s is the index -- subtype (we have to use pos because the subtype might be an - -- enumeration type preventing direct subtraction). - -- Note that the task entry array is one-indexed. + -- enumeration type preventing direct subtraction). Note that the task + -- entry array is one-indexed. -- The upper bound of the entry family may be a discriminant, so we -- retrieve the lower bound explicitly to compute offset, rather than @@ -3770,7 +3954,6 @@ package body Exp_Ch9 is procedure Establish_Task_Master (N : Node_Id) is Call : Node_Id; - begin if Restriction_Active (No_Task_Hierarchy) = False then Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master); @@ -3822,13 +4005,12 @@ package body Exp_Ch9 is -- We can distinguish the two cases by seeing whether the accept statement -- is part of a list. If not, then it must be in an accept alternative. - -- To expand the requeue statement, a label is provided at the end of - -- the accept statement or alternative of which it is a part, so that - -- the statement can be skipped after the requeue is complete. - -- This label is created here rather than during the expansion of the - -- accept statement, because it will be needed by any requeue - -- statements within the accept, which are expanded before the - -- accept. + -- To expand the requeue statement, a label is provided at the end of the + -- accept statement or alternative of which it is a part, so that the + -- statement can be skipped after the requeue is complete. This label is + -- created here rather than during the expansion of the accept statement, + -- because it will be needed by any requeue statements within the accept, + -- which are expanded before the accept. procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -3864,8 +4046,8 @@ package body Exp_Ch9 is -- Create and declare two labels to be placed at the end of the -- accept statement. The first label is used to allow requeues to - -- skip the remainder of entry processing. The second label is - -- used to skip the remainder of entry processing if the rendezvous + -- skip the remainder of entry processing. The second label is used + -- to skip the remainder of entry processing if the rendezvous -- completes in the middle of the accept body. if Present (Handled_Statement_Sequence (N)) then @@ -3952,11 +4134,10 @@ package body Exp_Ch9 is Next (Alt); end loop; - -- If we are the first accept statement, then we have to - -- create the Ann variable, as for the stand alone case, - -- except that it is inserted before the selective accept. - -- Similarly, a label for requeue expansion must be - -- declared. + -- If we are the first accept statement, then we have to create + -- the Ann variable, as for the stand alone case, except that + -- it is inserted before the selective accept. Similarly, a + -- label for requeue expansion must be declared. if N = Accept_Statement (Alt) then Ann := @@ -3971,8 +4152,8 @@ package body Exp_Ch9 is Insert_Before (Sel_Acc, Adecl); Analyze (Adecl); - -- If we are not the first accept statement, then find the - -- Ann variable allocated by the first accept and use it. + -- If we are not the first accept statement, then find the Ann + -- variable allocated by the first accept and use it. else Ann := @@ -3991,30 +4172,31 @@ package body Exp_Ch9 is Set_Needs_Debug_Info (Ann); end if; - -- Create renaming declarations for the entry formals. Each - -- reference to a formal becomes a dereference of a component - -- of the parameter block, whose address is held in Ann. - -- These declarations are eventually inserted into the accept - -- block, and analyzed there so that they have the proper scope - -- for gdb and do not conflict with other declarations. + -- Create renaming declarations for the entry formals. Each reference + -- to a formal becomes a dereference of a component of the parameter + -- block, whose address is held in Ann. These declarations are + -- eventually inserted into the accept block, and analyzed there so + -- that they have the proper scope for gdb and do not conflict with + -- other declarations. if Present (Parameter_Specifications (N)) and then Present (Handled_Statement_Sequence (N)) then declare - Formal : Entity_Id; - New_F : Entity_Id; Comp : Entity_Id; Decl : Node_Id; + Formal : Entity_Id; + New_F : Entity_Id; begin New_Scope (Ent); Formal := First_Formal (Ent); while Present (Formal) loop - Comp := Entry_Component (Formal); - New_F := + Comp := Entry_Component (Formal); + New_F := Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); + Set_Etype (New_F, Etype (Formal)); Set_Scope (New_F, Ent); Set_Needs_Debug_Info (New_F); -- That's the whole point. @@ -4030,16 +4212,19 @@ package body Exp_Ch9 is Decl := Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => New_F, - Subtype_Mark => New_Reference_To (Etype (Formal), Loc), - Name => - Make_Explicit_Dereference (Loc, - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (Entry_Parameters_Type (Ent), - New_Reference_To (Ann, Loc)), - Selector_Name => - New_Reference_To (Comp, Loc)))); + Defining_Identifier => + New_F, + Subtype_Mark => + New_Reference_To (Etype (Formal), Loc), + Name => + Make_Explicit_Dereference (Loc, + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To ( + Entry_Parameters_Type (Ent), + New_Reference_To (Ann, Loc)), + Selector_Name => + New_Reference_To (Comp, Loc)))); if No (Declarations (N)) then Set_Declarations (N, New_List); @@ -4065,10 +4250,10 @@ package body Exp_Ch9 is Comps : List_Id; T : constant Entity_Id := Defining_Identifier (N); D_T : constant Entity_Id := Designated_Type (T); - D_T2 : constant Entity_Id := Make_Defining_Identifier - (Loc, New_Internal_Name ('D')); - E_T : constant Entity_Id := Make_Defining_Identifier - (Loc, New_Internal_Name ('E')); + D_T2 : constant Entity_Id := Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('D')); + E_T : constant Entity_Id := Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('E')); P_List : constant List_Id := Build_Protected_Spec (N, RTE (RE_Address), False, D_T); Decl1 : Node_Id; @@ -4099,8 +4284,8 @@ package body Exp_Ch9 is Analyze (Decl1); Insert_After (N, Decl1); - -- Create Equivalent_Type, a record with two components for an - -- access to object and an access to subprogram. + -- Create Equivalent_Type, a record with two components for an access to + -- object and an access to subprogram. Comps := New_List ( Make_Component_Declaration (Loc, @@ -4154,12 +4339,12 @@ package body Exp_Ch9 is return; end if; - -- The body of the entry barrier must be analyzed in the context of - -- the protected object, but its scope is external to it, just as any - -- other unprotected version of a protected operation. The specification - -- has been produced when the protected type declaration was elaborated. - -- We build the body, insert it in the enclosing scope, but analyze it - -- in the current context. A more uniform approach would be to treat a + -- The body of the entry barrier must be analyzed in the context of the + -- protected object, but its scope is external to it, just as any other + -- unprotected version of a protected operation. The specification has + -- been produced when the protected type declaration was elaborated. We + -- build the body, insert it in the enclosing scope, but analyze it in + -- the current context. A more uniform approach would be to treat -- barrier just as a protected function, and discard the protected -- version of it because it is never called. @@ -4178,7 +4363,7 @@ package body Exp_Ch9 is Update_Prival_Subtypes (B_F); - Set_Privals (Spec_Decl, N, Loc); + Set_Privals (Spec_Decl, N, Loc, After_Barrier => True); Set_Discriminals (Spec_Decl); Set_Scope (Func, Scope (Prot)); @@ -4186,16 +4371,16 @@ package body Exp_Ch9 is Analyze_And_Resolve (Cond, Any_Boolean); end if; - -- The Ravenscar profile restricts barriers to simple variables - -- declared within the protected object. We also allow Boolean - -- constants, since these appear in several published examples - -- and are also allowed by the Aonix compiler. + -- The Ravenscar profile restricts barriers to simple variables declared + -- within the protected object. We also allow Boolean constants, since + -- these appear in several published examples and are also allowed by + -- the Aonix compiler. - -- Note that after analysis variables in this context will be - -- replaced by the corresponding prival, that is to say a renaming - -- of a selected component of the form _Object.Var. If expansion is - -- disabled, as within a generic, we check that the entity appears in - -- the current scope. + -- Note that after analysis variables in this context will be replaced + -- by the corresponding prival, that is to say a renaming of a selected + -- component of the form _Object.Var. If expansion is disabled, as + -- within a generic, we check that the entity appears in the current + -- scope. if Is_Entity_Name (Cond) then @@ -4278,11 +4463,37 @@ package body Exp_Ch9 is while Present (Tasknm) loop Count := Count + 1; - Append_To (Component_Associations (Aggr), - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, Count)), - Expression => Concurrent_Ref (Tasknm))); + + -- A task interface class-wide type object is being aborted. + -- Retrieve its _task_id by calling a dispatching routine. + + if Ada_Version >= Ada_05 + and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type + and then Is_Interface (Etype (Tasknm)) + and then Is_Task_Interface (Etype (Tasknm)) + then + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Count)), + Expression => + + -- Tasknm._disp_get_task_id + + Make_Selected_Component (Loc, + Prefix => + New_Copy_Tree (Tasknm), + Selector_Name => + Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))); + + else + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Count)), + Expression => Concurrent_Ref (Tasknm))); + end if; + Next (Tasknm); end loop; @@ -4340,10 +4551,10 @@ package body Exp_Ch9 is -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); -- end; - -- The first three declarations were already inserted ahead of the - -- accept statement by the Expand_Accept_Declarations procedure, which - -- was called directly from the semantics during analysis of the accept. - -- statement, before analyzing its contained statements. + -- The first three declarations were already inserted ahead of the accept + -- statement by the Expand_Accept_Declarations procedure, which was called + -- directly from the semantics during analysis of the accept. statement, + -- before analyzing its contained statements. -- The declarations from the N_Accept_Statement, as noted in Sinfo, come -- from possible expansion activity (the original source of course does @@ -4372,7 +4583,11 @@ package body Exp_Ch9 is function Null_Statements (Stats : List_Id) return Boolean; -- Check for null statement sequence (i.e a list of labels and - -- null statements) + -- null statements). + + --------------------- + -- Null_Statements -- + --------------------- function Null_Statements (Stats : List_Id) return Boolean is Stmt : Node_Id; @@ -4475,11 +4690,11 @@ package body Exp_Ch9 is Declarations => Declarations (N), Handled_Statement_Sequence => Build_Accept_Body (N)); - -- Prepend call to Accept_Call to main statement sequence - -- If the accept has exception handlers, the statement sequence - -- is wrapped in a block. Insert call and renaming declarations - -- in the declarations of the block, so they are elaborated before - -- the handlers. + -- Prepend call to Accept_Call to main statement sequence If the + -- accept has exception handlers, the statement sequence is wrapped + -- in a block. Insert call and renaming declarations in the + -- declarations of the block, so they are elaborated before the + -- handlers. Call := Make_Procedure_Call_Statement (Loc, @@ -4504,28 +4719,28 @@ package body Exp_Ch9 is D : Node_Id; Next_D : Node_Id; Typ : Entity_Id; + begin D := First (Declarations (N)); - while Present (D) loop Next_D := Next (D); if Nkind (D) = N_Object_Renaming_Declaration then - -- The renaming declarations for the formals were - -- created during analysis of the accept statement, - -- and attached to the list of declarations. Place - -- them now in the context of the accept block or - -- subprogram. + + -- The renaming declarations for the formals were created + -- during analysis of the accept statement, and attached to + -- the list of declarations. Place them now in the context + -- of the accept block or subprogram. Remove (D); Typ := Entity (Subtype_Mark (D)); Insert_After (Call, D); Analyze (D); - -- If the formal is class_wide, it does not have an - -- actual subtype. The analysis of the renaming declaration - -- creates one, but we need to retain the class-wide - -- nature of the entity. + -- If the formal is class_wide, it does not have an actual + -- subtype. The analysis of the renaming declaration creates + -- one, but we need to retain the class-wide nature of the + -- entity. if Is_Class_Wide_Type (Typ) then Set_Etype (Defining_Identifier (D), Typ); @@ -4691,16 +4906,6 @@ package body Exp_Ch9 is -- S : constant Integer := DT_Position (<dispatching-call>); -- U : Boolean; - -- procedure <temp>A is - -- begin - -- <abortable-statements> - -- end <temp>A; - - -- procedure <temp>T is - -- begin - -- <triggered-statements> - -- end <temp>T; - -- begin -- disp_get_prim_op_kind (<object>, S, C); @@ -4723,7 +4928,7 @@ package body Exp_Ch9 is -- ParamN := P.ParamN; -- if Enqueued (Bnn) then - -- <temp>A; + -- <abortable-statements> -- end if; -- at end -- _clean; @@ -4733,7 +4938,7 @@ package body Exp_Ch9 is -- end; -- if not Cancelled (Bnn) then - -- <temp>T; + -- <triggering-statements> -- end if; -- elsif C = POK_Task_Entry then @@ -4756,7 +4961,7 @@ package body Exp_Ch9 is -- begin -- begin -- Abort_Undefer; - -- <temp>A; + -- <abortable-statements> -- at end -- _clean; -- end; @@ -4765,13 +4970,13 @@ package body Exp_Ch9 is -- end; -- if not U then - -- <temp>T; + -- <triggering-statements> -- end if; -- end; -- else -- <dispatching-call>; - -- <temp>T; + -- <triggering-statements> -- end if; -- The job is to convert this to the asynchronous form @@ -4795,46 +5000,46 @@ package body Exp_Ch9 is Trig : constant Node_Id := Triggering_Alternative (N); Tstats : constant List_Id := Statements (Trig); - Abortable_Block : Node_Id; - Actuals : List_Id; - Aproc : Entity_Id; - Blk_Ent : Entity_Id; - Blk_Typ : Entity_Id; - Call : Node_Id; - Call_Ent : Entity_Id; - Cancel_Param : Entity_Id; - Cleanup_Block : Node_Id; - Cleanup_Stmts : List_Id; - Concval : Node_Id; - Dblock_Ent : Entity_Id; - Decl : Node_Id; - Decls : List_Id; - Ecall : Node_Id; - Ename : Node_Id; - Enqueue_Call : Node_Id; - Formals : List_Id; - Hdle : List_Id; - Index : Node_Id; - N_Orig : Node_Id; - Obj : Entity_Id; - Param : Node_Id; - Params : List_Id; - Pdef : Entity_Id; - ProtE_Stmts : List_Id; - ProtP_Stmts : List_Id; - Stmt : Node_Id; - Stmts : List_Id; - Target_Undefer : RE_Id; - TaskE_Stmts : List_Id; - Tproc : Entity_Id; - Undefer_Args : List_Id := No_List; + Abort_Block_Ent : Entity_Id; + Abortable_Block : Node_Id; + Actuals : List_Id; + Blk_Ent : Entity_Id; + Blk_Typ : Entity_Id; + Call : Node_Id; + Call_Ent : Entity_Id; + Cancel_Param : Entity_Id; + Cleanup_Block : Node_Id; + Cleanup_Block_Ent : Entity_Id; + Cleanup_Stmts : List_Id; + Concval : Node_Id; + Dblock_Ent : Entity_Id; + Decl : Node_Id; + Decls : List_Id; + Ecall : Node_Id; + Ename : Node_Id; + Enqueue_Call : Node_Id; + Formals : List_Id; + Hdle : List_Id; + Index : Node_Id; + N_Orig : Node_Id; + Obj : Entity_Id; + Param : Node_Id; + Params : List_Id; + Pdef : Entity_Id; + ProtE_Stmts : List_Id; + ProtP_Stmts : List_Id; + Stmt : Node_Id; + Stmts : List_Id; + Target_Undefer : RE_Id; + TaskE_Stmts : List_Id; + Undefer_Args : List_Id := No_List; B : Entity_Id; -- Call status flag Bnn : Entity_Id; -- Communication block C : Entity_Id; -- Call kind - P : Node_Id; -- Parameter block + P : Entity_Id; -- Parameter block S : Entity_Id; -- Primitive operation slot - U : Entity_Id; -- Additional status flag + T : Entity_Id; -- Additional status flag begin Blk_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); @@ -4900,50 +5105,37 @@ package body Exp_Ch9 is -- Dispatch table slot processing, generate: -- S : constant Integer := - -- DT_Position (<dispatching-procedure>); + -- Ada.Tags.Get_Offset_Index ( + -- Unchecked_Convert_To (Ada.Tags.Interface_Tag, Obj), + -- DT_Position (<dispatching-procedure>)); - S := SEU.Build_S (Loc, Decls, Call_Ent); + S := SEU.Build_S (Loc, Decls, Obj, Call_Ent); -- Additional status flag processing, generate: - U := Make_Defining_Identifier (Loc, Name_uU); + T := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => - U, + T, Object_Definition => New_Reference_To (Standard_Boolean, Loc))); - -- Generate: - -- procedure <temp>A is - -- begin - -- Astmts - -- end <temp>A; - - Aproc := SEU.Build_Wrapping_Procedure (Loc, 'A', Decls, Astats); - - -- Generate: - -- procedure <temp>T is - -- begin - -- Tstmts - -- end <temp>T; - - Tproc := SEU.Build_Wrapping_Procedure (Loc, 'T', Decls, Tstats); - - -- Generate: - -- _dispatching_get_prim_op_kind (<object>, S, C); - Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => - Make_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind), + New_Reference_To ( + Find_Prim_Op (Etype (Etype (Obj)), + Name_uDisp_Get_Prim_Op_Kind), + Loc), Parameter_Associations => New_List ( New_Copy_Tree (Obj), New_Reference_To (S, Loc), New_Reference_To (C, Loc)))); + -- --------------------------------------------------------------- -- Protected entry handling -- Generate: @@ -4951,7 +5143,7 @@ package body Exp_Ch9 is -- ... -- ParamN := P.ParamN; - Cleanup_Stmts := Parameter_Block_Unpack (Loc, Actuals, Formals); + Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); -- Generate: -- _dispatching_asynchronous_select @@ -4960,22 +5152,25 @@ package body Exp_Ch9 is Prepend_To (Cleanup_Stmts, Make_Procedure_Call_Statement (Loc, Name => - Make_Identifier (Loc, Name_uDisp_Asynchronous_Select), + New_Reference_To ( + Find_Prim_Op (Etype (Etype (Obj)), + Name_uDisp_Asynchronous_Select), + Loc), Parameter_Associations => New_List ( New_Copy_Tree (Obj), New_Reference_To (S, Loc), - P, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P, Loc), + Attribute_Name => Name_Address), New_Reference_To (Bnn, Loc), New_Reference_To (B, Loc)))); -- Generate: -- if Enqueued (Bnn) then - -- <temp>A + -- <abortable-statements> -- end if; - -- where <temp>A is the abort statements wrapping procedure - Append_To (Cleanup_Stmts, Make_If_Statement (Loc, Condition => @@ -4987,12 +5182,7 @@ package body Exp_Ch9 is New_Reference_To (Bnn, Loc))), Then_Statements => - New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (Aproc, Loc), - Parameter_Associations => - No_List)))); + New_Copy_List_Tree (Astats))); -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions -- will then generate a _clean for the communication block Bnn. @@ -5011,10 +5201,13 @@ package body Exp_Ch9 is -- _clean; -- end; - Cleanup_Block := - SEU.Build_Cleanup_Block (Loc, Blk_Ent, Cleanup_Stmts, Bnn); + Cleanup_Block_Ent := + Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + + Cleanup_Block := SEU.Build_Cleanup_Block (Loc, + Cleanup_Block_Ent, Cleanup_Stmts, Bnn); - -- Wrap the cleanup block in an exception handling block. + -- Wrap the cleanup block in an exception handling block -- Generate: -- begin @@ -5023,17 +5216,22 @@ package body Exp_Ch9 is -- when Abort_Signal => Abort_Undefer; -- end; + Abort_Block_Ent := + Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + ProtE_Stmts := New_List ( - SEU.Build_Abort_Block (Loc, Blk_Ent, Cleanup_Block)); + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Abort_Block_Ent), + + SEU.Build_Abort_Block (Loc, + Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); -- Generate: -- if not Cancelled (Bnn) then - -- <temp>T + -- <triggering-statements> -- end if; - -- there <temp>T is the triggering statements wrapping procedure - Append_To (ProtE_Stmts, Make_If_Statement (Loc, Condition => @@ -5047,14 +5245,9 @@ package body Exp_Ch9 is New_Reference_To (Bnn, Loc)))), Then_Statements => - New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (Tproc, Loc), - Parameter_Associations => - No_List)))); + New_Copy_List_Tree (Tstats))); - ------------------------------------------------------------------- + -- --------------------------------------------------------------- -- Task entry handling -- Generate: @@ -5062,7 +5255,7 @@ package body Exp_Ch9 is -- ... -- ParamN := P.ParamN; - TaskE_Stmts := Parameter_Block_Unpack (Loc, Actuals, Formals); + TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); -- Generate: -- _dispatching_asynchronous_select @@ -5071,12 +5264,17 @@ package body Exp_Ch9 is Prepend_To (TaskE_Stmts, Make_Procedure_Call_Statement (Loc, Name => - Make_Identifier (Loc, Name_uDisp_Asynchronous_Select), + New_Reference_To ( + Find_Prim_Op (Etype (Etype (Obj)), + Name_uDisp_Asynchronous_Select), + Loc), Parameter_Associations => New_List ( New_Copy_Tree (Obj), New_Reference_To (S, Loc), - New_Copy_Tree (P), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P, Loc), + Attribute_Name => Name_Address), New_Reference_To (Bnn, Loc), New_Reference_To (B, Loc)))); @@ -5092,23 +5290,16 @@ package body Exp_Ch9 is -- Generate: -- Abort_Undefer; - -- <temp>A - - -- where <temp>A is the abortable statements wrapping procedure + -- <abortable-statements> - Cleanup_Stmts := - New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Abort_Undefer), Loc), - Parameter_Associations => - No_List), + Cleanup_Stmts := New_Copy_List_Tree (Astats); - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (Aproc, Loc), - Parameter_Associations => - No_List)); + Prepend_To (Cleanup_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Abort_Undefer), Loc), + Parameter_Associations => + No_List)); -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions -- will generate a _clean for the additional status flag. @@ -5125,10 +5316,11 @@ package body Exp_Ch9 is -- _clean; -- end; - Blk_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Cleanup_Block_Ent := + Make_Defining_Identifier (Loc, New_Internal_Name ('C')); - Cleanup_Block := - SEU.Build_Cleanup_Block (Loc, Blk_Ent, Cleanup_Stmts, U); + Cleanup_Block := SEU.Build_Cleanup_Block (Loc, + Cleanup_Block_Ent, Cleanup_Stmts, T); -- Wrap the cleanup block in an exception handling block @@ -5139,48 +5331,41 @@ package body Exp_Ch9 is -- when Abort_Signal => Abort_Undefer; -- end; + Abort_Block_Ent := + Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Append_To (TaskE_Stmts, - SEU.Build_Abort_Block (Loc, Blk_Ent, Cleanup_Block)); + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Abort_Block_Ent)); + + Append_To (TaskE_Stmts, + SEU.Build_Abort_Block (Loc, + Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); -- Generate: - -- if not U then - -- <temp>T + -- if not T then + -- <triggering-statements> -- end if; - -- where <temp>T is the triggering statements wrapping procedure - Append_To (TaskE_Stmts, Make_If_Statement (Loc, Condition => Make_Op_Not (Loc, Right_Opnd => - New_Reference_To (U, Loc)), + New_Reference_To (T, Loc)), + Then_Statements => - New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (Tproc, Loc), - Parameter_Associations => - No_List)))); + New_Copy_List_Tree (Tstats))); ------------------------------------------------------------------- -- Protected procedure handling -- Generate: -- <dispatching-call>; - -- <temp>T; + -- <triggering-statements> - -- where <temp>T is the triggering statements wrapping procedure - - ProtP_Stmts := - New_List ( - New_Copy_Tree (Ecall), - - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (Tproc, Loc), - Parameter_Associations => - No_List)); + ProtP_Stmts := New_Copy_List_Tree (Tstats); + Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall)); -- Generate: -- if C = POK_Procedure_Entry then @@ -5212,6 +5397,7 @@ package body Exp_Ch9 is New_Reference_To (C, Loc), Right_Opnd => New_Reference_To (RTE (RE_POK_Task_Entry), Loc)), + Then_Statements => TaskE_Stmts)), @@ -5331,6 +5517,7 @@ package body Exp_Ch9 is Analyze (N); return; end if; + else N_Orig := N; end if; @@ -5725,10 +5912,11 @@ package body Exp_Ch9 is Params : List_Id; Stmt : Node_Id; Stmts : List_Id; + Unpack : List_Id; B : Entity_Id; -- Call status flag C : Entity_Id; -- Call kind - P : Node_Id; -- Parameter block + P : Entity_Id; -- Parameter block S : Entity_Id; -- Primitive operation slot begin @@ -5758,9 +5946,11 @@ package body Exp_Ch9 is -- Dispatch table slot processing, generate: -- S : constant Integer := - -- DT_Position (<dispatching-procedure>); + -- Ada.Tags.Get_Offset_Index ( + -- Unchecked_Convert_To (Ada.Tags.Interface_Tag, Obj), + -- DT_Position (<dispatching-procedure>)); - S := SEU.Build_S (Loc, Decls, Call_Ent); + S := SEU.Build_S (Loc, Decls, Obj, Call_Ent); -- Generate: -- _dispatching_conditional_select (<object>, S, P'address, C, B); @@ -5768,12 +5958,17 @@ package body Exp_Ch9 is Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => - Make_Identifier (Loc, Name_uDisp_Conditional_Select), + New_Reference_To ( + Find_Prim_Op (Etype (Etype (Obj)), + Name_uDisp_Conditional_Select), + Loc), Parameter_Associations => New_List ( New_Copy_Tree (Obj), New_Reference_To (S, Loc), - P, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P, Loc), + Attribute_Name => Name_Address), New_Reference_To (C, Loc), New_Reference_To (B, Loc)))); @@ -5786,26 +5981,33 @@ package body Exp_Ch9 is -- ParamN := P.ParamN; -- end if; - Append_To (Stmts, - Make_If_Statement (Loc, + Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); - Condition => - Make_Or_Else (Loc, - Left_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To (C, Loc), - Right_Opnd => - New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)), - Right_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To (C, Loc), - Right_Opnd => - New_Reference_To (RTE (RE_POK_Task_Entry), Loc))), + -- Generate the if statement only when the packed parameters need + -- explicit assignments to their corresponding actuals. - Then_Statements => - Parameter_Block_Unpack (Loc, Actuals, Formals))); + if Present (Unpack) then + Append_To (Stmts, + Make_If_Statement (Loc, + + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Protected_Entry), Loc)), + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Task_Entry), Loc))), + + Then_Statements => Unpack)); + end if; -- Generate: -- if B then @@ -5820,7 +6022,7 @@ package body Exp_Ch9 is -- <else-statements> -- end if; - N_Stats := New_Copy_List (Statements (Alt)); + N_Stats := New_Copy_List_Tree (Statements (Alt)); Prepend_To (N_Stats, Make_If_Statement (Loc, @@ -6060,10 +6262,9 @@ package body Exp_Ch9 is end if; end if; - -- Associate privals and discriminals with the next protected - -- operation body to be expanded. These are used to expand - -- references to private data objects and discriminants, - -- respectively. + -- Associate privals and discriminals with the next protected operation + -- body to be expanded. These are used to expand references to private + -- data objects and discriminants, respectively. Next_Op := Next_Protected_Operation (N); @@ -6091,16 +6292,15 @@ package body Exp_Ch9 is return; end if; - -- If this entry call is part of an asynchronous select, don't - -- expand it here; it will be expanded with the select statement. - -- Don't expand timed entry calls either, as they are translated - -- into asynchronous entry calls. + -- If this entry call is part of an asynchronous select, don't expand it + -- here; it will be expanded with the select statement. Don't expand + -- timed entry calls either, as they are translated into asynchronous + -- entry calls. - -- ??? This whole approach is questionable; it may be better - -- to go back to allowing the expansion to take place and then - -- attempting to fix it up in Expand_N_Asynchronous_Select. - -- The tricky part is figuring out whether the expanded - -- call is on a task or protected entry. + -- ??? This whole approach is questionable; it may be better to go back + -- to allowing the expansion to take place and then attempting to fix it + -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out + -- whether the expanded call is on a task or protected entry. if (Nkind (Parent (N)) /= N_Triggering_Alternative or else N /= Triggering_Statement (Parent (N))) @@ -6117,17 +6317,17 @@ package body Exp_Ch9 is -- Expand_N_Entry_Declaration -- -------------------------------- - -- If there are parameters, then first, each of the formals is marked - -- by setting Is_Entry_Formal. Next a record type is built which is - -- used to hold the parameter values. The name of this record type is - -- entryP where entry is the name of the entry, with an additional - -- corresponding access type called entryPA. The record type has matching - -- components for each formal (the component names are the same as the - -- formal names). For elementary types, the component type matches the - -- formal type. For composite types, an access type is declared (with - -- the name formalA) which designates the formal type, and the type of - -- the component is this access type. Finally the Entry_Component of - -- each formal is set to reference the corresponding record component. + -- If there are parameters, then first, each of the formals is marked by + -- setting Is_Entry_Formal. Next a record type is built which is used to + -- hold the parameter values. The name of this record type is entryP where + -- entry is the name of the entry, with an additional corresponding access + -- type called entryPA. The record type has matching components for each + -- formal (the component names are the same as the formal names). For + -- elementary types, the component type matches the formal type. For + -- composite types, an access type is declared (with the name formalA) + -- which designates the formal type, and the type of the component is this + -- access type. Finally the Entry_Component of each formal is set to + -- reference the corresponding record component. procedure Expand_N_Entry_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -6231,11 +6431,11 @@ package body Exp_Ch9 is ----------------------------- -- Protected bodies are expanded to the completion of the subprograms - -- created for the corresponding protected type. These are a protected - -- and unprotected version of each protected subprogram in the object, - -- a function to calculate each entry barrier, and a procedure to - -- execute the sequence of statements of each protected entry body. - -- For example, for protected type ptype: + -- created for the corresponding protected type. These are a protected and + -- unprotected version of each protected subprogram in the object, a + -- function to calculate each entry barrier, and a procedure to execute the + -- sequence of statements of each protected entry body. For example, for + -- protected type ptype: -- function entB -- (O : System.Address; @@ -6379,7 +6579,6 @@ package body Exp_Ch9 is Actuals := New_List; Formal := First (Parameter_Specifications (Spec)); - while Present (Formal) loop Append_To (Actuals, Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); @@ -6581,10 +6780,9 @@ package body Exp_Ch9 is Analyze (New_Op_Body); end if; - -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies - -- after the protected body. At this point the entry specs have been - -- created, frozen and included in the dispatch table for the - -- protected type. + -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after + -- the protected body. At this point the entry specs have been created, + -- frozen and included in the dispatch table for the protected type. pragma Assert (Present (Corresponding_Record_Type (Pid))); @@ -6600,10 +6798,10 @@ package body Exp_Ch9 is Wrap_Body : Node_Id; begin - -- Examine the visible declarations of the protected type, - -- looking for an entry declaration. We do not consider - -- entry families since they can not have dispatching - -- operations, thus they do not need entry wrappers. + -- Examine the visible declarations of the protected type, looking + -- for an entry declaration. We do not consider entry families + -- since they cannot have dispatching operations, thus they do not + -- need entry wrappers. while Present (Vis_Decl) loop if Nkind (Vis_Decl) = N_Entry_Declaration then @@ -6658,57 +6856,55 @@ package body Exp_Ch9 is -- <private data fields> -- end record; - -- The discriminants are present only if the corresponding protected - -- type has discriminants, and they exactly mirror the protected type - -- discriminants. The private data fields similarly mirror the - -- private declarations of the protected type. + -- The discriminants are present only if the corresponding protected type + -- has discriminants, and they exactly mirror the protected type + -- discriminants. The private data fields similarly mirror the private + -- declarations of the protected type. - -- The Object field is always present. It contains RTS specific data - -- used to control the protected object. It is declared as Aliased - -- so that it can be passed as a pointer to the RTS. This allows the - -- protected record to be referenced within RTS data structures. - -- An appropriate Protection type and discriminant are generated. + -- The Object field is always present. It contains RTS specific data used + -- to control the protected object. It is declared as Aliased so that it + -- can be passed as a pointer to the RTS. This allows the protected record + -- to be referenced within RTS data structures. An appropriate Protection + -- type and discriminant are generated. -- The Service field is present for protected objects with entries. It - -- contains sufficient information to allow the entry service procedure - -- for this object to be called when the object is not known till runtime. + -- contains sufficient information to allow the entry service procedure for + -- this object to be called when the object is not known till runtime. -- One entry_family component is present for each entry family in the -- task definition (see Expand_N_Task_Type_Declaration). -- When a protected object is declared, an instance of the protected type - -- value record is created. The elaboration of this declaration creates - -- the correct bounds for the entry families, and also evaluates the - -- priority expression if needed. The initialization routine for - -- the protected type itself then calls Initialize_Protection with - -- appropriate parameters to initialize the value of the Task_Id field. - -- Install_Handlers may be also called if a pragma Attach_Handler applies. - - -- Note: this record is passed to the subprograms created by the - -- expansion of protected subprograms and entries. It is an in parameter - -- to protected functions and an in out parameter to procedures and - -- entry bodies. The Entity_Id for this created record type is placed - -- in the Corresponding_Record_Type field of the associated protected - -- type entity. - - -- Next we create a procedure specifications for protected subprograms - -- and entry bodies. For each protected subprograms two subprograms are - -- created, an unprotected and a protected version. The unprotected - -- version is called from within other operations of the same protected - -- object. + -- value record is created. The elaboration of this declaration creates the + -- correct bounds for the entry families, and also evaluates the priority + -- expression if needed. The initialization routine for the protected type + -- itself then calls Initialize_Protection with appropriate parameters to + -- initialize the value of the Task_Id field. Install_Handlers may be also + -- called if a pragma Attach_Handler applies. + + -- Note: this record is passed to the subprograms created by the expansion + -- of protected subprograms and entries. It is an in parameter to protected + -- functions and an in out parameter to procedures and entry bodies. The + -- Entity_Id for this created record type is placed in the + -- Corresponding_Record_Type field of the associated protected type entity. + + -- Next we create a procedure specifications for protected subprograms and + -- entry bodies. For each protected subprograms two subprograms are + -- created, an unprotected and a protected version. The unprotected version + -- is called from within other operations of the same protected object. -- We also build the call to register the procedure if a pragma -- Interrupt_Handler applies. -- A single subprogram is created to service all entry bodies; it has an - -- additional boolean out parameter indicating that the previous entry - -- call made by the current task was serviced immediately, i.e. not by - -- proxy. The O parameter contains a pointer to a record object of the - -- type described above. An untyped interface is used here to allow this + -- additional boolean out parameter indicating that the previous entry call + -- made by the current task was serviced immediately, i.e. not by proxy. + -- The O parameter contains a pointer to a record object of the type + -- described above. An untyped interface is used here to allow this -- procedure to be called in places where the type of the object to be - -- serviced is not known. This must be done, for example, when a call - -- that may have been requeued is cancelled; the corresponding object - -- must be serviced, but which object that is not known till runtime. + -- serviced is not known. This must be done, for example, when a call that + -- may have been requeued is cancelled; the corresponding object must be + -- serviced, but which object that is not known till runtime. -- procedure ptypeS -- (O : System.Address; P : out Boolean); @@ -6724,9 +6920,8 @@ package body Exp_Ch9 is procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Prottyp : constant Entity_Id := Defining_Identifier (N); - Protnm : constant Name_Id := Chars (Prottyp); - Pdef : constant Node_Id := Protected_Definition (N); + Pdef : constant Node_Id := Protected_Definition (N); -- This contains two lists; one for visible and one for private decls Rec_Decl : Node_Id; @@ -6748,7 +6943,7 @@ package body Exp_Ch9 is Object_Comp : Node_Id; procedure Register_Handler; - -- for a protected operation that is an interrupt handler, add the + -- For a protected operation that is an interrupt handler, add the -- freeze action that will register it as such. ---------------------- @@ -6803,7 +6998,8 @@ package body Exp_Ch9 is -- corresponding record type must refer to the discriminants of that -- record, so we must apply a new renaming to subtypes_indications: - -- protected discriminant => discriminal => record discriminant. + -- protected discriminant => discriminal => record discriminant + -- This replacement is not applied to default expressions, for which -- the discriminal is correct. @@ -6811,11 +7007,9 @@ package body Exp_Ch9 is declare Disc : Entity_Id; Decl : Node_Id; - begin Disc := First_Discriminant (Prottyp); Decl := First (Discriminant_Specifications (Rec_Decl)); - while Present (Disc) loop Append_Elmt (Discriminal (Disc), Discr_Map); Append_Elmt (Defining_Identifier (Decl), Discr_Map); @@ -6827,15 +7021,14 @@ package body Exp_Ch9 is -- Fill in the component declarations - -- Add components for entry families. For each entry family, - -- create an anonymous type declaration with the same size, and - -- analyze the type. + -- Add components for entry families. For each entry family, create an + -- anonymous type declaration with the same size, and analyze the type. Collect_Entry_Families (Loc, Cdecls, Current_Node, Prottyp); - -- Prepend the _Object field with the right type to the component - -- list. We need to compute the number of entries, and in some cases - -- the number of Attach_Handler pragmas. + -- Prepend the _Object field with the right type to the component list. + -- We need to compute the number of entries, and in some cases the + -- number of Attach_Handler pragmas. declare Ritem : Node_Id; @@ -6892,8 +7085,7 @@ package body Exp_Ch9 is Sloc => Loc, Constraints => New_List (Entry_Count_Expr))); - -- The type has explicit entries or generated primitive entry - -- wrappers. + -- Type has explicit entries or generated primitive entry wrappers elsif Has_Entries (Prottyp) or else (Ada_Version >= Ada_05 @@ -7039,7 +7231,7 @@ package body Exp_Ch9 is begin -- Examine the visible declarations of the protected type, looking -- for declarations of entries, and subprograms. We do not - -- consider entry families since they can not have dispatching + -- consider entry families since they cannot have dispatching -- operations, thus they do not need entry wrappers. Vis_Decl := First (Visible_Declarations (Pdef)); @@ -7096,12 +7288,12 @@ package body Exp_Ch9 is Entries_Aggr := Empty; end if; - -- Build two new procedure specifications for each protected - -- subprogram; one to call from outside the object and one to - -- call from inside. Build a barrier function and an entry - -- body action procedure specification for each protected entry. - -- Initialize the entry body array. If subprogram is flagged as - -- eliminated, do not generate any internal operations. + -- Build two new procedure specifications for each protected subprogram; + -- one to call from outside the object and one to call from inside. + -- Build a barrier function and an entry body action procedure + -- specification for each protected entry. Initialize the entry body + -- array. If subprogram is flagged as eliminated, do not generate any + -- internal operations. E_Count := 0; @@ -7124,8 +7316,8 @@ package body Exp_Ch9 is (Defining_Unit_Name (Specification (Comp)), Defining_Unit_Name (Specification (Sub))); - -- Make the protected version of the subprogram available - -- for expansion of external calls. + -- Make the protected version of the subprogram available for + -- expansion of external calls. Current_Node := Sub; @@ -7160,9 +7352,10 @@ package body Exp_Ch9 is Current_Node := Sub; end if; - -- If a pragma Interrupt_Handler applies, build and add - -- a call to Register_Interrupt_Handler to the freezing actions - -- of the protected version (Current_Node) of the subprogram: + -- If a pragma Interrupt_Handler applies, build and add a call to + -- Register_Interrupt_Handler to the freezing actions of the + -- protected version (Current_Node) of the subprogram: + -- system.interrupts.register_interrupt_handler -- (prot_procP'address); @@ -7179,10 +7372,7 @@ package body Exp_Ch9 is Set_Privals_Chain (Comp_Id, New_Elmt_List); Edef := Make_Defining_Identifier (Loc, - Build_Selected_Name - (Protnm, - New_External_Name (Chars (Comp_Id), Suffix_Index => -1), - 'E')); + Build_Selected_Name (Prottyp, Comp_Id, 'E')); Sub := Make_Subprogram_Declaration (Loc, Specification => @@ -7199,10 +7389,7 @@ package body Exp_Ch9 is Bdef := Make_Defining_Identifier (Loc, - Build_Selected_Name - (Protnm, - New_External_Name (Chars (Comp_Id), Suffix_Index => -1), - 'B')); + Build_Selected_Name (Prottyp, Comp_Id, 'B')); Sub := Make_Subprogram_Declaration (Loc, Specification => @@ -7246,10 +7433,7 @@ package body Exp_Ch9 is Set_Privals_Chain (Comp_Id, New_Elmt_List); Edef := Make_Defining_Identifier (Loc, - Build_Selected_Name - (Protnm, - New_External_Name (Chars (Comp_Id), Suffix_Index => -1), - 'E')); + Build_Selected_Name (Prottyp, Comp_Id, 'E')); Sub := Make_Subprogram_Declaration (Loc, @@ -7267,10 +7451,8 @@ package body Exp_Ch9 is Bdef := Make_Defining_Identifier (Loc, - Build_Selected_Name - (Protnm, - New_External_Name (Chars (Comp_Id), Suffix_Index => -1), - 'B')); + Build_Selected_Name (Prottyp, Comp_Id, 'E')); + Sub := Make_Subprogram_Declaration (Loc, Specification => @@ -7283,9 +7465,8 @@ package body Exp_Ch9 is Set_Scope (Bdef, Scope (Comp_Id)); Current_Node := Sub; - -- Collect pointers to the protected subprogram and the - -- barrier of the current entry, for insertion into - -- Entry_Bodies_Array. + -- Collect pointers to the protected subprogram and the barrier + -- of the current entry, for insertion into Entry_Bodies_Array. Append ( Make_Aggregate (Loc, @@ -7345,9 +7526,8 @@ package body Exp_Ch9 is Attribute_Name => Name_Unrestricted_Access)))); end if; - -- A pointer to this array will be placed in the corresponding - -- record by its initialization procedure, so this needs to be - -- analyzed here. + -- A pointer to this array will be placed in the corresponding record + -- by its initialization procedure so this needs to be analyzed here. Insert_After (Current_Node, Body_Arr); Current_Node := Body_Arr; @@ -7378,11 +7558,11 @@ package body Exp_Ch9 is -------------------------------- -- A requeue statement is expanded into one of four GNARLI operations, - -- depending on the source and destination (task or protected object). - -- In addition, code must be generated to jump around the remainder of - -- processing for the original entry and, if the destination is a - -- (different) protected object, to attempt to service it. - -- The following illustrates the various cases: + -- depending on the source and destination (task or protected object). In + -- addition, code must be generated to jump around the remainder of + -- processing for the original entry and, if the destination is (different) + -- protected object, to attempt to service it. The following illustrates + -- the various cases: -- procedure entE -- (O : System.Address; @@ -7539,8 +7719,8 @@ package body Exp_Ch9 is Prepend (Self_Param, Params); exit; - -- If neither task type or protected type, must be in some - -- inner enclosing block, so move on out + -- If neither task type or protected type, must be in some inner + -- enclosing block, so move on out else Oldtyp := Scope (Oldtyp); @@ -7573,8 +7753,8 @@ package body Exp_Ch9 is end loop; -- The last statement is the second label, used for completing the - -- rendezvous the usual way. - -- The label we are looking for is right before it. + -- rendezvous the usual way. The label we are looking for is right + -- before it. Lab_Node := Prev (Last (Statements (Handled_Statement_Sequence (Acc_Stat)))); @@ -7825,9 +8005,9 @@ package body Exp_Ch9 is -- During the analysis of the body of the accept statement, any -- zero cost exception handler records were collected in the - -- Accept_Handler_Records field of the N_Accept_Alternative - -- node. This is where we move them to where they belong, - -- namely the newly created procedure. + -- Accept_Handler_Records field of the N_Accept_Alternative node. + -- This is where we move them to where they belong, namely the + -- newly created procedure. Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt)); Append (Proc_Body, Body_List); @@ -7835,8 +8015,8 @@ package body Exp_Ch9 is else Null_Body := New_Reference_To (Standard_True, Loc); - -- if accept statement has declarations, insert above, given - -- that we are not creating a body for the accept. + -- if accept statement has declarations, insert above, given that + -- we are not creating a body for the accept. if Present (Declarations (Acc_Stm)) then Insert_Actions (N, Declarations (Acc_Stm)); @@ -7931,9 +8111,9 @@ package body Exp_Ch9 is Alt_Stats := New_List; end if; - -- After the call, if any, branch to to trailing statements. - -- We create a label for each, as well as the corresponding - -- label declaration. + -- After the call, if any, branch to to trailing statements. We + -- create a label for each, as well as the corresponding label + -- declaration. Lab := Make_And_Declare_Label (Index); Append_To (Alt_Stats, @@ -8067,8 +8247,8 @@ package body Exp_Ch9 is Append_List (Delay_Alt, Delay_List); - -- If the delay alternative has a statement part, add a - -- choice to the case statements for delays. + -- If the delay alternative has a statement part, add choice to the + -- case statements for delays. if Present (Statements (Alt)) then @@ -8437,14 +8617,12 @@ package body Exp_Ch9 is Discrete_Choices => Choices, Statements => Alt_Stats)); - -- We make use of the fact that Accept_Index is an integer type, - -- and generate successive literals for entries for each accept. - -- Only those for which there is a body or trailing statements are - -- given a case entry. + -- We make use of the fact that Accept_Index is an integer type, and + -- generate successive literals for entries for each accept. Only those + -- for which there is a body or trailing statements get a case entry. Alt := First (Select_Alternatives (N)); Proc := First (Body_List); - while Present (Alt) loop if Nkind (Alt) = N_Accept_Alternative then @@ -8587,8 +8765,8 @@ package body Exp_Ch9 is Name => New_Reference_To (RTE (RE_Timed_Selective_Wait), Loc), Parameter_Associations => Parms)); - -- This new call should follow the calculation of the - -- minimum delay. + -- This new call should follow the calculation of the minimum + -- delay. Insert_List_Before (Select_Call, Delay_List); @@ -8652,9 +8830,9 @@ package body Exp_Ch9 is -------------------------------------- -- Single task declarations should never be present after semantic - -- analysis, since we expect them to be replaced by a declaration of - -- an anonymous task type, followed by a declaration of the task - -- object. We include this routine to make sure that is happening! + -- analysis, since we expect them to be replaced by a declaration of an + -- anonymous task type, followed by a declaration of the task object. We + -- include this routine to make sure that is happening! procedure Expand_N_Single_Task_Declaration (N : Node_Id) is begin @@ -8699,16 +8877,16 @@ package body Exp_Ch9 is -- tnameE := True; - -- In addition, if the task body is an activator, then a call to - -- activate tasks is added at the start of the statements, before - -- the call to Complete_Activation, and if in addition the task is - -- a master then it must be established as a master. These calls are - -- inserted and analyzed in Expand_Cleanup_Actions, when the - -- Handled_Sequence_Of_Statements is expanded. + -- In addition, if the task body is an activator, then a call to activate + -- tasks is added at the start of the statements, before the call to + -- Complete_Activation, and if in addition the task is a master then it + -- must be established as a master. These calls are inserted and analyzed + -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is + -- expanded. -- There is one discriminal declaration line generated for each - -- discriminant that is present to provide an easy reference point - -- for discriminant references inside the body (see Exp_Ch2.Expand_Name). + -- discriminant that is present to provide an easy reference point for + -- discriminant references inside the body (see Exp_Ch2.Expand_Name). -- Note on relationship to GNARLI definition. In the GNARLI definition, -- task body procedures have a profile (Arg : System.Address). That is @@ -8777,9 +8955,8 @@ package body Exp_Ch9 is Rewrite (N, New_N); Analyze (N); - -- Set elaboration flag immediately after task body. If the body - -- is a subunit, the flag is set in the declarative part that - -- contains the stub. + -- Set elaboration flag immediately after task body. If the body is a + -- subunit, the flag is set in the declarative part containing the stub. if Nkind (Parent (N)) /= N_Subunit then Insert_After (N, @@ -8789,10 +8966,9 @@ package body Exp_Ch9 is Expression => New_Reference_To (Standard_True, Loc))); end if; - -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies - -- after the task body. At this point the entry specs have been - -- created, frozen and included in the dispatch table for the task - -- type. + -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after + -- the task body. At this point the entry specs have been created, + -- frozen and included in the dispatch table for the task type. pragma Assert (Present (Corresponding_Record_Type (Ttyp))); @@ -8814,10 +8990,10 @@ package body Exp_Ch9 is Current_Node := N; end if; - -- Examine the visible declarations of the task type, - -- looking for an entry declaration. We do not consider - -- entry families since they can not have dispatching - -- operations, thus they do not need entry wrappers. + -- Examine the visible declarations of the task type, looking for + -- an entry declaration. We do not consider entry families since + -- they cannot have dispatching operations, thus they do not need + -- entry wrappers. while Present (Vis_Decl) loop if Nkind (Vis_Decl) = N_Entry_Declaration @@ -8858,8 +9034,8 @@ package body Exp_Ch9 is -- taskE : aliased Boolean := False; - -- Next a variable is declared to hold the task stack size (either - -- the default : Unspecified_Size, or a value that is set by a pragma + -- Next a variable is declared to hold the task stack size (either the + -- default : Unspecified_Size, or a value that is set by a pragma -- Storage_Size). If the value of the pragma Storage_Size is static, then -- the variable is initialized with this value: @@ -8881,28 +9057,28 @@ package body Exp_Ch9 is -- The discriminants are present only if the corresponding task type has -- discriminants, and they exactly mirror the task type discriminants. - -- The Id field is always present. It contains the Task_Id value, as - -- set by the call to Create_Task. Note that although the task is - -- limited, the task value record type is not limited, so there is no - -- problem in passing this field as an out parameter to Create_Task. + -- The Id field is always present. It contains the Task_Id value, as set by + -- the call to Create_Task. Note that although the task is limited, the + -- task value record type is not limited, so there is no problem in passing + -- this field as an out parameter to Create_Task. - -- One entry_family component is present for each entry family in the - -- task definition. The bounds correspond to the bounds of the entry - -- family (which may depend on discriminants). The element type is - -- void, since we only need the bounds information for determining - -- the entry index. Note that the use of an anonymous array would - -- normally be illegal in this context, but this is a parser check, - -- and the semantics is quite prepared to handle such a case. - - -- The _Size field is present only if a Storage_Size pragma appears in - -- the task definition. The expression captures the argument that was - -- present in the pragma, and is used to override the task stack size - -- otherwise associated with the task type. + -- One entry_family component is present for each entry family in the task + -- definition. The bounds correspond to the bounds of the entry family + -- (which may depend on discriminants). The element type is void, since we + -- only need the bounds information for determining the entry index. Note + -- that the use of an anonymous array would normally be illegal in this + -- context, but this is a parser check, and the semantics is quite prepared + -- to handle such a case. + + -- The _Size field is present only if a Storage_Size pragma appears in the + -- task definition. The expression captures the argument that was present + -- in the pragma, and is used to override the task stack size otherwise + -- associated with the task type. -- The _Priority field is present only if a Priority or Interrupt_Priority -- pragma appears in the task definition. The expression captures the - -- argument that was present in the pragma, and is used to provide - -- the Size parameter to the call to Create_Task. + -- argument that was present in the pragma, and is used to provide the Size + -- parameter to the call to Create_Task. -- The _Task_Info field is present only if a Task_Info pragma appears in -- the task definition. The expression captures the argument that was @@ -8910,18 +9086,18 @@ package body Exp_Ch9 is -- to the call to Create_Task. -- When a task is declared, an instance of the task value record is - -- created. The elaboration of this declaration creates the correct - -- bounds for the entry families, and also evaluates the size, priority, - -- and task_Info expressions if needed. The initialization routine for - -- the task type itself then calls Create_Task with appropriate - -- parameters to initialize the value of the Task_Id field. + -- created. The elaboration of this declaration creates the correct bounds + -- for the entry families, and also evaluates the size, priority, and + -- task_Info expressions if needed. The initialization routine for the task + -- type itself then calls Create_Task with appropriate parameters to + -- initialize the value of the Task_Id field. -- Note: the address of this record is passed as the "Discriminants" - -- parameter for Create_Task. Since Create_Task merely passes this onto - -- the body procedure, it does not matter that it does not quite match - -- the GNARLI model of what is being passed (the record contains more - -- than just the discriminants, but the discriminants can be found from - -- the record value). + -- parameter for Create_Task. Since Create_Task merely passes this onto the + -- body procedure, it does not matter that it does not quite match the + -- GNARLI model of what is being passed (the record contains more than just + -- the discriminants, but the discriminants can be found from the record + -- value). -- The Entity_Id for this created record type is placed in the -- Corresponding_Record_Type field of the associated task type entity. @@ -9023,9 +9199,9 @@ package body Exp_Ch9 is Insert_After (Elab_Decl, Size_Decl); - -- Next build the rest of the corresponding record declaration. - -- This is done last, since the corresponding record initialization - -- procedure will reference the previously created entities. + -- Next build the rest of the corresponding record declaration. This is + -- done last, since the corresponding record initialization procedure + -- will reference the previously created entities. -- Fill in the component declarations -- first the _Task_Id field @@ -9039,8 +9215,8 @@ package body Exp_Ch9 is Subtype_Indication => New_Reference_To (RTE (RO_ST_Task_Id), Loc)))); - -- Declare static ATCB (that is, created by the expander) if we - -- are using the Restricted run time. + -- Declare static ATCB (that is, created by the expander) if we are + -- using the Restricted run time. if Restricted_Profile then Append_To (Cdecls, @@ -9062,8 +9238,8 @@ package body Exp_Ch9 is end if; - -- Declare static stack (that is, created by the expander) if we - -- are using the Restricted run time on a bare board configuration. + -- Declare static stack (that is, created by the expander) if we are + -- using the Restricted run time on a bare board configuration. if Restricted_Profile and then Preallocated_Stacks_On_Target @@ -9102,8 +9278,8 @@ package body Exp_Ch9 is Append_To (Cdecls, Decl_Stack); - -- The appropriate alignment for the stack is ensured by the - -- run-time code in charge of task creation. + -- The appropriate alignment for the stack is ensured by the run-time + -- code in charge of task creation. end if; @@ -9218,14 +9394,14 @@ package body Exp_Ch9 is Insert_After (Rec_Decl, Body_Decl); - -- The subprogram does not comes from source, so we have to indicate - -- the need for debugging information explicitly. + -- The subprogram does not comes from source, so we have to indicate the + -- need for debugging information explicitly. Set_Needs_Debug_Info (Defining_Entity (Proc_Spec), Comes_From_Source (Original_Node (N))); - -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs - -- before the corresponding record has been frozen. + -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before + -- the corresponding record has been frozen. if Ada_Version >= Ada_05 and then Present (Taskdef) @@ -9242,10 +9418,10 @@ package body Exp_Ch9 is New_N : Node_Id; begin - -- Examine the visible declarations of the task type, - -- looking for an entry declaration. We do not consider - -- entry families since they can not have dispatching - -- operations, thus they do not need entry wrappers. + -- Examine the visible declarations of the task type, looking for + -- an entry declaration. We do not consider entry families since + -- they cannot have dispatching operations, thus they do not need + -- entry wrappers. while Present (Vis_Decl) loop if Nkind (Vis_Decl) = N_Entry_Declaration @@ -9295,8 +9471,8 @@ package body Exp_Ch9 is end; end if; - -- Complete the expansion of access types to the current task - -- type, if any were declared. + -- Complete the expansion of access types to the current task type, if + -- any were declared. Expand_Previous_Access_Type (Tasktyp); end Expand_N_Task_Type_Declaration; @@ -9305,8 +9481,8 @@ package body Exp_Ch9 is -- Expand_N_Timed_Entry_Call -- ------------------------------- - -- A timed entry call in normal case is not implemented using ATC - -- mechanism anymore for efficiency reason. + -- A timed entry call in normal case is not implemented using ATC mechanism + -- anymore for efficiency reason. -- select -- T.E; @@ -9421,12 +9597,13 @@ package body Exp_Ch9 is Params : List_Id; Stmt : Node_Id; Stmts : List_Id; + Unpack : List_Id; B : Entity_Id; -- Call status flag C : Entity_Id; -- Call kind D : Entity_Id; -- Delay M : Entity_Id; -- Delay mode - P : Node_Id; -- Parameter block + P : Entity_Id; -- Parameter block S : Entity_Id; -- Primitive operation slot begin @@ -9576,9 +9753,11 @@ package body Exp_Ch9 is -- Dispatch table slot processing, generate: -- S : constant Integer := - -- DT_Prosition (<dispatching-procedure>) + -- Ada.Tags.Get_Offset_Index ( + -- Unchecked_Convert_To (Ada.Tags.Interface_Tag, Obj), + -- DT_Position (<dispatching-procedure>)); - S := SEU.Build_S (Loc, Decls, Call_Ent); + S := SEU.Build_S (Loc, Decls, Obj, Call_Ent); -- Generate: -- _dispatching_timed_select (Obj, S, P'address, D, M, C, B); @@ -9592,7 +9771,9 @@ package body Exp_Ch9 is Append_To (Params, New_Copy_Tree (Obj)); Append_To (Params, New_Reference_To (S, Loc)); - Append_To (Params, P); + Append_To (Params, Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P, Loc), + Attribute_Name => Name_Address)); Append_To (Params, New_Reference_To (D, Loc)); Append_To (Params, New_Reference_To (M, Loc)); Append_To (Params, New_Reference_To (C, Loc)); @@ -9601,7 +9782,10 @@ package body Exp_Ch9 is Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => - Make_Identifier (Loc, Name_uDisp_Timed_Select), + New_Reference_To ( + Find_Prim_Op (Etype (Etype (Obj)), + Name_uDisp_Timed_Select), + Loc), Parameter_Associations => Params)); @@ -9614,28 +9798,36 @@ package body Exp_Ch9 is -- ParamN := P.ParamN; -- end if; - Append_To (Stmts, - Make_If_Statement (Loc, + Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); - Condition => - Make_Or_Else (Loc, - Left_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To (C, Loc), - Right_Opnd => - New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)), - Right_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To (C, Loc), - Right_Opnd => - New_Reference_To (RTE (RE_POK_Task_Entry), Loc))), + -- Generate the if statement only when the packed parameters need + -- explicit assignments to their corresponding actuals. - Then_Statements => - Parameter_Block_Unpack (Loc, Actuals, Formals))); + if Present (Unpack) then + Append_To (Stmts, + Make_If_Statement (Loc, + + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Protected_Entry), Loc)), + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Task_Entry), Loc))), + + Then_Statements => Unpack)); + end if; -- Generate: + -- if B then -- if C = POK_Procedure -- or else C = POK_Protected_Procedure @@ -9648,7 +9840,7 @@ package body Exp_Ch9 is -- <delay-statements> -- end if; - N_Stats := New_Copy_List (E_Stats); + N_Stats := New_Copy_List_Tree (E_Stats); Prepend_To (N_Stats, Make_If_Statement (Loc, @@ -9802,18 +9994,18 @@ package body Exp_Ch9 is -- Expand_Protected_Body_Declarations -- ---------------------------------------- - -- Part of the expansion of a protected body involves the creation of - -- a declaration that can be referenced from the statement sequences of - -- the entry bodies: + -- Part of the expansion of a protected body involves the creation of a + -- declaration that can be referenced from the statement sequences of the + -- entry bodies: -- A : Address; - -- This declaration is inserted in the declarations of the service - -- entries procedure for the protected body, and it is important that - -- it be inserted before the statements of the entry body statement - -- sequences are analyzed. Thus it would be too late to create this - -- declaration in the Expand_N_Protected_Body routine, which is why - -- there is a separate procedure to be called directly from Sem_Ch9. + -- This declaration is inserted in the declarations of the service entries + -- procedure for the protected body, and it is important that it be + -- inserted before the statements of the entry body statement sequences are + -- analyzed. Thus it would be too late to create this declaration in the + -- Expand_N_Protected_Body routine, which is why there is a separate + -- procedure to be called directly from Sem_Ch9. -- Ann is used to hold the address of the record containing the parameters -- (see Expand_N_Entry_Call for more details on how this record is built). @@ -9824,14 +10016,14 @@ package body Exp_Ch9 is -- Accept_Address stack in the corresponding entry entity, and this element -- must be set in place before the statements are processed. - -- No stack is needed for entry bodies, since they cannot be nested, but - -- it is kept for consistency between protected and task entries. The - -- stack will never contain more than one element. There is also only one - -- such variable for a given protected body, but this is placed on the + -- No stack is needed for entry bodies, since they cannot be nested, but it + -- is kept for consistency between protected and task entries. The stack + -- will never contain more than one element. There is also only one such + -- variable for a given protected body, but this is placed on the -- Accept_Address stack of all of the entries, again for consistency. - -- To expand the requeue statement, a label is provided at the end of - -- the loop in the entry service routine created by the expander (see + -- To expand the requeue statement, a label is provided at the end of the + -- loop in the entry service routine created by the expander (see -- Expand_N_Protected_Body for details), so that the statement can be -- skipped after the requeue is complete. This label is created during the -- expansion of the entry body, which will take place after the expansion @@ -9859,9 +10051,9 @@ package body Exp_Ch9 is elsif Expander_Active then - -- Associate privals with the first subprogram or entry - -- body to be expanded. These are used to expand references - -- to private data objects. + -- Associate privals with the first subprogram or entry body to be + -- expanded. These are used to expand references to private data + -- objects. Op := First_Protected_Operation (Declarations (N)); @@ -9991,12 +10183,11 @@ package body Exp_Ch9 is Ttyp : Entity_Id) return Node_Id is function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; - -- If one of the bounds is a reference to a discriminant, replace - -- with corresponding discriminal of type. Within the body of a task - -- retrieve the renamed discriminant by simple visibility, using its - -- generated name. Within a protected object, find the original dis- - -- criminant and replace it with the discriminal of the current prot- - -- ected operation. + -- If one of the bounds is a reference to a discriminant, replace with + -- corresponding discriminal of type. Within the body of a task retrieve + -- the renamed discriminant by simple visibility, using its generated + -- name. Within a protected object, find the original dis- criminant and + -- replace it with the discriminal of the current prot- ected operation. ------------------------------ -- Convert_Discriminant_Ref -- @@ -10019,7 +10210,6 @@ package body Exp_Ch9 is elsif Is_Protected_Type (Ttyp) then D := First_Discriminant (Ttyp); - while Chars (D) /= Chars (Entity (Bound)) loop Next_Discriminant (D); end loop; @@ -10097,7 +10287,6 @@ package body Exp_Ch9 is begin N := First (Visible_Declarations (T)); - while Present (N) loop if Nkind (N) = N_Pragma then if Chars (N) = P then @@ -10118,7 +10307,6 @@ package body Exp_Ch9 is end loop; N := First (Private_Declarations (T)); - while Present (N) loop if Nkind (N) = N_Pragma then if Chars (N) = P then @@ -10178,10 +10366,9 @@ package body Exp_Ch9 is Lo : Node_Id := Type_Low_Bound (Etype (Index_Id)); function Replace_Discriminant (Bound : Node_Id) return Node_Id; - -- The bounds of the entry index may depend on discriminants, so - -- each declaration of an entry_index_constant must have its own - -- subtype declaration, using the local renaming of the object discri- - -- minant. + -- The bounds of the entry index may depend on discriminants, so each + -- declaration of an entry_index_constant must have its own subtype + -- declaration, using the local renaming of the object discriminant. -------------------------- -- Replace_Discriminant -- @@ -10285,22 +10472,20 @@ package body Exp_Ch9 is Restricted : constant Boolean := Restricted_Profile; begin - -- We may need two calls to properly initialize the object, one - -- to Initialize_Protection, and possibly one to Install_Handlers - -- if we have a pragma Attach_Handler. + -- We may need two calls to properly initialize the object, one to + -- Initialize_Protection, and possibly one to Install_Handlers if we + -- have a pragma Attach_Handler. -- Get protected declaration. In the case of a task type declaration, - -- this is simply the parent of the protected type entity. - -- In the single protected object - -- declaration, this parent will be the implicit type, and we can find - -- the corresponding single protected object declaration by - -- searching forward in the declaration list in the tree. - -- ??? I am not sure that the test for N_Single_Protected_Declaration - -- is needed here. Nodes of this type should have been removed - -- during semantic analysis. + -- this is simply the parent of the protected type entity. In the single + -- protected object declaration, this parent will be the implicit type, + -- and we can find the corresponding single protected object declaration + -- by searching forward in the declaration list in the tree. - Pdec := Parent (Ptyp); + -- Is the test for N_Single_Protected_Declaration needed here??? Nodes + -- of this type should have been removed during semantic analysis. + Pdec := Parent (Ptyp); while Nkind (Pdec) /= N_Protected_Type_Declaration and then Nkind (Pdec) /= N_Single_Protected_Declaration loop @@ -10378,10 +10563,11 @@ package body Exp_Ch9 is end if; if Has_Entry then + -- Entry_Bodies parameter. This is a pointer to an array of - -- pointers to the entry body procedures and barrier functions - -- of the object. If the protected type has no entries this - -- object will not exist; in this case, pass a null. + -- pointers to the entry body procedures and barrier functions of + -- the object. If the protected type has no entries this object + -- will not exist; in this case, pass a null. P_Arr := Entry_Bodies_Array (Ptyp); @@ -10446,11 +10632,14 @@ package body Exp_Ch9 is if Has_Attach_Handler (Ptyp) then - -- We have a list of N Attach_Handler (ProcI, ExprI), - -- and we have to make the following call: + -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to + -- make the following call: + -- Install_Handlers (_object, -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); + -- or, in the case of Ravenscar: + -- Install_Handlers -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); @@ -10461,6 +10650,7 @@ package body Exp_Ch9 is begin if not Restricted then + -- Appends the _object argument Append_To (Args, @@ -10536,17 +10726,16 @@ package body Exp_Ch9 is Ttyp := Corresponding_Concurrent_Type (Task_Rec); Tnam := Chars (Ttyp); - -- Get task declaration. In the case of a task type declaration, this - -- is simply the parent of the task type entity. In the single task + -- Get task declaration. In the case of a task type declaration, this is + -- simply the parent of the task type entity. In the single task -- declaration, this parent will be the implicit type, and we can find - -- the corresponding single task declaration by searching forward in - -- the declaration list in the tree. - -- ??? I am not sure that the test for N_Single_Task_Declaration - -- is needed here. Nodes of this type should have been removed - -- during semantic analysis. + -- the corresponding single task declaration by searching forward in the + -- declaration list in the tree. - Tdec := Parent (Ttyp); + -- Is the test for N_Single_Task_Declaration needed here??? Nodes of + -- this type should have been removed during semantic analysis. + Tdec := Parent (Ttyp); while Nkind (Tdec) /= N_Task_Type_Declaration and then Nkind (Tdec) /= N_Single_Task_Declaration loop @@ -10741,7 +10930,6 @@ package body Exp_Ch9 is begin Next_Op := Next (N); - while Present (Next_Op) and then Nkind (Next_Op) /= N_Subprogram_Body and then Nkind (Next_Op) /= N_Entry_Body @@ -10764,12 +10952,14 @@ package body Exp_Ch9 is Decls : List_Id; Stmts : List_Id) return Node_Id is - Actual : Entity_Id; - Blk_Nam : Node_Id; - Formal : Entity_Id; - Params : List_Id; - Temp_Asn : Node_Id; - Temp_Nam : Node_Id; + Actual : Entity_Id; + Expr : Node_Id := Empty; + Formal : Entity_Id; + Has_Param : Boolean := False; + P : Entity_Id; + Params : List_Id; + Temp_Asn : Node_Id; + Temp_Nam : Node_Id; begin Actual := First (Actuals); @@ -10820,41 +11010,46 @@ package body Exp_Ch9 is Name_Unchecked_Access, Prefix => New_Reference_To (Temp_Nam, Loc))); + + Has_Param := True; + + -- The controlling parameter is omitted + else - Append_To (Params, - Make_Reference (Loc, New_Copy_Tree (Actual))); + if not Is_Controlling_Actual (Actual) then + Append_To (Params, + Make_Reference (Loc, New_Copy_Tree (Actual))); + + Has_Param := True; + end if; end if; Next_Actual (Actual); Next_Formal_With_Extras (Formal); end loop; + if Has_Param then + Expr := Make_Aggregate (Loc, Params); + end if; + -- Generate: -- P : Ann := ( -- J1'unchecked_access; -- <actual2>'reference; -- ...); - Blk_Nam := Make_Defining_Identifier (Loc, Name_uP); + P := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => - Blk_Nam, + P, Object_Definition => New_Reference_To (Blk_Typ, Loc), Expression => - Make_Aggregate (Loc, Params))); - - -- Return: - -- P'address + Expr)); - return - Make_Attribute_Reference (Loc, - Attribute_Name => - Name_Address, - Prefix => - New_Reference_To (Blk_Nam, Loc)); + return P; end Parameter_Block_Pack; ---------------------------- @@ -10863,26 +11058,23 @@ package body Exp_Ch9 is function Parameter_Block_Unpack (Loc : Source_Ptr; + P : Entity_Id; Actuals : List_Id; Formals : List_Id) return List_Id is - Actual : Entity_Id; - Asnmt : Node_Id; - Formal : Entity_Id; - Result : constant List_Id := New_List; - - At_Least_One_Asnmt : Boolean := False; + Actual : Entity_Id; + Asnmt : Node_Id; + Formal : Entity_Id; + Has_Asnmt : Boolean := False; + Result : constant List_Id := New_List; begin Actual := First (Actuals); Formal := Defining_Identifier (First (Formals)); - while Present (Actual) loop if Is_By_Copy_Type (Etype (Actual)) and then Ekind (Formal) /= E_In_Parameter then - At_Least_One_Asnmt := True; - -- Generate: -- <actual> := P.<formal>; @@ -10894,24 +11086,25 @@ package body Exp_Ch9 is Make_Explicit_Dereference (Loc, Make_Selected_Component (Loc, Prefix => - Make_Identifier (Loc, Name_uP), + New_Reference_To (P, Loc), Selector_Name => Make_Identifier (Loc, Chars (Formal))))); Set_Assignment_OK (Name (Asnmt)); - Append_To (Result, Asnmt); + + Has_Asnmt := True; end if; Next_Actual (Actual); Next_Formal_With_Extras (Formal); end loop; - if At_Least_One_Asnmt then + if Has_Asnmt then return Result; + else + return New_List (Make_Null_Statement (Loc)); end if; - - return New_List (Make_Null_Statement (Loc)); end Parameter_Block_Unpack; ---------------------- @@ -10950,15 +11143,19 @@ package body Exp_Ch9 is ----------------- procedure Set_Privals - (Dec : Node_Id; - Op : Node_Id; - Loc : Source_Ptr) + (Dec : Node_Id; + Op : Node_Id; + Loc : Source_Ptr; + After_Barrier : Boolean := False) is - P_Decl : Node_Id; - P_Id : Entity_Id; - Priv : Entity_Id; - Def : Node_Id; - Body_Ent : Entity_Id; + P_Decl : Node_Id; + P_Id : Entity_Id; + Priv : Entity_Id; + Def : Node_Id; + Body_Ent : Entity_Id; + For_Barrier : constant Boolean := + Nkind (Op) = N_Entry_Body and then not After_Barrier; + Prec_Decl : constant Node_Id := Parent (Corresponding_Record_Type (Defining_Identifier (Dec))); @@ -10976,15 +11173,20 @@ package body Exp_Ch9 is Def := Protected_Definition (Dec); if Present (Private_Declarations (Def)) then - P_Decl := First (Private_Declarations (Def)); - while Present (P_Decl) loop if Nkind (P_Decl) = N_Component_Declaration then P_Id := Defining_Identifier (P_Decl); - Priv := - Make_Defining_Identifier (Loc, - New_External_Name (Chars (P_Id), 'P')); + + if For_Barrier then + Priv := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (P_Id), 'P')); + else + Priv := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (P_Id))); + end if; Set_Ekind (Priv, E_Variable); Set_Etype (Priv, Etype (P_Id)); @@ -11075,7 +11277,6 @@ package body Exp_Ch9 is if Is_Entity_Name (N) then declare E : constant Entity_Id := Entity (N); - begin if Present (E) and then (Ekind (E) = E_Constant diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 044f56d..baa5036 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -311,13 +311,21 @@ package Exp_Ch9 is -- protected type. procedure Set_Privals - (Dec : Node_Id; - Op : Node_Id; - Loc : Source_Ptr); + (Dec : Node_Id; + Op : Node_Id; + Loc : Source_Ptr; + After_Barrier : Boolean := False); -- Associates a new set of privals (placeholders for later access to -- private components of protected objects) with the private object -- declarations of a protected object. These will be used to expand -- the references to private objects in the next protected -- subprogram or entry body to be expanded. + -- + -- The flag After_Barrier indicates whether this is called after building + -- the barrier function for an entry body. This flag determines whether + -- the privals should have source names (which simplifies debugging) or + -- internally generated names. Entry barriers contain no debuggable code, + -- and there may be visibility conflicts between an entry index and a + -- a prival, so privals for barrier function have internal names. end Exp_Ch9; diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index e7bdcc4..8281f15 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2005, 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- -- @@ -134,7 +134,7 @@ package body Exp_Dbug is -- used to determine whether encoding is required for a discrete type. procedure Output_Homonym_Numbers_Suffix; - -- If homonym numbers are stored, then output them into Name_Buffer. + -- If homonym numbers are stored, then output them into Name_Buffer procedure Prepend_String_To_Buffer (S : String); -- Prepend given string to the contents of the string buffer, updating @@ -250,9 +250,9 @@ package body Exp_Dbug is then return True; - -- Here we check if the static bounds match the natural size, which - -- is the size passed through with the debugging information. This - -- is the Esize rounded up to 8, 16, 32 or 64 as appropriate. + -- Here we check if the static bounds match the natural size, which is + -- the size passed through with the debugging information. This is the + -- Esize rounded up to 8, 16, 32 or 64 as appropriate. else declare @@ -305,12 +305,12 @@ package body Exp_Dbug is Def : Entity_Id; function Output_Subscript (N : Node_Id; S : String) return Boolean; - -- Outputs a single subscript value as ?nnn (subscript is compile - -- time known value with value nnn) or as ?e (subscript is local - -- constant with name e), where S supplies the proper string to - -- use for ?. Returns False if the subscript is not of an appropriate - -- type to output in one of these two forms. The result is prepended - -- to the name stored in Name_Buffer. + -- Outputs a single subscript value as ?nnn (subscript is compile time + -- known value with value nnn) or as ?e (subscript is local constant + -- with name e), where S supplies the proper string to use for ?. + -- Returns False if the subscript is not of an appropriate type to + -- output in one of these two forms. The result is prepended to the + -- name stored in Name_Buffer. ---------------------- -- Output_Subscript -- @@ -358,9 +358,9 @@ package body Exp_Dbug is when N_Package_Renaming_Declaration => Add_Str_To_Name_Buffer ("___XRP"); - -- If it is a child unit create a fully qualified name, - -- to disambiguate multiple child units with the same - -- name and different parents. + -- If it is a child unit create a fully qualified name, to + -- disambiguate multiple child units with the same name and + -- different parents. if Is_Child_Unit (Ent) then Prepend_String_To_Buffer ("__"); @@ -386,8 +386,8 @@ package body Exp_Dbug is when N_Expanded_Name => - -- The entity field for an N_Expanded_Name is on the - -- expanded name node itself, so we are done here too. + -- The entity field for an N_Expanded_Name is on the expanded + -- name node itself, so we are done here too. exit; @@ -713,6 +713,7 @@ package body Exp_Dbug is -- If this is a library level subprogram (i.e. a subprogram that is a -- compilation unit other than a subunit), then we prepend _ada_ to -- ensure distinctions required as described in the spec. + -- Check explicitly for child units, because those are not flagged -- as Compilation_Units by lib. Should they be ??? @@ -880,6 +881,39 @@ package body Exp_Dbug is end if; end Get_Variant_Encoding; + ------------------------------------ + -- Get_Secondary_DT_External_Name -- + ------------------------------------ + + procedure Get_Secondary_DT_External_Name + (Typ : Entity_Id; + Ancestor_Typ : Entity_Id; + Suffix_Index : Int) is + begin + Get_External_Name (Typ, Has_Suffix => False); + + if Ancestor_Typ /= Typ then + declare + Len : constant Natural := Name_Len; + Save_Str : constant String (1 .. Name_Len) + := Name_Buffer (1 .. Name_Len); + begin + Get_External_Name (Ancestor_Typ, Has_Suffix => False); + + -- Append the extended name of the ancestor to the + -- extended name of Typ + + Name_Buffer (Len + 2 .. Len + Name_Len + 1) := + Name_Buffer (1 .. Name_Len); + Name_Buffer (1 .. Len) := Save_Str; + Name_Buffer (Len + 1) := '_'; + Name_Len := Len + Name_Len + 1; + end; + end if; + + Add_Nat_To_Name_Buffer (Suffix_Index); + end Get_Secondary_DT_External_Name; + --------------------------------- -- Make_Packed_Array_Type_Name -- --------------------------------- @@ -1166,7 +1200,6 @@ package body Exp_Dbug is else Add_Char_To_Name_Buffer ('X'); end if; - end Set_BNPE_Suffix; --------------------- @@ -1338,7 +1371,6 @@ package body Exp_Dbug is exit; end if; end loop; - end Strip_Suffixes; end Exp_Dbug; diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads index 9100d9c..ccd80f3 100644 --- a/gcc/ada/exp_dbug.ads +++ b/gcc/ada/exp_dbug.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2005, 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- -- @@ -360,7 +360,7 @@ package Exp_Dbug is -- Operations generated for protected entries follow the same encoding. -- Each entry results in two suprograms: a procedure that holds the -- entry body, and a function that holds the evaluation of the barrier. - -- The names of these subprograms include the prefix 'E' or 'B' res- + -- The names of these subprograms include the prefix '_E' or '_B' res- -- pectively. The names also include a numeric suffix to render them -- unique in the presence of overloaded entries. @@ -382,8 +382,8 @@ package Exp_Dbug is -- lock_setN -- lock_setP - -- lock_update1sE - -- lock_udpate2sB + -- lock_update_E1s + -- lock_udpate_B2s -- If the protected type implements at least one interface, the -- following additional operations are created: @@ -538,6 +538,12 @@ package Exp_Dbug is -- field, and neither the outer structure name, nor the field name -- should appear when the value is printed. + -- When the debugger sees a record named REP being a field inside + -- another record, it should treat the fields inside REP as being + -- part of the outer record (this REP field is only present for + -- code generation purposes). The REP record should not appear in + -- the values printed by the debugger. + ----------------------- -- Fixed-Point Types -- ----------------------- @@ -1432,6 +1438,66 @@ package Exp_Dbug is -- the second enumeration literal would be named QU43 and the -- value assigned to it would be 1. + ----------------------------------------------- + -- Secondary Dispatch tables of tagged types -- + ----------------------------------------------- + + procedure Get_Secondary_DT_External_Name + (Typ : Entity_Id; + Ancestor_Typ : Entity_Id; + Suffix_Index : Int); + -- Set Name_Buffer and Name_Len to the external name of one secondary + -- dispatch table of Typ. If the interface has been inherited from some + -- ancestor then Ancestor_Typ is such node (in this case the secondary + -- DT is needed to handle overriden primitives); if there is no such + -- ancestor then Ancestor_Typ is equal to Typ. + -- + -- Internal rule followed for the generation of the external name: + -- + -- Case 1. If the secondary dispatch has not been inherited from some + -- ancestor of Typ then the external name is composed as + -- follows: + -- External_Name (Typ) + Suffix_Number + 'P' + -- + -- Case 2. if the secondary dispatch table has been inherited from some + -- ancestor then the external name is composed as follows: + -- External_Name (Typ) + '_' + External_Name (Ancestor_Typ) + -- + Suffix_Number + 'P' + -- + -- Note: We have to use the external names (instead of simply their + -- names) to protect the frontend against programs that give the same + -- name to all the interfaces and use the expanded name to reference + -- them. The Suffix_Number is used to differentiate all the secondary + -- dispatch tables of a given type. + -- + -- Examples: + -- + -- package Pkg1 is | package Pkg2 is | package Pkg3 is + -- type Typ is | type Typ is | type Typ is + -- interface; | interface; | interface; + -- end Pkg1; | end Pkg; | end Pkg3; + -- + -- with Pkg1, Pkg2, Pkg3; + -- package Case_1 is + -- type Typ is new Pkg1.Typ and Pkg2.Typ and Pkg3.Typ with ... + -- end Case_1; + -- + -- with Case_1; + -- package Case_2 is + -- type Typ is new Case_1.Typ with ... + -- end Case_2; + -- + -- These are the external names generated for Case_1.Typ (note that + -- Pkg1.Typ is associated with the Primary Dispatch Table, because it + -- is the the parent of this type, and hence no external name is + -- generated for it). + -- case_1__typ0P (associated with Pkg2.Typ) + -- case_1__typ1P (associated with Pkg3.Typ) + -- + -- These are the external names generated for Case_2.Typ: + -- case_2__typ_case_1__typ0P + -- case_2__typ_case_1__typ1P + ---------------------------- -- Effect of Optimization -- ---------------------------- diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 524d6de..20e769e 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -31,6 +31,7 @@ with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Ch7; use Exp_Ch7; +with Exp_Dbug; use Exp_Dbug; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Itypes; use Itypes; @@ -74,9 +75,10 @@ package body Exp_Disp is -- C : out Prim_Op_Kind procedure Build_Common_Dispatching_Select_Statements - (Loc : Source_Ptr; - Typ : Entity_Id; - Stmts : List_Id); + (Loc : Source_Ptr; + Typ : Entity_Id; + DT_Ptr : Entity_Id; + Stmts : List_Id); -- Ada 2005 (AI-345): Generate statements that are common between -- asynchronous, conditional and timed select expansion. @@ -151,21 +153,10 @@ package body Exp_Disp is procedure Build_Common_Dispatching_Select_Statements (Loc : Source_Ptr; Typ : Entity_Id; + DT_Ptr : Entity_Id; Stmts : List_Id) is - DT_Ptr : Entity_Id; - DT_Ptr_Typ : Entity_Id := Typ; - begin - -- Typ may be a derived type, climb the derivation chain in order to - -- find the root. - - while Present (Parent_Subtype (DT_Ptr_Typ)) loop - DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ); - end loop; - - DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ))); - -- Generate: -- C := get_prim_op_kind (tag! (<type>VP), S); @@ -187,6 +178,7 @@ package body Exp_Disp is Make_Identifier (Loc, Name_uS))))); -- Generate: + -- if C = POK_Procedure -- or else C = POK_Protected_Procedure -- or else C = POK_Task_Procedure; @@ -317,6 +309,7 @@ package body Exp_Disp is Get_Access_Level => RE_Get_Access_Level, Get_Entry_Index => RE_Get_Entry_Index, Get_External_Tag => RE_Get_External_Tag, + Get_Offset_Index => RE_Get_Offset_Index, Get_Prim_Op_Address => RE_Get_Prim_Op_Address, Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind, Get_RC_Offset => RE_Get_RC_Offset, @@ -329,10 +322,13 @@ package body Exp_Disp is Set_Entry_Index => RE_Set_Entry_Index, Set_Expanded_Name => RE_Set_Expanded_Name, Set_External_Tag => RE_Set_External_Tag, + Set_Offset_Index => RE_Set_Offset_Index, + Set_OSD => RE_Set_OSD, Set_Prim_Op_Address => RE_Set_Prim_Op_Address, Set_Prim_Op_Kind => RE_Set_Prim_Op_Kind, Set_RC_Offset => RE_Set_RC_Offset, Set_Remotely_Callable => RE_Set_Remotely_Callable, + Set_SSD => RE_Set_SSD, Set_TSD => RE_Set_TSD, TSD_Entry_Size => RE_TSD_Entry_Size, TSD_Prologue_Size => RE_TSD_Prologue_Size); @@ -345,6 +341,7 @@ package body Exp_Disp is Get_Access_Level => False, Get_Entry_Index => False, Get_External_Tag => False, + Get_Offset_Index => False, Get_Prim_Op_Address => False, Get_Prim_Op_Kind => False, Get_Remotely_Callable => False, @@ -357,10 +354,13 @@ package body Exp_Disp is Set_Entry_Index => True, Set_Expanded_Name => True, Set_External_Tag => True, + Set_Offset_Index => True, + Set_OSD => True, Set_Prim_Op_Address => True, Set_Prim_Op_Kind => True, Set_RC_Offset => True, Set_Remotely_Callable => True, + Set_SSD => True, Set_TSD => True, TSD_Entry_Size => False, TSD_Prologue_Size => False); @@ -373,6 +373,7 @@ package body Exp_Disp is Get_Access_Level => 1, Get_Entry_Index => 2, Get_External_Tag => 1, + Get_Offset_Index => 2, Get_Prim_Op_Address => 2, Get_Prim_Op_Kind => 2, Get_RC_Offset => 1, @@ -385,10 +386,13 @@ package body Exp_Disp is Set_Entry_Index => 3, Set_Expanded_Name => 2, Set_External_Tag => 2, + Set_Offset_Index => 3, + Set_OSD => 2, Set_Prim_Op_Address => 3, Set_Prim_Op_Kind => 3, Set_RC_Offset => 2, Set_Remotely_Callable => 2, + Set_SSD => 2, Set_TSD => 2, TSD_Entry_Size => 0, TSD_Prologue_Size => 0); @@ -552,21 +556,25 @@ package body Exp_Disp is elsif TSS_Name = TSS_Deep_Finalize then return Uint_10; - elsif Chars (E) = Name_uDisp_Asynchronous_Select then - return Uint_11; + elsif Ada_Version >= Ada_05 then + if Chars (E) = Name_uDisp_Asynchronous_Select then + return Uint_11; - elsif Chars (E) = Name_uDisp_Conditional_Select then - return Uint_12; + elsif Chars (E) = Name_uDisp_Conditional_Select then + return Uint_12; - elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then - return Uint_13; + elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then + return Uint_13; - elsif Chars (E) = Name_uDisp_Timed_Select then - return Uint_14; + elsif Chars (E) = Name_uDisp_Get_Task_Id then + return Uint_14; - else - raise Program_Error; + elsif Chars (E) = Name_uDisp_Timed_Select then + return Uint_15; + end if; end if; + + raise Program_Error; end Default_Prim_Op_Position; ----------------------------- @@ -1527,7 +1535,6 @@ package body Exp_Disp is (Etype (First_Entity (Target)), Make_Explicit_Dereference (Loc, New_Reference_To (Defining_Identifier (Decl_2), Loc)))); - end if; Formal := Next (First (Formals)); @@ -1650,7 +1657,6 @@ package body Exp_Disp is function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Obj); - begin return Make_DT_Access_Action (Typ => Etype (Obj), @@ -1675,14 +1681,16 @@ package body Exp_Disp is AI : Elmt_Id; begin - -- No need to inherit primitives if it an abstract interface type + -- No need to inherit primitives if we have an abstract interface + -- type or a concurrent type. - if Is_Interface (Typ) then + if Is_Interface (Typ) or else Is_Concurrent_Record_Type (Typ) then return Result; end if; AI := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); while Present (AI) loop + -- All the secondary tables inherit the dispatch table entries -- associated with predefined primitives. @@ -1704,759 +1712,6 @@ package body Exp_Disp is return Result; end Init_Predefined_Interface_Primitives; - ------------- - -- Make_DT -- - ------------- - - function Make_DT (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Result : constant List_Id := New_List; - Elab_Code : constant List_Id := New_List; - - Tname : constant Name_Id := Chars (Typ); - Name_DT : constant Name_Id := New_External_Name (Tname, 'T'); - Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P'); - Name_TSD : constant Name_Id := New_External_Name (Tname, 'B'); - Name_Exname : constant Name_Id := New_External_Name (Tname, 'E'); - Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F'); - - DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT); - DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr); - TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD); - Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname); - No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg); - - Generalized_Tag : constant Entity_Id := RTE (RE_Tag); - I_Depth : Int; - Size_Expr_Node : Node_Id; - Old_Tag1 : Node_Id; - Old_Tag2 : Node_Id; - Num_Ifaces : Int; - Nb_Prim : Int; - TSD_Num_Entries : Int; - Typ_Copy : constant Entity_Id := New_Copy (Typ); - AI : Elmt_Id; - - begin - if not RTE_Available (RE_Tag) then - Error_Msg_CRT ("tagged types", Typ); - return New_List; - end if; - - -- Collect the full list of directly and indirectly implemented - -- interfaces - - Set_Parent (Typ_Copy, Parent (Typ)); - Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List); - Collect_All_Interfaces (Typ_Copy); - - -- Calculate the number of entries required in the table of interfaces - - Num_Ifaces := 0; - AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); - while Present (AI) loop - Num_Ifaces := Num_Ifaces + 1; - Next_Elmt (AI); - end loop; - - -- Count ancestors to compute the inheritance depth. For private - -- extensions, always go to the full view in order to compute the real - -- inheritance depth. - - declare - Parent_Type : Entity_Id := Typ; - P : Entity_Id; - - begin - I_Depth := 0; - loop - P := Etype (Parent_Type); - - if Is_Private_Type (P) then - P := Full_View (Base_Type (P)); - end if; - - exit when P = Parent_Type; - - I_Depth := I_Depth + 1; - Parent_Type := P; - end loop; - end; - - Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); - - -- Ada 2005 (AI-345): The size of the TSD is increased to accomodate - -- the two tables used for dispatching in asynchronous, conditional - -- and timed selects. The tables are solely generated for limited - -- types that implement a limited interface. - - if Ada_Version >= Ada_05 - and then not Is_Interface (Typ) - and then not Is_Abstract (Typ) - and then not Is_Controlled (Typ) - and then Implements_Limited_Interface (Typ) - then - TSD_Num_Entries := I_Depth + Num_Ifaces + 1 + - 2 * (Nb_Prim - Default_Prim_Op_Count); - else - TSD_Num_Entries := I_Depth + Num_Ifaces + 1; - end if; - - -- ---------------------------------------------------------------- - -- Dispatch table and related entities are allocated statically - - Set_Ekind (DT, E_Variable); - Set_Is_Statically_Allocated (DT); - - Set_Ekind (DT_Ptr, E_Variable); - Set_Is_Statically_Allocated (DT_Ptr); - - Set_Ekind (TSD, E_Variable); - Set_Is_Statically_Allocated (TSD); - - Set_Ekind (Exname, E_Variable); - Set_Is_Statically_Allocated (Exname); - - Set_Ekind (No_Reg, E_Variable); - Set_Is_Statically_Allocated (No_Reg); - - -- Generate code to create the storage for the Dispatch_Table object: - - -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size); - -- for DT'Alignment use Address'Alignment - - Size_Expr_Node := - Make_Op_Add (Loc, - Left_Opnd => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List), - Right_Opnd => - Make_Op_Multiply (Loc, - Left_Opnd => - Make_DT_Access_Action (Typ, DT_Entry_Size, No_List), - Right_Opnd => - Make_Integer_Literal (Loc, Nb_Prim))); - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => DT, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), - Constraint => Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => Size_Expr_Node)))))); - - Append_To (Result, - Make_Attribute_Definition_Clause (Loc, - Name => New_Reference_To (DT, Loc), - Chars => Name_Alignment, - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), - Attribute_Name => Name_Alignment))); - - -- Generate code to create the pointer to the dispatch table - - -- DT_Ptr : Tag := Tag!(DT'Address); - - -- According to the C++ ABI, the base of the vtable is located after a - -- prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move - -- down the pointer to the real base of the vtable - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => DT_Ptr, - Constant_Present => True, - Object_Definition => New_Reference_To (Generalized_Tag, Loc), - Expression => - Unchecked_Convert_To (Generalized_Tag, - Make_Op_Add (Loc, - Left_Opnd => - Unchecked_Convert_To (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (DT, Loc), - Attribute_Name => Name_Address)), - Right_Opnd => - Make_DT_Access_Action (Typ, - DT_Prologue_Size, No_List))))); - - -- Generate code to define the boolean that controls registration, in - -- order to avoid multiple registrations for tagged types defined in - -- multiple-called scopes. - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => No_Reg, - Object_Definition => New_Reference_To (Standard_Boolean, Loc), - Expression => New_Reference_To (Standard_True, Loc))); - - -- Set Access_Disp_Table field to be the dispatch table pointer - - if not Present (Access_Disp_Table (Typ)) then - Set_Access_Disp_Table (Typ, New_Elmt_List); - end if; - - Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ)); - - -- Generate code to create the storage for the type specific data object - -- with enough space to store the tags of the ancestors plus the tags - -- of all the implemented interfaces (as described in a-tags.adb). - -- - -- TSD: Storage_Array - -- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size); - -- for TSD'Alignment use Address'Alignment - - Size_Expr_Node := - Make_Op_Add (Loc, - Left_Opnd => - Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List), - Right_Opnd => - Make_Op_Multiply (Loc, - Left_Opnd => - Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List), - Right_Opnd => - Make_Integer_Literal (Loc, TSD_Num_Entries))); - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => TSD, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), - Constraint => Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => Size_Expr_Node)))))); - - Append_To (Result, - Make_Attribute_Definition_Clause (Loc, - Name => New_Reference_To (TSD, Loc), - Chars => Name_Alignment, - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), - Attribute_Name => Name_Alignment))); - - -- Generate code to put the Address of the TSD in the dispatch table - -- Set_TSD (DT_Ptr, TSD); - - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Set_TSD, - Args => New_List ( - New_Reference_To (DT_Ptr, Loc), -- DTptr - Make_Attribute_Reference (Loc, -- Value - Prefix => New_Reference_To (TSD, Loc), - Attribute_Name => Name_Address)))); - - -- Generate: Exname : constant String := full_qualified_name (typ); - -- The type itself may be an anonymous parent type, so use the first - -- subtype to have a user-recognizable name. - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => Exname, - Constant_Present => True, - Object_Definition => New_Reference_To (Standard_String, Loc), - Expression => - Make_String_Literal (Loc, - Full_Qualified_Name (First_Subtype (Typ))))); - - -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address); - - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Set_Expanded_Name, - Args => New_List ( - Node1 => New_Reference_To (DT_Ptr, Loc), - Node2 => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Exname, Loc), - Attribute_Name => Name_Address)))); - - -- Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>); - - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Set_Access_Level, - Args => New_List ( - Node1 => New_Reference_To (DT_Ptr, Loc), - Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ))))); - - -- Generate: - -- Set_Offset_To_Top (DT_Ptr, 0); - - Append_To (Elab_Code, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), - Parameter_Associations => New_List ( - New_Reference_To (DT_Ptr, Loc), - Make_Integer_Literal (Loc, Uint_0)))); - - if Typ = Etype (Typ) - or else Is_CPP_Class (Etype (Typ)) - then - Old_Tag1 := - Unchecked_Convert_To (Generalized_Tag, - Make_Integer_Literal (Loc, 0)); - Old_Tag2 := - Unchecked_Convert_To (Generalized_Tag, - Make_Integer_Literal (Loc, 0)); - - else - Old_Tag1 := - New_Reference_To - (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); - Old_Tag2 := - New_Reference_To - (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); - end if; - - if Typ /= Etype (Typ) - and then not Is_Interface (Typ) - and then not Is_Interface (Etype (Typ)) - then - -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent); - - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Inherit_DT, - Args => New_List ( - Node1 => Old_Tag1, - Node2 => New_Reference_To (DT_Ptr, Loc), - Node3 => - Make_Integer_Literal (Loc, - DT_Entry_Count (First_Tag_Component (Etype (Typ))))))); - - -- Inherit the secondary dispatch tables of the ancestor - - if not Is_CPP_Class (Etype (Typ)) then - declare - Sec_DT_Ancestor : Elmt_Id := - Next_Elmt - (First_Elmt - (Access_Disp_Table (Etype (Typ)))); - Sec_DT_Typ : Elmt_Id := - Next_Elmt - (First_Elmt - (Access_Disp_Table (Typ))); - - procedure Copy_Secondary_DTs (Typ : Entity_Id); - -- Local procedure required to climb through the ancestors and - -- copy the contents of all their secondary dispatch tables. - - ------------------------ - -- Copy_Secondary_DTs -- - ------------------------ - - procedure Copy_Secondary_DTs (Typ : Entity_Id) is - E : Entity_Id; - - begin - if Etype (Typ) /= Typ then - Copy_Secondary_DTs (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) - and then Present (Node (Sec_DT_Ancestor)) - loop - if Is_Tag (E) and then Chars (E) /= Name_uTag then - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Inherit_DT, - Args => New_List ( - Node1 => Unchecked_Convert_To - (RTE (RE_Tag), - New_Reference_To - (Node (Sec_DT_Ancestor), Loc)), - Node2 => Unchecked_Convert_To - (RTE (RE_Tag), - New_Reference_To - (Node (Sec_DT_Typ), Loc)), - Node3 => Make_Integer_Literal (Loc, - DT_Entry_Count (E))))); - - Next_Elmt (Sec_DT_Ancestor); - Next_Elmt (Sec_DT_Typ); - end if; - - Next_Entity (E); - end loop; - end if; - end Copy_Secondary_DTs; - - begin - if Present (Node (Sec_DT_Ancestor)) then - Copy_Secondary_DTs (Typ); - end if; - end; - end if; - end if; - - -- Generate: - -- Inherit_TSD (parent'tag, DT_Ptr); - - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Inherit_TSD, - Args => New_List ( - Node1 => Old_Tag2, - Node2 => New_Reference_To (DT_Ptr, Loc)))); - - -- For types with no controlled components, generate: - -- Set_RC_Offset (DT_Ptr, 0); - - -- For simple types with controlled components, generate: - -- Set_RC_Offset (DT_Ptr, type._record_controller'position); - - -- For complex types with controlled components where the position - -- of the record controller is not statically computable, if there are - -- controlled components at this level, generate: - -- Set_RC_Offset (DT_Ptr, -1); - -- to indicate that the _controller field is right after the _parent - - -- Or if there are no controlled components at this level, generate: - -- Set_RC_Offset (DT_Ptr, -2); - -- to indicate that we need to get the position from the parent. - - declare - Position : Node_Id; - - begin - if not Has_Controlled_Component (Typ) then - Position := Make_Integer_Literal (Loc, 0); - - elsif Etype (Typ) /= Typ and then Has_Discriminants (Etype (Typ)) then - if Has_New_Controlled_Component (Typ) then - Position := Make_Integer_Literal (Loc, -1); - else - Position := Make_Integer_Literal (Loc, -2); - end if; - else - Position := - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => New_Reference_To (Typ, Loc), - Selector_Name => - New_Reference_To (Controller_Component (Typ), Loc)), - Attribute_Name => Name_Position); - - -- This is not proper Ada code to use the attribute 'Position - -- on something else than an object but this is supported by - -- the back end (see comment on the Bit_Component attribute in - -- sem_attr). So we avoid semantic checking here. - - -- Is this documented in sinfo.ads??? it should be! - - Set_Analyzed (Position); - Set_Etype (Prefix (Position), RTE (RE_Record_Controller)); - Set_Etype (Prefix (Prefix (Position)), Typ); - Set_Etype (Selector_Name (Prefix (Position)), - RTE (RE_Record_Controller)); - Set_Etype (Position, RTE (RE_Storage_Offset)); - end if; - - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Set_RC_Offset, - Args => New_List ( - Node1 => New_Reference_To (DT_Ptr, Loc), - Node2 => Position))); - end; - - -- Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is - -- described in E.4 (18) - - declare - Status : Entity_Id; - - begin - Status := - Boolean_Literals - (Is_Pure (Typ) - or else Is_Shared_Passive (Typ) - or else - ((Is_Remote_Types (Typ) - or else Is_Remote_Call_Interface (Typ)) - and then Original_View_In_Visible_Part (Typ)) - or else not Comes_From_Source (Typ)); - - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Set_Remotely_Callable, - Args => New_List ( - New_Occurrence_Of (DT_Ptr, Loc), - New_Occurrence_Of (Status, Loc)))); - end; - - -- Generate: Set_External_Tag (DT_Ptr, exname'Address); - -- Should be the external name not the qualified name??? - - if not Has_External_Tag_Rep_Clause (Typ) then - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Set_External_Tag, - Args => New_List ( - Node1 => New_Reference_To (DT_Ptr, Loc), - Node2 => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Exname, Loc), - Attribute_Name => Name_Address)))); - - -- Generate code to register the Tag in the External_Tag hash - -- table for the pure Ada type only. - - -- Register_Tag (Dt_Ptr); - - -- Skip this if routine not available, or in No_Run_Time mode - - if RTE_Available (RE_Register_Tag) - and then Is_RTE (Generalized_Tag, RE_Tag) - and then not No_Run_Time_Mode - then - Append_To (Elab_Code, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Register_Tag), Loc), - Parameter_Associations => - New_List (New_Reference_To (DT_Ptr, Loc)))); - end if; - end if; - - -- Generate: - -- if No_Reg then - -- <elab_code> - -- No_Reg := False; - -- end if; - - Append_To (Elab_Code, - Make_Assignment_Statement (Loc, - Name => New_Reference_To (No_Reg, Loc), - Expression => New_Reference_To (Standard_False, Loc))); - - Append_To (Result, - Make_Implicit_If_Statement (Typ, - Condition => New_Reference_To (No_Reg, Loc), - Then_Statements => Elab_Code)); - - -- Ada 2005 (AI-251): Register the tag of the interfaces into - -- the table of implemented interfaces - - if Present (Abstract_Interfaces (Typ_Copy)) - and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ_Copy)) - then - AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); - while Present (AI) loop - - -- Generate: - -- Register_Interface (DT_Ptr, Interface'Tag); - - Append_To (Result, - Make_DT_Access_Action (Typ, - Action => Register_Interface_Tag, - Args => New_List ( - Node1 => New_Reference_To (DT_Ptr, Loc), - Node2 => New_Reference_To - (Node - (First_Elmt - (Access_Disp_Table (Node (AI)))), - Loc)))); - - Next_Elmt (AI); - end loop; - end if; - - return Result; - end Make_DT; - - -------------------------------- - -- Make_Abstract_Interface_DT -- - -------------------------------- - - procedure Make_Abstract_Interface_DT - (AI_Tag : Entity_Id; - Acc_Disp_Tables : in out Elist_Id; - Result : out List_Id) - is - Loc : constant Source_Ptr := Sloc (AI_Tag); - Name_DT : constant Name_Id := New_Internal_Name ('T'); - Name_DT_Ptr : constant Name_Id := New_Internal_Name ('P'); - - Iface_DT : constant Node_Id := - Make_Defining_Identifier (Loc, Name_DT); - Iface_DT_Ptr : constant Node_Id := - Make_Defining_Identifier (Loc, Name_DT_Ptr); - - Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag); - Size_Expr_Node : Node_Id; - Nb_Prim : Int; - - begin - Result := New_List; - - -- Dispatch table and related entities are allocated statically - - Set_Ekind (Iface_DT, E_Variable); - Set_Is_Statically_Allocated (Iface_DT); - - Set_Ekind (Iface_DT_Ptr, E_Variable); - Set_Is_Statically_Allocated (Iface_DT_Ptr); - - -- Generate code to create the storage for the Dispatch_Table object - - -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size); - -- for DT'Alignment use Address'Alignment - - Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag)); - - Size_Expr_Node := - Make_Op_Add (Loc, - Left_Opnd => Make_DT_Access_Action (Etype (AI_Tag), - DT_Prologue_Size, - No_List), - Right_Opnd => - Make_Op_Multiply (Loc, - Left_Opnd => - Make_DT_Access_Action (Etype (AI_Tag), - DT_Entry_Size, - No_List), - Right_Opnd => - Make_Integer_Literal (Loc, Nb_Prim))); - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => Iface_DT, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), - Constraint => Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => Size_Expr_Node)))), - - -- Initialize the signature of the interface tag. It is currently - -- a sequence of four bytes located in the unused Typeinfo_Ptr - -- field of the prologue). Its current value is the following - -- sequence: (80, Nb_Prim, 0, 80) - - Expression => - Make_Aggregate (Loc, - Component_Associations => New_List ( - Make_Component_Association (Loc, - - -- -80, 0, 0, -80 - - Choices => New_List ( - Make_Integer_Literal (Loc, Uint_5), - Make_Integer_Literal (Loc, Uint_8)), - Expression => - Make_Integer_Literal (Loc, Uint_80)), - - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, Uint_2)), - Expression => - Make_Integer_Literal (Loc, Nb_Prim)), - - Make_Component_Association (Loc, - Choices => New_List ( - Make_Others_Choice (Loc)), - Expression => Make_Integer_Literal (Loc, Uint_0)))))); - - Append_To (Result, - Make_Attribute_Definition_Clause (Loc, - Name => New_Reference_To (Iface_DT, Loc), - Chars => Name_Alignment, - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), - Attribute_Name => Name_Alignment))); - - -- Generate code to create the pointer to the dispatch table - - -- Iface_DT_Ptr : Tag := Tag!(DT'Address); - - -- According to the C++ ABI, the base of the vtable is located - -- after the following prologue: Offset_To_Top, and Typeinfo_Ptr. - -- Hence, move the pointer down to the real base of the vtable. - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => Iface_DT_Ptr, - Constant_Present => True, - Object_Definition => New_Reference_To (Generalized_Tag, Loc), - Expression => - Unchecked_Convert_To (Generalized_Tag, - Make_Op_Add (Loc, - Left_Opnd => - Unchecked_Convert_To (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Iface_DT, Loc), - Attribute_Name => Name_Address)), - Right_Opnd => - Make_DT_Access_Action (Etype (AI_Tag), - DT_Prologue_Size, No_List))))); - - -- Note: Offset_To_Top will be initialized by the init subprogram - - -- Set Access_Disp_Table field to be the dispatch table pointer - - if not (Present (Acc_Disp_Tables)) then - Acc_Disp_Tables := New_Elmt_List; - end if; - - Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables); - end Make_Abstract_Interface_DT; - - --------------------------- - -- Make_DT_Access_Action -- - --------------------------- - - function Make_DT_Access_Action - (Typ : Entity_Id; - Action : DT_Access_Action; - Args : List_Id) return Node_Id - is - Action_Name : constant Entity_Id := RTE (Ada_Actions (Action)); - Loc : Source_Ptr; - - begin - if No (Args) then - - -- This is a constant - - return New_Reference_To (Action_Name, Sloc (Typ)); - end if; - - pragma Assert (List_Length (Args) = Action_Nb_Arg (Action)); - - Loc := Sloc (First (Args)); - - if Action_Is_Proc (Action) then - return - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (Action_Name, Loc), - Parameter_Associations => Args); - - else - return - Make_Function_Call (Loc, - Name => New_Reference_To (Action_Name, Loc), - Parameter_Associations => Args); - end if; - end Make_DT_Access_Action; - ---------------------------------------- -- Make_Disp_Asynchronous_Select_Body -- ---------------------------------------- @@ -2464,27 +1719,30 @@ package body Exp_Disp is function Make_Disp_Asynchronous_Select_Body (Typ : Entity_Id) return Node_Id is - Conc_Typ : Entity_Id := Empty; - Decls : constant List_Id := New_List; - DT_Ptr : Entity_Id; - DT_Ptr_Typ : Entity_Id; - Loc : constant Source_Ptr := Sloc (Typ); - Stmts : constant List_Id := New_List; + Conc_Typ : Entity_Id := Empty; + Decls : constant List_Id := New_List; + DT_Ptr : Entity_Id; + Loc : constant Source_Ptr := Sloc (Typ); + Stmts : constant List_Id := New_List; begin + if Is_Interface (Typ) then + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Asynchronous_Select_Spec (Typ), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Make_Null_Statement (Loc)))); + end if; + if Is_Concurrent_Record_Type (Typ) then Conc_Typ := Corresponding_Concurrent_Type (Typ); end if; - -- Typ may be a derived type, climb the derivation chain in order to - -- find the root. - - DT_Ptr_Typ := Typ; - while Present (Parent_Subtype (DT_Ptr_Typ)) loop - DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ); - end loop; - - DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ))); + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); if Present (Conc_Typ) then @@ -2590,11 +1848,11 @@ package body Exp_Disp is Make_Identifier (Loc, Name_uF)))); -- status flag end if; - -- Null implementation for limited tagged types + -- Implementation for limited tagged types else Append_To (Stmts, - Make_Null_Statement (Loc)); + Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); end if; return @@ -2615,6 +1873,9 @@ package body Exp_Disp is (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); + Def_Id : constant Node_Id := + Make_Defining_Identifier (Loc, + Name_uDisp_Asynchronous_Select); Params : constant List_Id := New_List; begin @@ -2630,12 +1891,12 @@ package body Exp_Disp is SEU.Build_B (Loc, Params); SEU.Build_F (Loc, Params); + Set_Is_Internal (Def_Id); + return Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Name_uDisp_Asynchronous_Select), - Parameter_Specifications => - Params); + Defining_Unit_Name => Def_Id, + Parameter_Specifications => Params); end Make_Disp_Asynchronous_Select_Spec; --------------------------------------- @@ -2645,30 +1906,34 @@ package body Exp_Disp is function Make_Disp_Conditional_Select_Body (Typ : Entity_Id) return Node_Id is - Blk_Nam : Entity_Id; - Conc_Typ : Entity_Id := Empty; - Decls : constant List_Id := New_List; - DT_Ptr : Entity_Id; - DT_Ptr_Typ : Entity_Id; - Loc : constant Source_Ptr := Sloc (Typ); - Stmts : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Blk_Nam : Entity_Id; + Conc_Typ : Entity_Id := Empty; + Decls : constant List_Id := New_List; + DT_Ptr : Entity_Id; + Stmts : constant List_Id := New_List; begin + if Is_Interface (Typ) then + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Conditional_Select_Spec (Typ), + Declarations => + No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Make_Null_Statement (Loc)))); + end if; + if Is_Concurrent_Record_Type (Typ) then Conc_Typ := Corresponding_Concurrent_Type (Typ); end if; - -- Typ may be a derived type, climb the derivation chain in order to - -- find the root. - - DT_Ptr_Typ := Typ; - while Present (Parent_Subtype (DT_Ptr_Typ)) loop - DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ); - end loop; - - DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ))); + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); if Present (Conc_Typ) then + -- Generate: -- I : Integer; @@ -2694,7 +1959,7 @@ package body Exp_Disp is -- return; -- end if; - SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts); + SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, DT_Ptr, Stmts); if Present (Conc_Typ) then @@ -2716,7 +1981,7 @@ package body Exp_Disp is -- Generate: -- I := get_entry_index (tag! (<type>VP), S); - -- where I is the entry index and S is the dispatch table slot. + -- I is the entry index and S is the dispatch table slot Append_To (Stmts, Make_Assignment_Statement (Loc, @@ -2833,11 +2098,11 @@ package body Exp_Disp is Make_Identifier (Loc, Name_uF)))); -- status flag end if; - -- Null implementation for limited tagged types + -- Implementation for limited tagged types else Append_To (Stmts, - Make_Null_Statement (Loc)); + Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); end if; return @@ -2858,6 +2123,9 @@ package body Exp_Disp is (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); + Def_Id : constant Node_Id := + Make_Defining_Identifier (Loc, + Name_uDisp_Conditional_Select); Params : constant List_Id := New_List; begin @@ -2873,12 +2141,12 @@ package body Exp_Disp is SEU.Build_C (Loc, Params); SEU.Build_F (Loc, Params); + Set_Is_Internal (Def_Id); + return Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Name_uDisp_Conditional_Select), - Parameter_Specifications => - Params); + Defining_Unit_Name => Def_Id, + Parameter_Specifications => Params); end Make_Disp_Conditional_Select_Spec; ------------------------------------- @@ -2888,20 +2156,23 @@ package body Exp_Disp is function Make_Disp_Get_Prim_Op_Kind_Body (Typ : Entity_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (Typ); - DT_Ptr : Entity_Id; - DT_Ptr_Typ : Entity_Id; + Loc : constant Source_Ptr := Sloc (Typ); + DT_Ptr : Entity_Id; begin - -- Typ may be a derived type, climb the derivation chain in order to - -- find the root. - - DT_Ptr_Typ := Typ; - while Present (Parent_Subtype (DT_Ptr_Typ)) loop - DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ); - end loop; + if Is_Interface (Typ) then + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Get_Prim_Op_Kind_Spec (Typ), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Make_Null_Statement (Loc)))); + end if; - DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ))); + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); -- Generate: -- C := get_prim_op_kind (tag! (<type>VP), S); @@ -2914,7 +2185,7 @@ package body Exp_Disp is Specification => Make_Disp_Get_Prim_Op_Kind_Spec (Typ), Declarations => - No_List, + New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List ( @@ -2940,6 +2211,9 @@ package body Exp_Disp is (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); + Def_Id : constant Node_Id := + Make_Defining_Identifier (Loc, + Name_uDisp_Get_Prim_Op_Kind); Params : constant List_Id := New_List; begin @@ -2951,109 +2225,84 @@ package body Exp_Disp is SEU.Build_S (Loc, Params); SEU.Build_C (Loc, Params); + Set_Is_Internal (Def_Id); + return Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind), - Parameter_Specifications => - Params); + Defining_Unit_Name => Def_Id, + Parameter_Specifications => Params); end Make_Disp_Get_Prim_Op_Kind_Spec; - ----------------------------- - -- Make_Disp_Select_Tables -- - ----------------------------- + -------------------------------- + -- Make_Disp_Get_Task_Id_Body -- + -------------------------------- - function Make_Disp_Select_Tables - (Typ : Entity_Id) return List_Id + function Make_Disp_Get_Task_Id_Body + (Typ : Entity_Id) return Node_Id is - Assignments : constant List_Id := New_List; - DT_Ptr : Entity_Id; - DT_Ptr_Typ : Entity_Id; - Index : Uint := Uint_1; - Loc : constant Source_Ptr := Sloc (Typ); - Prim : Entity_Id; - Prim_Als : Entity_Id; - Prim_Elmt : Elmt_Id; - Prim_Pos : Uint; + Loc : constant Source_Ptr := Sloc (Typ); + Ret : Node_Id; begin - pragma Assert (Present (Primitive_Operations (Typ))); - - -- Typ may be a derived type, climb the derivation chain in order to - -- find the root. - - DT_Ptr_Typ := Typ; - while Present (Parent_Subtype (DT_Ptr_Typ)) loop - DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ); - end loop; - - DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ))); - - Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); - while Present (Prim_Elmt) loop - Prim := Node (Prim_Elmt); - - -- Retrieve the root of the alias chain - - if Present (Alias (Prim)) then - Prim_Als := Prim; - while Present (Alias (Prim_Als)) loop - Prim_Als := Alias (Prim_Als); - end loop; - else - Prim_Als := Empty; - end if; - - -- We either have a procedure or a wrapper. Set the primitive - -- operation kind for both cases and set the entry index for - -- wrappers. - - if Ekind (Prim) = E_Procedure - and then Present (Prim_Als) - and then Is_Primitive_Wrapper (Prim_Als) - then - Prim_Pos := DT_Position (Prim); - - -- Generate: - -- set_prim_op_kind (<tag>, <position>, <kind>); + if Is_Concurrent_Record_Type (Typ) + and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type + then + Ret := + Make_Return_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uT), + Selector_Name => + Make_Identifier (Loc, Name_uTask_Id))); - Append_To (Assignments, - Make_DT_Access_Action (Typ, - Action => - Set_Prim_Op_Kind, - Args => - New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (DT_Ptr, Loc)), - Make_Integer_Literal (Loc, Prim_Pos), - Prim_Op_Kind (Prim, Typ)))); + -- A null body is constructed for non-task types - -- The wrapped entity of the alias is an entry + else + Ret := + Make_Return_Statement (Loc, + Expression => + New_Reference_To (RTE (RO_ST_Null_Task), Loc)); + end if; - if Ekind (Wrapped_Entity (Prim_Als)) = E_Entry then - -- Generate: - -- set_entry_index (<tag>, <position>, <index>); + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Get_Task_Id_Spec (Typ), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Ret))); + end Make_Disp_Get_Task_Id_Body; - Append_To (Assignments, - Make_DT_Access_Action (Typ, - Action => - Set_Entry_Index, - Args => - New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (DT_Ptr, Loc)), - Make_Integer_Literal (Loc, Prim_Pos), - Make_Integer_Literal (Loc, Index)))); + -------------------------------- + -- Make_Disp_Get_Task_Id_Spec -- + -------------------------------- - Index := Index + 1; - end if; - end if; + function Make_Disp_Get_Task_Id_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Def_Id : constant Node_Id := + Make_Defining_Identifier (Loc, + Name_uDisp_Get_Task_Id); - Next_Elmt (Prim_Elmt); - end loop; + begin + Set_Is_Internal (Def_Id); - return Assignments; - end Make_Disp_Select_Tables; + return + Make_Function_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => + New_Reference_To (Typ, Loc))), + Result_Definition => + New_Reference_To (RTE (RO_ST_Task_Id), Loc)); + end Make_Disp_Get_Task_Id_Spec; --------------------------------- -- Make_Disp_Timed_Select_Body -- @@ -3062,27 +2311,30 @@ package body Exp_Disp is function Make_Disp_Timed_Select_Body (Typ : Entity_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Conc_Typ : Entity_Id := Empty; - Decls : constant List_Id := New_List; - DT_Ptr : Entity_Id; - DT_Ptr_Typ : Entity_Id; - Stmts : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Conc_Typ : Entity_Id := Empty; + Decls : constant List_Id := New_List; + DT_Ptr : Entity_Id; + Stmts : constant List_Id := New_List; begin + if Is_Interface (Typ) then + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Timed_Select_Spec (Typ), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Make_Null_Statement (Loc)))); + end if; + if Is_Concurrent_Record_Type (Typ) then Conc_Typ := Corresponding_Concurrent_Type (Typ); end if; - -- Typ may be a derived type, climb the derivation chain in order to - -- find the root. - - DT_Ptr_Typ := Typ; - while Present (Parent_Subtype (DT_Ptr_Typ)) loop - DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ); - end loop; - - DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ))); + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); if Present (Conc_Typ) then @@ -3111,14 +2363,14 @@ package body Exp_Disp is -- return; -- end if; - SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts); + SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, DT_Ptr, Stmts); if Present (Conc_Typ) then -- Generate: -- I := get_entry_index (tag! (<type>VP), S); - -- where I is the entry index and S is the dispatch table slot. + -- I is the entry index and S is the dispatch table slot Append_To (Stmts, Make_Assignment_Statement (Loc, @@ -3218,11 +2470,11 @@ package body Exp_Disp is Make_Identifier (Loc, Name_uF)))); -- status flag end if; - -- Null implementation for limited tagged types + -- Implementation for limited tagged types else Append_To (Stmts, - Make_Null_Statement (Loc)); + Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); end if; return @@ -3243,6 +2495,9 @@ package body Exp_Disp is (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); + Def_Id : constant Node_Id := + Make_Defining_Identifier (Loc, + Name_uDisp_Timed_Select); Params : constant List_Id := New_List; begin @@ -3275,14 +2530,1189 @@ package body Exp_Disp is SEU.Build_C (Loc, Params); SEU.Build_F (Loc, Params); + Set_Is_Internal (Def_Id); + return Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Name_uDisp_Timed_Select), - Parameter_Specifications => - Params); + Defining_Unit_Name => Def_Id, + Parameter_Specifications => Params); end Make_Disp_Timed_Select_Spec; + ------------- + -- Make_DT -- + ------------- + + function Make_DT (Typ : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Typ); + Result : constant List_Id := New_List; + Elab_Code : constant List_Id := New_List; + + Tname : constant Name_Id := Chars (Typ); + Name_DT : constant Name_Id := New_External_Name (Tname, 'T'); + Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P'); + Name_SSD : constant Name_Id := New_External_Name (Tname, 'S'); + Name_TSD : constant Name_Id := New_External_Name (Tname, 'B'); + Name_Exname : constant Name_Id := New_External_Name (Tname, 'E'); + Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F'); + + DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT); + DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr); + SSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_SSD); + TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD); + Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname); + No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg); + + Generalized_Tag : constant Entity_Id := RTE (RE_Tag); + I_Depth : Int; + Size_Expr_Node : Node_Id; + Old_Tag1 : Node_Id; + Old_Tag2 : Node_Id; + Num_Ifaces : Int; + Nb_Prim : Int; + TSD_Num_Entries : Int; + Typ_Copy : constant Entity_Id := New_Copy (Typ); + AI : Elmt_Id; + + begin + if not RTE_Available (RE_Tag) then + Error_Msg_CRT ("tagged types", Typ); + return New_List; + end if; + + -- Collect full list of directly and indirectly implemented interfaces + + Set_Parent (Typ_Copy, Parent (Typ)); + Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List); + Collect_All_Interfaces (Typ_Copy); + + -- Calculate the size of the DT and the TSD + + if Is_Interface (Typ) then + -- Abstract interfaces need neither the DT nor the ancestors table. + -- We reserve a single entry for its DT because at run-time the + -- pointer to this dummy DT is the tag of this abstract interface + -- type. + + Nb_Prim := 1; + TSD_Num_Entries := 0; + + else + -- Calculate the number of entries for the table of interfaces + + Num_Ifaces := 0; + AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); + while Present (AI) loop + Num_Ifaces := Num_Ifaces + 1; + Next_Elmt (AI); + end loop; + + -- Count ancestors to compute the inheritance depth. For private + -- extensions, always go to the full view in order to compute the + -- real inheritance depth. + + declare + Parent_Type : Entity_Id := Typ; + P : Entity_Id; + + begin + I_Depth := 0; + loop + P := Etype (Parent_Type); + + if Is_Private_Type (P) then + P := Full_View (Base_Type (P)); + end if; + + exit when P = Parent_Type; + + I_Depth := I_Depth + 1; + Parent_Type := P; + end loop; + end; + + TSD_Num_Entries := I_Depth + Num_Ifaces + 1; + Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); + + -- If the number of primitives of Typ is less that the number of + -- predefined primitives, we must reserve at least enough space + -- for the predefined primitives. + + if Nb_Prim < Default_Prim_Op_Count then + Nb_Prim := Default_Prim_Op_Count; + end if; + end if; + + -- Dispatch table and related entities are allocated statically + + Set_Ekind (DT, E_Variable); + Set_Is_Statically_Allocated (DT); + + Set_Ekind (DT_Ptr, E_Variable); + Set_Is_Statically_Allocated (DT_Ptr); + + Set_Ekind (SSD, E_Variable); + Set_Is_Statically_Allocated (SSD); + + Set_Ekind (TSD, E_Variable); + Set_Is_Statically_Allocated (TSD); + + Set_Ekind (Exname, E_Variable); + Set_Is_Statically_Allocated (Exname); + + Set_Ekind (No_Reg, E_Variable); + Set_Is_Statically_Allocated (No_Reg); + + -- Generate code to create the storage for the Dispatch_Table object: + + -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size); + -- for DT'Alignment use Address'Alignment + + Size_Expr_Node := + Make_Op_Add (Loc, + Left_Opnd => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List), + Right_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => + Make_DT_Access_Action (Typ, DT_Entry_Size, No_List), + Right_Opnd => + Make_Integer_Literal (Loc, Nb_Prim))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To + (RTE (RE_Storage_Array), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Size_Expr_Node)))))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (DT, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + -- Initialize the signature of the interface tag. It is a sequence + -- two bytes located in the header of the dispatch table. + + Append_To (Result, + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (DT, Loc), + Expressions => New_List ( + Make_Integer_Literal (Loc, Uint_1))), + Expression => + Unchecked_Convert_To (RTE (RE_Storage_Element), + New_Reference_To (RTE (RE_Valid_Signature), Loc)))); + + if not Is_Interface (Typ) then + + -- The signature of a Primary Dispatch table is: + -- (Valid_Signature, Primary_DT) + + Append_To (Result, + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (DT, Loc), + Expressions => New_List ( + Make_Integer_Literal (Loc, Uint_2))), + Expression => + Unchecked_Convert_To (RTE (RE_Storage_Element), + New_Reference_To (RTE (RE_Primary_DT), Loc)))); + + else + -- The signature of an abstract interface is: + -- (Valid_Signature, Abstract_Interface) + + Append_To (Result, + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (DT, Loc), + Expressions => New_List ( + Make_Integer_Literal (Loc, Uint_2))), + Expression => + Unchecked_Convert_To (RTE (RE_Storage_Element), + New_Reference_To (RTE (RE_Abstract_Interface), Loc)))); + end if; + + -- Generate code to create the pointer to the dispatch table + + -- DT_Ptr : Tag := Tag!(DT'Address); + + -- According to the C++ ABI, the base of the vtable is located after a + -- prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move + -- down the pointer to the real base of the vtable + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To (Generalized_Tag, Loc), + Expression => + Unchecked_Convert_To (Generalized_Tag, + Make_Op_Add (Loc, + Left_Opnd => + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (DT, Loc), + Attribute_Name => Name_Address)), + Right_Opnd => + Make_DT_Access_Action (Typ, + DT_Prologue_Size, No_List))))); + + -- Generate code to define the boolean that controls registration, in + -- order to avoid multiple registrations for tagged types defined in + -- multiple-called scopes. + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => No_Reg, + Object_Definition => New_Reference_To (Standard_Boolean, Loc), + Expression => New_Reference_To (Standard_True, Loc))); + + -- Set Access_Disp_Table field to be the dispatch table pointer + + if not Present (Access_Disp_Table (Typ)) then + Set_Access_Disp_Table (Typ, New_Elmt_List); + end if; + + Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ)); + + -- Generate code to create the storage for the type specific data object + -- with enough space to store the tags of the ancestors plus the tags + -- of all the implemented interfaces (as described in a-tags.adb). + + -- TSD: Storage_Array + -- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size); + -- for TSD'Alignment use Address'Alignment + + Size_Expr_Node := + Make_Op_Add (Loc, + Left_Opnd => + Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List), + Right_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => + Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List), + Right_Opnd => + Make_Integer_Literal (Loc, TSD_Num_Entries))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => TSD, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Size_Expr_Node)))))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (TSD, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + -- Generate code to put the Address of the TSD in the dispatch table + -- Set_TSD (DT_Ptr, TSD); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_TSD, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (TSD, Loc), + Attribute_Name => Name_Address)))); + + -- Generate: + -- Set_Num_Prim_Ops (T'Tag, Nb_Prim) + + if not Is_Interface (Typ) then + Append_To (Elab_Code, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), + Parameter_Associations => New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Nb_Prim)))); + end if; + + if Ada_Version >= Ada_05 + and then not Is_Interface (Typ) + and then not Is_Abstract (Typ) + and then not Is_Controlled (Typ) + and then Implements_Interface ( + Typ => Typ, + Kind => Any_Limited_Interface, + Check_Parent => True) + and then (Nb_Prim - Default_Prim_Op_Count) > 0 + then + -- Generate the Select Specific Data table for tagged types that + -- implement a synchronized interface. The size of the table is + -- constrained by the number of non-predefined primitive operations. + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => SSD, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To ( + RTE (RE_Select_Specific_Data), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, + Nb_Prim - Default_Prim_Op_Count)))))); + + -- Set the pointer to the Select Specific Data table in the TSD + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_SSD, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (SSD, Loc), + Attribute_Name => Name_Address)))); + end if; + + -- Generate: Exname : constant String := full_qualified_name (typ); + -- The type itself may be an anonymous parent type, so use the first + -- subtype to have a user-recognizable name. + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Exname, + Constant_Present => True, + Object_Definition => New_Reference_To (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + Full_Qualified_Name (First_Subtype (Typ))))); + + -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Expanded_Name, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Exname, Loc), + Attribute_Name => Name_Address)))); + + if not Is_Interface (Typ) then + -- Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Access_Level, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ))))); + end if; + + if Typ = Etype (Typ) + or else Is_CPP_Class (Etype (Typ)) + or else Is_Interface (Typ) + then + Old_Tag1 := + Unchecked_Convert_To (Generalized_Tag, + Make_Integer_Literal (Loc, 0)); + Old_Tag2 := + Unchecked_Convert_To (Generalized_Tag, + Make_Integer_Literal (Loc, 0)); + + else + Old_Tag1 := + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); + Old_Tag2 := + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); + end if; + + if Typ /= Etype (Typ) + and then not Is_Interface (Typ) + then + -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent); + + if not Is_Interface (Etype (Typ)) then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_DT, + Args => New_List ( + Node1 => Old_Tag1, + Node2 => New_Reference_To (DT_Ptr, Loc), + Node3 => + Make_Integer_Literal (Loc, + DT_Entry_Count (First_Tag_Component (Etype (Typ))))))); + end if; + + -- Inherit the secondary dispatch tables of the ancestor + + if not Is_CPP_Class (Etype (Typ)) then + declare + Sec_DT_Ancestor : Elmt_Id := + Next_Elmt + (First_Elmt + (Access_Disp_Table (Etype (Typ)))); + Sec_DT_Typ : Elmt_Id := + Next_Elmt + (First_Elmt + (Access_Disp_Table (Typ))); + + procedure Copy_Secondary_DTs (Typ : Entity_Id); + -- Local procedure required to climb through the ancestors and + -- copy the contents of all their secondary dispatch tables. + + ------------------------ + -- Copy_Secondary_DTs -- + ------------------------ + + procedure Copy_Secondary_DTs (Typ : Entity_Id) is + E : Entity_Id; + Iface : Elmt_Id; + + begin + -- Climb to the ancestor (if any) handling private types + + if Present (Full_View (Etype (Typ))) then + if Full_View (Etype (Typ)) /= Typ then + Copy_Secondary_DTs (Full_View (Etype (Typ))); + end if; + + elsif Etype (Typ) /= Typ then + Copy_Secondary_DTs (Etype (Typ)); + end if; + + if Present (Abstract_Interfaces (Typ)) + and then not Is_Empty_Elmt_List + (Abstract_Interfaces (Typ)) + then + Iface := First_Elmt (Abstract_Interfaces (Typ)); + E := First_Entity (Typ); + + while Present (E) + and then Present (Node (Sec_DT_Ancestor)) + loop + if Is_Tag (E) and then Chars (E) /= Name_uTag then + if not Is_Interface (Etype (Typ)) then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_DT, + Args => New_List ( + Node1 => Unchecked_Convert_To + (RTE (RE_Tag), + New_Reference_To + (Node (Sec_DT_Ancestor), + Loc)), + Node2 => Unchecked_Convert_To + (RTE (RE_Tag), + New_Reference_To + (Node (Sec_DT_Typ), Loc)), + Node3 => Make_Integer_Literal (Loc, + DT_Entry_Count (E))))); + end if; + + Next_Elmt (Sec_DT_Ancestor); + Next_Elmt (Sec_DT_Typ); + Next_Elmt (Iface); + end if; + + Next_Entity (E); + end loop; + end if; + end Copy_Secondary_DTs; + + begin + if Present (Node (Sec_DT_Ancestor)) then + + -- Handle private types + + if Present (Full_View (Typ)) then + Copy_Secondary_DTs (Full_View (Typ)); + else + Copy_Secondary_DTs (Typ); + end if; + end if; + end; + end if; + end if; + + -- Generate: + -- Inherit_TSD (parent'tag, DT_Ptr); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_TSD, + Args => New_List ( + Node1 => Old_Tag2, + Node2 => New_Reference_To (DT_Ptr, Loc)))); + + -- For types with no controlled components, generate: + -- Set_RC_Offset (DT_Ptr, 0); + + -- For simple types with controlled components, generate: + -- Set_RC_Offset (DT_Ptr, type._record_controller'position); + + -- For complex types with controlled components where the position + -- of the record controller is not statically computable, if there are + -- controlled components at this level, generate: + -- Set_RC_Offset (DT_Ptr, -1); + -- to indicate that the _controller field is right after the _parent + + -- Or if there are no controlled components at this level, generate: + -- Set_RC_Offset (DT_Ptr, -2); + -- to indicate that we need to get the position from the parent. + + if not Is_Interface (Typ) then + declare + Position : Node_Id; + + begin + if not Has_Controlled_Component (Typ) then + Position := Make_Integer_Literal (Loc, 0); + + elsif Etype (Typ) /= Typ + and then Has_Discriminants (Etype (Typ)) + then + if Has_New_Controlled_Component (Typ) then + Position := Make_Integer_Literal (Loc, -1); + else + Position := Make_Integer_Literal (Loc, -2); + end if; + else + Position := + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Typ, Loc), + Selector_Name => + New_Reference_To (Controller_Component (Typ), Loc)), + Attribute_Name => Name_Position); + + -- This is not proper Ada code to use the attribute 'Position + -- on something else than an object but this is supported by + -- the back end (see comment on the Bit_Component attribute in + -- sem_attr). So we avoid semantic checking here. + + -- Is this documented in sinfo.ads??? it should be! + + Set_Analyzed (Position); + Set_Etype (Prefix (Position), RTE (RE_Record_Controller)); + Set_Etype (Prefix (Prefix (Position)), Typ); + Set_Etype (Selector_Name (Prefix (Position)), + RTE (RE_Record_Controller)); + Set_Etype (Position, RTE (RE_Storage_Offset)); + end if; + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_RC_Offset, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => Position))); + end; + + -- Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is + -- described in E.4 (18) + + declare + Status : Entity_Id; + + begin + Status := + Boolean_Literals + (Is_Pure (Typ) + or else Is_Shared_Passive (Typ) + or else + ((Is_Remote_Types (Typ) + or else Is_Remote_Call_Interface (Typ)) + and then Original_View_In_Visible_Part (Typ)) + or else not Comes_From_Source (Typ)); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Remotely_Callable, + Args => New_List ( + New_Occurrence_Of (DT_Ptr, Loc), + New_Occurrence_Of (Status, Loc)))); + end; + + -- Generate: + -- Set_Offset_To_Top (DT_Ptr, 0); + + Append_To (Elab_Code, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Uint_0)))); + end if; + + -- Generate: Set_External_Tag (DT_Ptr, exname'Address); + -- Should be the external name not the qualified name??? + + if not Has_External_Tag_Rep_Clause (Typ) then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_External_Tag, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Exname, Loc), + Attribute_Name => Name_Address)))); + + -- Generate code to register the Tag in the External_Tag hash + -- table for the pure Ada type only. + + -- Register_Tag (Dt_Ptr); + + -- Skip this if routine not available, or in No_Run_Time mode + -- or Typ is an abstract interface type (because the table to + -- register it is not available in the abstract type but in + -- types implementing this interface) + + if not No_Run_Time_Mode + and then RTE_Available (RE_Register_Tag) + and then Is_RTE (Generalized_Tag, RE_Tag) + and then not Is_Interface (Typ) + then + Append_To (Elab_Code, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Register_Tag), Loc), + Parameter_Associations => + New_List (New_Reference_To (DT_Ptr, Loc)))); + end if; + end if; + + -- Generate: + -- if No_Reg then + -- <elab_code> + -- No_Reg := False; + -- end if; + + Append_To (Elab_Code, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (No_Reg, Loc), + Expression => New_Reference_To (Standard_False, Loc))); + + Append_To (Result, + Make_Implicit_If_Statement (Typ, + Condition => New_Reference_To (No_Reg, Loc), + Then_Statements => Elab_Code)); + + -- Ada 2005 (AI-251): Register the tag of the interfaces into + -- the table of implemented interfaces and ... + + if not Is_Interface (Typ) + and then Present (Abstract_Interfaces (Typ_Copy)) + and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ_Copy)) + then + AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); + while Present (AI) loop + + -- Generate: + -- Register_Interface (DT_Ptr, Interface'Tag); + + Append_To (Result, + Make_DT_Access_Action (Typ, + Action => Register_Interface_Tag, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => New_Reference_To + (Node + (First_Elmt + (Access_Disp_Table (Node (AI)))), + Loc)))); + + Next_Elmt (AI); + end loop; + end if; + + return Result; + end Make_DT; + + --------------------------- + -- Make_DT_Access_Action -- + --------------------------- + + function Make_DT_Access_Action + (Typ : Entity_Id; + Action : DT_Access_Action; + Args : List_Id) return Node_Id + is + Action_Name : constant Entity_Id := RTE (Ada_Actions (Action)); + Loc : Source_Ptr; + + begin + if No (Args) then + + -- This is a constant + + return New_Reference_To (Action_Name, Sloc (Typ)); + end if; + + pragma Assert (List_Length (Args) = Action_Nb_Arg (Action)); + + Loc := Sloc (First (Args)); + + if Action_Is_Proc (Action) then + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Action_Name, Loc), + Parameter_Associations => Args); + + else + return + Make_Function_Call (Loc, + Name => New_Reference_To (Action_Name, Loc), + Parameter_Associations => Args); + end if; + end Make_DT_Access_Action; + + ----------------------- + -- Make_Secondary_DT -- + ----------------------- + + procedure Make_Secondary_DT + (Typ : Entity_Id; + Ancestor_Typ : Entity_Id; + Suffix_Index : Int; + Iface : Entity_Id; + AI_Tag : Entity_Id; + Acc_Disp_Tables : in out Elist_Id; + Result : out List_Id) + is + Loc : constant Source_Ptr := Sloc (AI_Tag); + Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag); + Name_DT : constant Name_Id := New_Internal_Name ('T'); + Iface_DT : Node_Id; + Iface_DT_Ptr : Node_Id; + Name_DT_Ptr : Name_Id; + Nb_Prim : Int; + OSD : Entity_Id; + Size_Expr_Node : Node_Id; + Tname : Name_Id; + + begin + Result := New_List; + + -- Generate a unique external name associated with the secondary + -- dispatch table. This external name will be used to declare an + -- access to this secondary dispatch table, value that will be used + -- for the elaboration of Typ's objects and also for the elaboration + -- of objects of any derivation of Typ that do not override any + -- primitive operation of Typ. + + Get_Secondary_DT_External_Name (Typ, Ancestor_Typ, Suffix_Index); + + Tname := Name_Find; + Name_DT_Ptr := New_External_Name (Tname, "P"); + Iface_DT := Make_Defining_Identifier (Loc, Name_DT); + Iface_DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr); + + -- Dispatch table and related entities are allocated statically + + Set_Ekind (Iface_DT, E_Variable); + Set_Is_Statically_Allocated (Iface_DT); + + Set_Ekind (Iface_DT_Ptr, E_Variable); + Set_Is_Statically_Allocated (Iface_DT_Ptr); + + -- Generate code to create the storage for the Dispatch_Table object. + -- If the number of primitives of Typ is less that the number of + -- predefined primitives, we must reserve at least enough space + -- for the predefined primitives. + + Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag)); + + if Nb_Prim < Default_Prim_Op_Count then + Nb_Prim := Default_Prim_Op_Count; + end if; + + -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size); + -- for DT'Alignment use Address'Alignment + + Size_Expr_Node := + Make_Op_Add (Loc, + Left_Opnd => Make_DT_Access_Action (Etype (AI_Tag), + DT_Prologue_Size, + No_List), + Right_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => + Make_DT_Access_Action (Etype (AI_Tag), + DT_Entry_Size, + No_List), + Right_Opnd => + Make_Integer_Literal (Loc, Nb_Prim))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Iface_DT, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Size_Expr_Node)))))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (Iface_DT, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + -- Initialize the signature of the interface tag. It is a sequence of + -- two bytes located in the header of the dispatch table. The signature + -- of a Secondary Dispatch Table is (Valid_Signature, Secondary_DT). + + Append_To (Result, + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Iface_DT, Loc), + Expressions => New_List ( + Make_Integer_Literal (Loc, Uint_1))), + Expression => + Unchecked_Convert_To (RTE (RE_Storage_Element), + New_Reference_To (RTE (RE_Valid_Signature), Loc)))); + + Append_To (Result, + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Iface_DT, Loc), + Expressions => New_List ( + Make_Integer_Literal (Loc, Uint_2))), + Expression => + Unchecked_Convert_To (RTE (RE_Storage_Element), + New_Reference_To (RTE (RE_Secondary_DT), Loc)))); + + -- Generate code to create the pointer to the dispatch table + + -- Iface_DT_Ptr : Tag := Tag!(DT'Address); + + -- According to the C++ ABI, the base of the vtable is located + -- after the following prologue: Offset_To_Top, and Typeinfo_Ptr. + -- Hence, move the pointer down to the real base of the vtable. + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Iface_DT_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To (Generalized_Tag, Loc), + Expression => + Unchecked_Convert_To (Generalized_Tag, + Make_Op_Add (Loc, + Left_Opnd => + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Iface_DT, Loc), + Attribute_Name => Name_Address)), + Right_Opnd => + Make_DT_Access_Action (Etype (AI_Tag), + DT_Prologue_Size, No_List))))); + + -- Note: Offset_To_Top will be initialized by the init subprogram + + -- Set Access_Disp_Table field to be the dispatch table pointer + + if not (Present (Acc_Disp_Tables)) then + Acc_Disp_Tables := New_Elmt_List; + end if; + + Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables); + + -- Step 1: Generate an Object Specific Data (OSD) table + + OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + + -- Generate: + -- OSD : Ada.Tags.Object_Specific_Data + -- (Nb_Prims - Default_Prim_Op_Count); + -- where the constraint is used to allocate space for the + -- non-predefined primitive operations only. + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => OSD, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To ( + RTE (RE_Object_Specific_Data), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, + Nb_Prim - Default_Prim_Op_Count)))))); + + -- Generate: + -- Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD); + + Append_To (Result, + Make_DT_Access_Action (Typ, + Action => Set_OSD, + Args => New_List ( + New_Reference_To (Iface_DT_Ptr, Loc), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (OSD, Loc), + Attribute_Name => Name_Address)))); + + -- Offset table creation + + if not Is_Interface (Typ) + and then not Is_Abstract (Typ) + and then not Is_Controlled (Typ) + and then Implements_Interface + (Typ => Typ, + Kind => Any_Limited_Interface, + Check_Parent => True) + and then (Nb_Prim - Default_Prim_Op_Count) > 0 + then + declare + Prim : Entity_Id; + Prim_Alias : Entity_Id; + Prim_Elmt : Elmt_Id; + + begin + -- Step 2: Populate the OSD table + + Prim_Alias := Empty; + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Present (Abstract_Interface_Alias (Prim)) then + Prim_Alias := Abstract_Interface_Alias (Prim); + end if; + + if Present (Prim_Alias) + and then Present (First_Entity (Prim_Alias)) + and then Etype (First_Entity (Prim_Alias)) = Iface + then + -- Generate: + -- Ada.Tags.Set_Offset_Index ( + -- Iface_DT_Ptr, secondary_DT_Pos, primary_DT_pos); + + Append_To (Result, + Make_DT_Access_Action (Iface, + Action => Set_Offset_Index, + Args => New_List ( + New_Reference_To (Iface_DT_Ptr, Loc), + Make_Integer_Literal (Loc, DT_Position (Prim_Alias)), + Make_Integer_Literal (Loc, DT_Position (Prim))))); + + Prim_Alias := Empty; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + end if; + + -- Generate: + -- Set_Num_Prim_Ops (T'Tag, Nb_Prim) + + Append_To (Result, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Iface_DT_Ptr, Loc)), + Make_Integer_Literal (Loc, Nb_Prim)))); + + end Make_Secondary_DT; + + ------------------------------------- + -- Make_Select_Specific_Data_Table -- + ------------------------------------- + + function Make_Select_Specific_Data_Table + (Typ : Entity_Id) return List_Id + is + Assignments : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + + Conc_Typ : Entity_Id; + Decls : List_Id; + DT_Ptr : Entity_Id; + Prim : Entity_Id; + Prim_Als : Entity_Id; + Prim_Elmt : Elmt_Id; + Prim_Pos : Uint; + Nb_Prim : Int := 0; + + type Examined_Array is array (Int range <>) of Boolean; + + function Find_Entry_Index (E : Entity_Id) return Uint; + -- Given an entry, find its index in the visible declarations of the + -- corresponding concurrent type of Typ. + + ---------------------- + -- Find_Entry_Index -- + ---------------------- + + function Find_Entry_Index (E : Entity_Id) return Uint is + Index : Uint := Uint_1; + Subp_Decl : Entity_Id; + + begin + if Present (Decls) + and then not Is_Empty_List (Decls) + then + Subp_Decl := First (Decls); + while Present (Subp_Decl) loop + if Nkind (Subp_Decl) = N_Entry_Declaration then + if Defining_Identifier (Subp_Decl) = E then + return Index; + end if; + + Index := Index + 1; + end if; + + Next (Subp_Decl); + end loop; + end if; + + return Uint_0; + end Find_Entry_Index; + + -- Start of processing for Make_Select_Specific_Data_Table + + begin + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + + if Present (Corresponding_Concurrent_Type (Typ)) then + Conc_Typ := Corresponding_Concurrent_Type (Typ); + + if Ekind (Conc_Typ) = E_Protected_Type then + Decls := Visible_Declarations (Protected_Definition ( + Parent (Conc_Typ))); + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + Decls := Visible_Declarations (Task_Definition ( + Parent (Conc_Typ))); + end if; + end if; + + -- Count the non-predefined primitive operations + + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + if not Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then + Nb_Prim := Nb_Prim + 1; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + declare + Examined_Size : constant Int := Nb_Prim + Default_Prim_Op_Count; + Examined : Examined_Array (1 .. Examined_Size) := (others => False); + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + Prim_Pos := DT_Position (Prim); + + pragma Assert (UI_To_Int (Prim_Pos) <= Examined_Size); + + if Examined (UI_To_Int (Prim_Pos)) then + goto Continue; + else + Examined (UI_To_Int (Prim_Pos)) := True; + end if; + + -- The current primitive overrides an interface-level subprogram + + if Present (Abstract_Interface_Alias (Prim)) then + + -- Set the primitive operation kind regardless of subprogram + -- type. Generate: + -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>); + + Append_To (Assignments, + Make_DT_Access_Action (Typ, + Action => + Set_Prim_Op_Kind, + Args => + New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Prim_Pos), + Prim_Op_Kind (Prim, Typ)))); + + -- Retrieve the root of the alias chain if one is present + + if Present (Alias (Prim)) then + Prim_Als := Prim; + while Present (Alias (Prim_Als)) loop + Prim_Als := Alias (Prim_Als); + end loop; + else + Prim_Als := Empty; + end if; + + -- In the case of an entry wrapper, set the entry index + + if Ekind (Prim) = E_Procedure + and then Present (Prim_Als) + and then Is_Primitive_Wrapper (Prim_Als) + and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry + then + + -- Generate: + -- Ada.Tags.Set_Entry_Index (DT_Ptr, <position>, <index>); + + Append_To (Assignments, + Make_DT_Access_Action (Typ, + Action => + Set_Entry_Index, + Args => + New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Prim_Pos), + Make_Integer_Literal (Loc, + Find_Entry_Index (Wrapped_Entity (Prim_Als)))))); + end if; + end if; + + <<Continue>> + + Next_Elmt (Prim_Elmt); + end loop; + end; + + return Assignments; + end Make_Select_Specific_Data_Table; + ----------------------------------- -- Original_View_In_Visible_Part -- ----------------------------------- @@ -3342,6 +3772,11 @@ package body Exp_Disp is if Ekind (Full_Typ) = E_Protected_Type then return New_Reference_To (RTE (RE_POK_Protected_Function), Loc); + -- Task function + + elsif Ekind (Full_Typ) = E_Task_Type then + return New_Reference_To (RTE (RE_POK_Task_Function), Loc); + -- Regular function else @@ -3638,7 +4073,10 @@ package body Exp_Disp is -- Ada 2005 (AI-251) - if Present (Abstract_Interface_Alias (Prim)) then + if Present (Abstract_Interface_Alias (Prim)) + and then Is_Interface (Scope (DTC_Entity + (Abstract_Interface_Alias (Prim)))) + then Set_DTC_Entity (Prim, Find_Interface_Tag (T => Typ, diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 469ea79..bdc1417 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -28,8 +28,144 @@ -- dispatching expansion. with Types; use Types; + package Exp_Disp is + ------------------------------------- + -- Predefined primitive operations -- + ------------------------------------- + + -- The predefined primitive operations (PPOs) are subprograms generated + -- by GNAT for a particular tagged type. Their role is to provide support + -- for different Ada language features such as the attribute 'Size or + -- handling of dispatching triggers in select statements. PPOs are created + -- when a tagged type is expanded or frozen. These subprograms are later + -- collected and inserted into the dispatch table of a tagged type at + -- fixed positions. Some of the PPOs that manipulate data in tagged objects + -- require the generation of thunks. + + -- List of predefined primitive operations + + -- Leading underscores designate reserved names. Bracketed numerical + -- values represent dispatch table slot numbers. + + -- _Size (1) - implementation of the attribute 'Size for any tagged + -- type. Constructs of the form Prefix'Size are converted into + -- Prefix._Size. + + -- _Alignment (2) - implementation of the attribute 'Alignment for + -- any tagged type. Constructs of the form Prefix'Alignment are + -- converted into Prefix._Alignment. + + -- TSS_Stream_Read (3) - implementation of the stream attribute Read + -- for any tagged type. + + -- TSS_Stream_Write (4) - implementation of the stream attribute Write + -- for any tagged type. + + -- TSS_Stream_Input (5) - implementation of the stream attribute Input + -- for any tagged type. + + -- TSS_Stream_Output (6) - implementation of the stream attribute + -- Output for any tagged type. + + -- Op_Eq (7) - implementation of the equality operator for any non- + -- limited tagged type. + + -- _Assign (8) - implementation of the assignment operator for any + -- non-limited tagged type. + + -- TSS_Deep_Adjust (9) - implementation of the finalization operation + -- Adjust for any non-limited tagged type. + + -- TSS_Deep_Finalize (10) - implementation of the finalization + -- operation Finalize for any non-limited tagged type. + + -- _Disp_Asynchronous_Select (11) - used in the expansion of ATC with + -- dispatching triggers. Null implementation for limited interfaces, + -- full body generation for types that implement limited interfaces, + -- not generated for the rest of the cases. See Expand_N_Asynchronous_ + -- Select in Exp_Ch9 for more information. + + -- _Disp_Conditional_Select (12) - used in the expansion of conditional + -- selects with dispatching triggers. Null implementation for limited + -- interfaces, full body generation for types that implement limited + -- interfaces, not generated for the rest of the cases. See Expand_N_ + -- Conditional_Entry_Call in Exp_Ch9 for more information. + + -- _Disp_Get_Prim_Op_Kind (13) - helper routine used in the expansion + -- of ATC with dispatching triggers. Null implementation for limited + -- interfaces, full body generation for types that implement limited + -- interfaces, not generated for the rest of the cases. + + -- _Disp_Get_Task_Id (14) - helper routine used in the expansion of + -- Abort, attributes 'Callable and 'Terminated for task interface + -- class-wide types. Full body generation for task types, null + -- implementation for limited interfaces, not generated for the rest + -- of the cases. See Expand_N_Attribute_Reference in Exp_Attr and + -- Expand_N_Abort_Statement in Exp_Ch9 for more information. + + -- _Disp_Timed_Select (15) - used in the expansion of timed selects + -- with dispatching triggers. Null implementation for limited + -- interfaces, full body generation for types that implement limited + -- interfaces, not generated for the rest of the cases. See Expand_N_ + -- Timed_Entry_Call for more information. + + -- Lifecycle of predefined primitive operations + + -- The specifications and bodies of the PPOs are created by + -- Make_Predefined_Primitive_Specs and Predefined_Primitive_Bodies + -- in Exp_Ch3. The generated specifications are immediately analyzed, + -- while the bodies are left as freeze actions to the tagged type for + -- which they are created. + + -- PPOs are collected and added to the Primitive_Operations list of + -- a type by the regular analysis mechanism. + + -- PPOs are frozen in Predefined_Primitive_Freeze in Exp_Ch3. + + -- Thunks for PPOs are created in Freeze_Subprogram in Exp_Ch6, by a + -- call to Register_Predefined_DT_Entry, also in Exp_Ch6. + + -- Dispatch table positions of PPOs are set in Set_All_DT_Position in + -- Exp_Disp. + + -- Calls to PPOs procede as regular dispatching calls. If the PPO + -- has a thunk, a call procedes as a regular dispatching call with + -- a thunk. + + -- Guidelines for addition of new predefined primitive operations + + -- Update the value of constant Default_Prim_Op_Count in Exp_Disp.ads + -- to reflect the new number of PPOs. + + -- Update the value of constant Default_Prim_Op_Count in A-Tags.ads + -- to reflect the new number of PPOs. This value should be the same + -- as the one in Exp_Disp.ads. + + -- Introduce a new predefined name for the new PPO in Snames.ads and + -- Snames.adb. + + -- Categorize the new PPO name as predefined by adding an entry in + -- Is_Predefined_Dispatching_Operation in Exp_Util.adb. + + -- Reserve a dispatch table position for the new PPO by adding an entry + -- in Default_Prim_Op_Position in Exp_Disp.adb. + + -- Generate the specification of the new PPO in Make_Predefined_ + -- Primitive_Spec in Exp_Ch3.adb. The Is_Internal flag of the defining + -- identifier of the specification must be set to True. + + -- Generate the body of the new PPO in Predefined_Primitive_Bodies in + -- Exp_Ch3.adb. The Is_Internal flag of the defining identifier of the + -- specification must be set to True. + + -- If the new PPO requires a thunk, add an entry in Freeze_Subprogram + -- in Exp_Ch6.adb. + + -- When generating calls to a PPO, use Find_Prim_Op from Exp_Util.ads + -- to retrieve the entity of the operation directly. + -- Number of predefined primitive operations added by the Expander -- for a tagged type. If more predefined primitive operations are -- added, the following items must be changed: @@ -38,7 +174,7 @@ package Exp_Disp is -- Exp_Disp.Default_Prim_Op_Position - indirect use -- Exp_Disp.Set_All_DT_Position - direct use - Default_Prim_Op_Count : constant Int := 14; + Default_Prim_Op_Count : constant Int := 15; type DT_Access_Action is (CW_Membership, @@ -48,6 +184,7 @@ package Exp_Disp is Get_Access_Level, Get_Entry_Index, Get_External_Tag, + Get_Offset_Index, Get_Prim_Op_Address, Get_Prim_Op_Kind, Get_RC_Offset, @@ -60,10 +197,13 @@ package Exp_Disp is Set_Entry_Index, Set_Expanded_Name, Set_External_Tag, + Set_Offset_Index, + Set_OSD, Set_Prim_Op_Address, Set_Prim_Op_Kind, Set_RC_Offset, Set_Remotely_Callable, + Set_SSD, Set_TSD, TSD_Entry_Size, TSD_Prologue_Size); @@ -117,16 +257,6 @@ package Exp_Disp is -- Ada 2005 (AI-251): Initialize the entries associated with predefined -- primitives in all the secondary dispatch tables of Typ. - procedure Make_Abstract_Interface_DT - (AI_Tag : Entity_Id; - Acc_Disp_Tables : in out Elist_Id; - Result : out List_Id); - -- Ada 2005 (AI-251): Expand the declarations for the secondary Dispatch - -- Tables corresponding with an abstract interface. The reference to the - -- dispatch table is appended at the end of Acc_Disp_Tables; it will be - -- are later used to generate the corresponding initialization statement - -- (see Exp_Ch3.Build_Init_Procedure). - function Make_DT_Access_Action (Typ : Entity_Id; Action : DT_Access_Action; @@ -141,7 +271,8 @@ package Exp_Disp is function Make_Disp_Asynchronous_Select_Body (Typ : Entity_Id) return Node_Id; -- Ada 2005 (AI-345): Generate the body of the primitive operation of type - -- Typ used for dispatching in asynchronous selects. + -- Typ used for dispatching in asynchronous selects. Generate a null body + -- if Typ is an interface type. function Make_Disp_Asynchronous_Select_Spec (Typ : Entity_Id) return Node_Id; @@ -151,7 +282,8 @@ package Exp_Disp is function Make_Disp_Conditional_Select_Body (Typ : Entity_Id) return Node_Id; -- Ada 2005 (AI-345): Generate the body of the primitive operation of type - -- Typ used for dispatching in conditional selects. + -- Typ used for dispatching in conditional selects. Generate a null body + -- if Typ is an interface type. function Make_Disp_Conditional_Select_Spec (Typ : Entity_Id) return Node_Id; @@ -162,7 +294,7 @@ package Exp_Disp is (Typ : Entity_Id) return Node_Id; -- Ada 2005 (AI-345): Generate the body of the primitive operation of type -- Typ used for retrieving the callable entity kind during dispatching in - -- asynchronous selects. + -- asynchronous selects. Generate a null body if Typ is an interface type. function Make_Disp_Get_Prim_Op_Kind_Spec (Typ : Entity_Id) return Node_Id; @@ -170,23 +302,52 @@ package Exp_Disp is -- of the type Typ use for retrieving the callable entity kind during -- dispatching in asynchronous selects. - function Make_Disp_Select_Tables - (Typ : Entity_Id) return List_Id; - -- Ada 2005 (AI-345): Populate the two auxiliary tables in the TSD of Typ - -- used for dispatching in asynchronous, conditional and timed selects. - -- Generate code to set the primitive operation kinds and entry indices - -- of primitive operations and primitive wrappers. + function Make_Disp_Get_Task_Id_Body + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the body of the primitive operation of type + -- Typ used for retrieving the _task_id field of a task interface class- + -- wide type. Generate a null body if Typ is an interface or a non-task + -- type. + + function Make_Disp_Get_Task_Id_Spec + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the specification of the primitive operation + -- of type Typ used for retrieving the _task_id field of a task interface + -- class-wide type. function Make_Disp_Timed_Select_Body (Typ : Entity_Id) return Node_Id; -- Ada 2005 (AI-345): Generate the body of the primitive operation of type - -- Typ used for dispatching in timed selects. + -- Typ used for dispatching in timed selects. Generate a null body if Nul + -- is an interface type. function Make_Disp_Timed_Select_Spec (Typ : Entity_Id) return Node_Id; -- Ada 2005 (AI-345): Generate the specification of the primitive operation -- of type Typ used for dispatching in timed selects. + function Make_Select_Specific_Data_Table + (Typ : Entity_Id) return List_Id; + -- Ada 2005 (AI-345): Create and populate the auxiliary table in the TSD + -- of Typ used for dispatching in asynchronous, conditional and timed + -- selects. Generate code to set the primitive operation kinds and entry + -- indices of primitive operations and primitive wrappers. + + procedure Make_Secondary_DT + (Typ : Entity_Id; + Ancestor_Typ : Entity_Id; + Suffix_Index : Int; + Iface : Entity_Id; + AI_Tag : Entity_Id; + Acc_Disp_Tables : in out Elist_Id; + Result : out List_Id); + -- Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch + -- Table of Typ associated with Iface (each abstract interface implemented + -- by Typ has a secondary dispatch table). The arguments Typ, Ancestor_Typ + -- and Suffix_Index are used to generate an unique external name which + -- is added at the end of Acc_Disp_Tables; this external name will be + -- used later by the subprogram Exp_Ch3.Build_Init_Procedure. + procedure Set_All_DT_Position (Typ : Entity_Id); -- Set the DT_Position field for each primitive operation. In the CPP -- Class case check that no pragma CPP_Virtual is missing and that the diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index ebef01d..c6924e9 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -1275,6 +1275,16 @@ package body Exp_Util is then null; + -- Nothing to be done for derived types with unknown discriminants if + -- the parent type also has unknown discriminants. + + elsif Is_Record_Type (Unc_Type) + and then not Is_Class_Wide_Type (Unc_Type) + and then Has_Unknown_Discriminants (Unc_Type) + and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type)) + then + null; + -- Nothing to be done if the type of the expression is limited, because -- in this case the expression cannot be copied, and its use can only -- be by reference and there is no need for the actual subtype. @@ -1289,8 +1299,147 @@ package body Exp_Util is end if; end Expand_Subtype_From_Expr; + -------------------------------- + -- Find_Implemented_Interface -- + -------------------------------- + + -- Given the following code (XXX denotes irrelevant value): + + -- type Limd_Iface is limited interface; + -- type Prot_Iface is protected interface; + -- type Sync_Iface is synchronized interface; + + -- type Parent_Subtype is new Limd_Iface and Sync_Iface with ... + -- type Child_Subtype is new Parent_Subtype and Prot_Iface with ... + + -- The following calls will return the following values: + + -- Find_Implemented_Interface + -- (Child_Subtype, Synchronized_Interface, False) -> Empty + + -- Find_Implemented_Interface + -- (Child_Subtype, Synchronized_Interface, True) -> Sync_Iface + + -- Find_Implemented_Interface + -- (Child_Subtype, Any_Synchronized_Interface, XXX) -> Prot_Iface + + -- Find_Implemented_Interface + -- (Child_Subtype, Any_Limited_Interface, XXX) -> Prot_Iface + + function Find_Implemented_Interface + (Typ : Entity_Id; + Kind : Interface_Kind; + Check_Parent : Boolean := False) return Entity_Id + is + Iface_Elmt : Elmt_Id; + + function Interface_In_Kind + (I : Entity_Id; + Kind : Interface_Kind) return Boolean; + -- Determine whether an interface falls into a specified kind + + ----------------------- + -- Interface_In_Kind -- + ----------------------- + + function Interface_In_Kind + (I : Entity_Id; + Kind : Interface_Kind) return Boolean is + begin + if Is_Limited_Interface (I) + and then (Kind = Any_Interface + or else Kind = Any_Limited_Interface + or else Kind = Limited_Interface) + then + return True; + + elsif Is_Protected_Interface (I) + and then (Kind = Any_Interface + or else Kind = Any_Limited_Interface + or else Kind = Any_Synchronized_Interface + or else Kind = Protected_Interface) + then + return True; + + elsif Is_Synchronized_Interface (I) + and then (Kind = Any_Interface + or else Kind = Any_Limited_Interface + or else Kind = Synchronized_Interface) + then + return True; + + elsif Is_Task_Interface (I) + and then (Kind = Any_Interface + or else Kind = Any_Limited_Interface + or else Kind = Any_Synchronized_Interface + or else Kind = Task_Interface) + then + return True; + + -- Regular interface. This should be the last kind to check since + -- all of the previous cases have their Is_Interface flags set. + + elsif Is_Interface (I) + and then (Kind = Any_Interface + or else Kind = Iface) + then + return True; + + else + return False; + end if; + end Interface_In_Kind; + + -- Start of processing for Find_Implemented_Interface + + begin + if not Is_Tagged_Type (Typ) then + return Empty; + end if; + + -- Implementations of the form: + -- Typ is new Interface ... + + if Is_Interface (Etype (Typ)) + and then Interface_In_Kind (Etype (Typ), Kind) + then + return Etype (Typ); + end if; + + -- Implementations of the form: + -- Typ is new Typ_Parent and Interface ... + + if Present (Abstract_Interfaces (Typ)) then + Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ)); + while Present (Iface_Elmt) loop + if Interface_In_Kind (Node (Iface_Elmt), Kind) then + return Node (Iface_Elmt); + end if; + + Iface_Elmt := Next_Elmt (Iface_Elmt); + end loop; + end if; + + -- Typ is a derived type and may implement a limited interface + -- through its parent subtype. Check the parent subtype as well + -- as any interfaces explicitly implemented at this level. + + if Check_Parent + and then Ekind (Typ) = E_Record_Type + and then Present (Parent_Subtype (Typ)) + then + return Find_Implemented_Interface ( + Parent_Subtype (Typ), Kind, Check_Parent); + end if; + + -- Typ does not implement a limited interface either at this level or + -- in any of its parent subtypes. + + return Empty; + end Find_Implemented_Interface; + ------------------------ - -- Find_Interface_Tag -- + -- Find_Interface_ADT -- ------------------------ function Find_Interface_ADT @@ -1302,7 +1451,7 @@ package body Exp_Util is Typ : Entity_Id := T; procedure Find_Secondary_Table (Typ : Entity_Id); - -- Comment required ??? + -- Internal subprogram used to recursively climb to the ancestors -------------------------- -- Find_Secondary_Table -- @@ -1313,10 +1462,23 @@ package body Exp_Util is AI : Node_Id; begin - if Etype (Typ) /= Typ then + -- Climb to the ancestor (if any) handling private types + + if Present (Full_View (Etype (Typ))) then + if Full_View (Etype (Typ)) /= Typ then + Find_Secondary_Table (Full_View (Etype (Typ))); + end if; + + elsif Etype (Typ) /= Typ then Find_Secondary_Table (Etype (Typ)); end if; + -- If we already found it there is nothing else to do + + if Found then + return; + end if; + if Present (Abstract_Interfaces (Typ)) and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) then @@ -1401,9 +1563,14 @@ package body Exp_Util is return; end if; - -- Climb to the root type + -- Climb to the root type handling private types + + if Present (Full_View (Etype (Typ))) then + if Full_View (Etype (Typ)) /= Typ then + Find_Tag (Full_View (Etype (Typ))); + end if; - if Etype (Typ) /= Typ then + elsif Etype (Typ) /= Typ then Find_Tag (Etype (Typ)); end if; @@ -1437,6 +1604,8 @@ package body Exp_Util is -- Start of processing for Find_Interface_Tag begin + pragma Assert (Is_Interface (Iface)); + -- Handle private types if Has_Private_Declaration (Typ) @@ -1742,67 +1911,17 @@ package body Exp_Util is return Count; end Homonym_Number; - ---------------------------------- - -- Implements_Limited_Interface -- - ---------------------------------- - - function Implements_Limited_Interface (Typ : Entity_Id) return Boolean is - function Contains_Limited_Interface - (Ifaces : Elist_Id) return Boolean; - -- Given a list of interfaces, determine whether one of them is limited - - -------------------------------- - -- Contains_Limited_Interface -- - -------------------------------- - - function Contains_Limited_Interface - (Ifaces : Elist_Id) return Boolean - is - Iface_Elmt : Elmt_Id; - - begin - if not Present (Ifaces) then - return False; - end if; - - Iface_Elmt := First_Elmt (Ifaces); - - while Present (Iface_Elmt) loop - if Is_Limited_Record (Node (Iface_Elmt)) then - return True; - end if; - - Iface_Elmt := Next_Elmt (Iface_Elmt); - end loop; - - return False; - end Contains_Limited_Interface; - - -- Start of processing for Implements_Limited_Interface + -------------------------- + -- Implements_Interface -- + -------------------------- + function Implements_Interface + (Typ : Entity_Id; + Kind : Interface_Kind; + Check_Parent : Boolean := False) return Boolean is begin - -- Typ is a derived type and may implement a limited interface - -- through its parent subtype. Check the parent subtype as well - -- as any interfaces explicitly implemented at this level. - - if Ekind (Typ) = E_Record_Type - and then Present (Parent_Subtype (Typ)) - then - return Contains_Limited_Interface (Abstract_Interfaces (Typ)) - or else Implements_Limited_Interface (Parent_Subtype (Typ)); - - -- Typ is an abstract type derived from some interface - - elsif Is_Abstract (Typ) then - return Is_Interface (Etype (Typ)) - and then Is_Limited_Record (Etype (Typ)); - - -- Typ may directly implement some interface - - else - return Contains_Limited_Interface (Abstract_Interfaces (Typ)); - end if; - end Implements_Limited_Interface; + return Find_Implemented_Interface (Typ, Kind, Check_Parent) /= Empty; + end Implements_Interface; ------------------------------ -- In_Unconditional_Context -- @@ -2436,7 +2555,6 @@ package body Exp_Util is if Suppress = All_Checks then declare Svg : constant Suppress_Array := Scope_Suppress; - begin Scope_Suppress := (others => True); Insert_Actions (Assoc_Node, Ins_Actions); @@ -2446,7 +2564,6 @@ package body Exp_Util is else declare Svg : constant Boolean := Scope_Suppress (Suppress); - begin Scope_Suppress (Suppress) := True; Insert_Actions (Assoc_Node, Ins_Actions); @@ -2557,12 +2674,12 @@ package body Exp_Util is return True; end Is_All_Null_Statements; - ------------------------ - -- Is_Default_Prim_Op -- - ------------------------ + ----------------------------------------- + -- Is_Predefined_Dispatching_Operation -- + ----------------------------------------- function Is_Predefined_Dispatching_Operation - (Subp : Entity_Id) return Boolean + (Subp : Entity_Id) return Boolean is TSS_Name : TSS_Name_Type; E : Entity_Id := Subp; @@ -2590,10 +2707,12 @@ package body Exp_Util is or else Chars (E) = Name_uAssign or else TSS_Name = TSS_Deep_Adjust or else TSS_Name = TSS_Deep_Finalize - or else Chars (E) = Name_uDisp_Asynchronous_Select - or else Chars (E) = Name_uDisp_Conditional_Select - or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind - or else Chars (E) = Name_uDisp_Timed_Select + or else (Ada_Version >= Ada_05 + and then (Chars (E) = Name_uDisp_Asynchronous_Select + or else Chars (E) = Name_uDisp_Conditional_Select + or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind + or else Chars (E) = Name_uDisp_Get_Task_Id + or else Chars (E) = Name_uDisp_Timed_Select)) then return True; end if; @@ -3466,7 +3585,7 @@ package body Exp_Util is return New_Occurrence_Of (CW_Subtype, Loc); end; - -- Comment needed (what case is this ???) + -- Indefinite record type with discriminants. else D := First_Discriminant (Unc_Typ); diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index a63cc71..2afb88f8 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -33,6 +33,21 @@ with Types; use Types; package Exp_Util is + -- An enumeration type used to capture all the possible interface + -- kinds and their hierarchical relation. These values are used in + -- Find_Implemented_Interface and Implements_Interface. + + type Interface_Kind is ( + Any_Interface, -- Any interface + Any_Limited_Interface, -- Only limited interfaces + Any_Synchronized_Interface, -- Only synchronized interfaces + + Iface, -- Individual kinds + Limited_Interface, + Protected_Interface, + Synchronized_Interface, + Task_Interface); + ----------------------------------------------- -- Handling of Actions Associated with Nodes -- ----------------------------------------------- @@ -325,17 +340,27 @@ package Exp_Util is -- class-wide). function Find_Interface_ADT - (T : Entity_Id; - Iface : Entity_Id) return Entity_Id; + (T : Entity_Id; + Iface : Entity_Id) return Entity_Id; -- Ada 2005 (AI-251): Given a type T implementing the interface Iface, -- return the Access_Disp_Table value of the interface. function Find_Interface_Tag - (T : Entity_Id; - Iface : Entity_Id) return Entity_Id; + (T : Entity_Id; + Iface : Entity_Id) return Entity_Id; -- Ada 2005 (AI-251): Given a type T implementing the interface Iface, -- return the record component containing the tag of Iface. + function Find_Implemented_Interface + (Typ : Entity_Id; + Kind : Interface_Kind; + Check_Parent : Boolean := False) return Entity_Id; + -- Ada 2005 (AI-345): Find a designated kind of interface implemented by + -- Typ or any parent subtype. Return the first encountered interface that + -- correspond to the selected class. Return Empty if no such interface is + -- found. Use Check_Parent to climb a potential derivation chain and + -- examine the parent subtypes for any implementation. + function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id; -- Find the first primitive operation of type T whose name is 'Name'. -- This function allows the use of a primitive operation which is not @@ -410,11 +435,13 @@ package Exp_Util is -- chain, counting only entries in the curren scope. If an entity is not -- overloaded, the returned number will be one. - function Implements_Limited_Interface (Typ : Entity_Id) return Boolean; - -- Ada 2005 (AI-345): Determine whether Typ implements some limited - -- interface. The interface may be of limited, protected, synchronized - -- or taks kind. Typ may also be derived from a type that implements a - -- limited interface. + function Implements_Interface + (Typ : Entity_Id; + Kind : Interface_Kind; + Check_Parent : Boolean := False) return Boolean; + -- Ada 2005 (AI-345): Determine whether Typ implements a designated kind + -- of interface. Use Check_Parent to climb a potential derivation chain + -- and examine the parent subtypes for any implementation. function Inside_Init_Proc return Boolean; -- Returns True if current scope is within an init proc diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 07adc39..8b19055 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -209,9 +209,14 @@ package Rtsfind is System_Exp_Mod, System_Exp_Uns, System_Fat_Flt, + System_Fat_IEEE_Long_Float, + System_Fat_IEEE_Short_Float, System_Fat_LFlt, System_Fat_LLF, System_Fat_SFlt, + System_Fat_VAX_D_Float, + System_Fat_VAX_F_Float, + System_Fat_VAX_G_Float, System_Finalization_Implementation, System_Finalization_Root, System_Fore, @@ -493,6 +498,7 @@ package Rtsfind is RE_Get_Access_Level, -- Ada.Tags RE_Get_Entry_Index, -- Ada.Tags RE_Get_External_Tag, -- Ada.Tags + RE_Get_Offset_Index, -- Ada.Tags RE_Get_Prim_Op_Address, -- Ada.Tags RE_Get_Prim_Op_Kind, -- Ada.Tags RE_Get_RC_Offset, -- Ada.Tags @@ -501,25 +507,32 @@ package Rtsfind is RE_Inherit_TSD, -- Ada.Tags RE_Internal_Tag, -- Ada.Tags RE_Is_Descendant_At_Same_Level, -- Ada.Tags + RE_Object_Specific_Data, -- Ada.Tags RE_POK_Function, -- Ada.Tags RE_POK_Procedure, -- Ada.Tags RE_POK_Protected_Entry, -- Ada.Tags RE_POK_Protected_Function, -- Ada.Tags RE_POK_Protected_Procedure, -- Ada.Tags RE_POK_Task_Entry, -- Ada.Tags + RE_POK_Task_Function, -- Ada.Tags RE_POK_Task_Procedure, -- Ada.Tags RE_Prim_Op_Kind, -- Ada.Tags RE_Register_Interface_Tag, -- Ada.Tags RE_Register_Tag, -- Ada.Tags + RE_Select_Specific_Data, -- Ada.Tags RE_Set_Access_Level, -- Ada.Tags RE_Set_Entry_Index, -- Ada.Tags RE_Set_Expanded_Name, -- Ada.Tags RE_Set_External_Tag, -- Ada.Tags + RE_Set_Num_Prim_Ops, -- Ada.Tags + RE_Set_Offset_Index, -- Ada.Tags RE_Set_Offset_To_Top, -- Ada.Tags + RE_Set_OSD, -- 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_TSD, -- Ada.Tags RE_Tag_Error, -- Ada.Tags RE_TSD_Entry_Size, -- Ada.Tags @@ -527,6 +540,10 @@ package Rtsfind is RE_Interface_Tag, -- Ada.Tags RE_Tag, -- Ada.Tags RE_Address_Array, -- Ada.Tags + RE_Valid_Signature, -- Ada.Tags + RE_Primary_DT, -- Ada.Tags + RE_Secondary_DT, -- Ada.Tags + RE_Abstract_Interface, -- Ada.Tags RE_Abort_Task, -- Ada.Task_Identification RE_Current_Task, -- Ada.Task_Identification @@ -666,13 +683,28 @@ package Rtsfind is RE_Exp_Unsigned, -- System.Exp_Uns - RE_Fat_Float, -- System.Fat_Flt + RE_Attr_Float, -- System.Fat_Flt - RE_Fat_Long_Float, -- System.Fat_LFlt + RE_Attr_IEEE_Long, -- System.Fat_IEEE_Long_Float + RE_Fat_IEEE_Long, -- System.Fat_IEEE_Long_Float - RE_Fat_Long_Long_Float, -- System.Fat_LLF + RE_Attr_IEEE_Short, -- System.Fat_IEEE_Short_Float + RE_Fat_IEEE_Short, -- System.Fat_IEEE_Short_Float - RE_Fat_Short_Float, -- System.Fat_SFlt + RE_Attr_Long_Float, -- System.Fat_LFlt + + RE_Attr_Long_Long_Float, -- System.Fat_LLF + + RE_Attr_Short_Float, -- System.Fat_SFlt + + RE_Attr_VAX_D_Float, -- System.Fat_VAX_D_Float + RE_Fat_VAX_D, -- System.Fat_VAX_D_Float + + RE_Attr_VAX_F_Float, -- System.Fat_VAX_F_Float + RE_Fat_VAX_F, -- System.Fat_VAX_F_Float + + RE_Attr_VAX_G_Float, -- System.Fat_VAX_G_Float + RE_Fat_VAX_G, -- System.Fat_VAX_G_Float RE_Attach_To_Final_List, -- System.Finalization_Implementation RE_Finalize_List, -- System.Finalization_Implementation @@ -1151,6 +1183,7 @@ package Rtsfind is RE_TC_Alias, -- System.PolyORB_Interface RE_TC_Build, -- System.PolyORB_Interface + RE_Get_TC, -- System.PolyORB_Interface RE_Set_TC, -- System.PolyORB_Interface RE_TC_Any, -- System.PolyORB_Interface RE_TC_AD, -- System.PolyORB_Interface @@ -1219,6 +1252,7 @@ package Rtsfind is RE_Integer_Address, -- System.Storage_Elements RE_Storage_Offset, -- System.Storage_Elements RE_Storage_Array, -- System.Storage_Elements + RE_Storage_Element, -- System.Storage_Elements RE_To_Address, -- System.Storage_Elements RE_Root_Storage_Pool, -- System.Storage_Pools @@ -1291,6 +1325,7 @@ package Rtsfind is RE_Task_Procedure_Access, -- System.Tasking RO_ST_Task_Id, -- System.Tasking + RO_ST_Null_Task, -- System.Tasking RE_Call_Modes, -- System.Tasking RE_Simple_Call, -- System.Tasking @@ -1417,6 +1452,8 @@ package Rtsfind is RE_Le_G, -- System.Vax_Float_Operations RE_Lt_F, -- System.Vax_Float_Operations RE_Lt_G, -- System.Vax_Float_Operations + RE_Ne_F, -- System.Vax_Float_Operations + RE_Ne_G, -- System.Vax_Float_Operations RE_Valid_D, -- System.Vax_Float_Operations RE_Valid_F, -- System.Vax_Float_Operations @@ -1602,6 +1639,7 @@ package Rtsfind is RE_Get_Access_Level => Ada_Tags, RE_Get_Entry_Index => Ada_Tags, RE_Get_External_Tag => Ada_Tags, + RE_Get_Offset_Index => Ada_Tags, RE_Get_Prim_Op_Address => Ada_Tags, RE_Get_Prim_Op_Kind => Ada_Tags, RE_Get_RC_Offset => Ada_Tags, @@ -1610,25 +1648,32 @@ package Rtsfind is RE_Inherit_TSD => Ada_Tags, RE_Internal_Tag => Ada_Tags, RE_Is_Descendant_At_Same_Level => Ada_Tags, + RE_Object_Specific_Data => Ada_Tags, RE_POK_Function => Ada_Tags, RE_POK_Procedure => Ada_Tags, RE_POK_Protected_Entry => Ada_Tags, RE_POK_Protected_Function => Ada_Tags, RE_POK_Protected_Procedure => Ada_Tags, RE_POK_Task_Entry => Ada_Tags, + RE_POK_Task_Function => Ada_Tags, RE_POK_Task_Procedure => Ada_Tags, RE_Prim_Op_Kind => Ada_Tags, RE_Register_Interface_Tag => Ada_Tags, RE_Register_Tag => Ada_Tags, + RE_Select_Specific_Data => Ada_Tags, RE_Set_Access_Level => Ada_Tags, RE_Set_Entry_Index => Ada_Tags, RE_Set_Expanded_Name => Ada_Tags, RE_Set_External_Tag => Ada_Tags, + RE_Set_Num_Prim_Ops => Ada_Tags, + RE_Set_Offset_Index => Ada_Tags, RE_Set_Offset_To_Top => Ada_Tags, + RE_Set_OSD => 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_TSD => Ada_Tags, RE_Tag_Error => Ada_Tags, RE_TSD_Entry_Size => Ada_Tags, @@ -1636,6 +1681,10 @@ package Rtsfind is RE_Interface_Tag => Ada_Tags, RE_Tag => Ada_Tags, RE_Address_Array => Ada_Tags, + RE_Valid_Signature => Ada_Tags, + RE_Primary_DT => Ada_Tags, + RE_Secondary_DT => Ada_Tags, + RE_Abstract_Interface => Ada_Tags, RE_Abort_Task => Ada_Task_Identification, RE_Current_Task => Ada_Task_Identification, @@ -1773,13 +1822,28 @@ package Rtsfind is RE_Exp_Unsigned => System_Exp_Uns, - RE_Fat_Float => System_Fat_Flt, + RE_Attr_Float => System_Fat_Flt, + + RE_Attr_IEEE_Long => System_Fat_IEEE_Long_Float, + RE_Fat_IEEE_Long => System_Fat_IEEE_Long_Float, + + RE_Attr_IEEE_Short => System_Fat_IEEE_Short_Float, + RE_Fat_IEEE_Short => System_Fat_IEEE_Short_Float, + + RE_Attr_Long_Float => System_Fat_LFlt, + + RE_Attr_Long_Long_Float => System_Fat_LLF, + + RE_Attr_Short_Float => System_Fat_SFlt, - RE_Fat_Long_Float => System_Fat_LFlt, + RE_Attr_VAX_D_Float => System_Fat_VAX_D_Float, + RE_Fat_VAX_D => System_Fat_VAX_D_Float, - RE_Fat_Long_Long_Float => System_Fat_LLF, + RE_Attr_VAX_F_Float => System_Fat_VAX_F_Float, + RE_Fat_VAX_F => System_Fat_VAX_F_Float, - RE_Fat_Short_Float => System_Fat_SFlt, + RE_Attr_VAX_G_Float => System_Fat_VAX_G_Float, + RE_Fat_VAX_G => System_Fat_VAX_G_Float, RE_Attach_To_Final_List => System_Finalization_Implementation, RE_Finalize_List => System_Finalization_Implementation, @@ -2249,6 +2313,7 @@ package Rtsfind is RE_TC_Alias => System_PolyORB_Interface, RE_TC_Build => System_PolyORB_Interface, + RE_Get_TC => System_PolyORB_Interface, RE_Set_TC => System_PolyORB_Interface, RE_TC_Any => System_PolyORB_Interface, RE_TC_AD => System_PolyORB_Interface, @@ -2326,6 +2391,7 @@ package Rtsfind is RE_Integer_Address => System_Storage_Elements, RE_Storage_Offset => System_Storage_Elements, RE_Storage_Array => System_Storage_Elements, + RE_Storage_Element => System_Storage_Elements, RE_To_Address => System_Storage_Elements, RE_Root_Storage_Pool => System_Storage_Pools, @@ -2397,6 +2463,7 @@ package Rtsfind is RE_Task_Procedure_Access => System_Tasking, RO_ST_Task_Id => System_Tasking, + RO_ST_Null_Task => System_Tasking, RE_Call_Modes => System_Tasking, RE_Simple_Call => System_Tasking, @@ -2523,6 +2590,8 @@ package Rtsfind is RE_Le_G => System_Vax_Float_Operations, RE_Lt_F => System_Vax_Float_Operations, RE_Lt_G => System_Vax_Float_Operations, + RE_Ne_F => System_Vax_Float_Operations, + RE_Ne_G => System_Vax_Float_Operations, RE_Valid_D => System_Vax_Float_Operations, RE_Valid_F => System_Vax_Float_Operations, diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 190706c..c49bed3 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -28,7 +28,7 @@ with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; with Errout; use Errout; -with Exp_Ch9; +with Exp_Ch9; use Exp_Ch9; with Elists; use Elists; with Freeze; use Freeze; with Itypes; use Itypes; @@ -94,11 +94,22 @@ package body Sem_Ch9 is while Present (T_Name) loop Analyze (T_Name); - if not Is_Task_Type (Etype (T_Name)) then - Error_Msg_N ("expect task name for ABORT", T_Name); - return; - else + if Is_Task_Type (Etype (T_Name)) + or else (Ada_Version >= Ada_05 + and then Ekind (Etype (T_Name)) = E_Class_Wide_Type + and then Is_Interface (Etype (T_Name)) + and then Is_Task_Interface (Etype (T_Name))) + then Resolve (T_Name); + else + if Ada_Version >= Ada_05 then + Error_Msg_N ("expect task name or task interface class-wide " + & "object for ABORT", T_Name); + else + Error_Msg_N ("expect task name for ABORT", T_Name); + end if; + + return; end if; Next (T_Name); @@ -298,9 +309,7 @@ package body Sem_Ch9 is begin E1 := First_Entity (Current_Scope); - while Present (E1) loop - if Ekind (E1) = E_Procedure and then Chars (E1) = Chars (Entry_Nam) and then Type_Conformant (E1, Entry_Nam) @@ -368,7 +377,6 @@ package body Sem_Ch9 is begin Decl := First (Declarations (N)); - while Present (Decl) loop Analyze (Decl); @@ -390,6 +398,7 @@ package body Sem_Ch9 is -- In the case of a select alternative of a selective accept, -- the expander references the address declaration even if there -- is no statement list. + -- We also need to create the renaming declarations for the local -- variables that will replace references to the formals within -- the accept. @@ -440,14 +449,49 @@ package body Sem_Ch9 is --------------------------------- procedure Analyze_Asynchronous_Select (N : Node_Id) is + Param : Node_Id; + Trigger : Node_Id; + begin Tasking_Used := True; Check_Restriction (Max_Asynchronous_Select_Nesting, N); Check_Restriction (No_Select_Statements, N); - -- Analyze the statements. We analyze statements in the abortable part - -- first, because this is the section that is executed first, and that - -- way our remembering of saved values and checks is accurate. + if Ada_Version >= Ada_05 then + Trigger := Triggering_Statement (Triggering_Alternative (N)); + + Analyze (Trigger); + + -- The trigger is a dispatching procedure. Postpone the analysis + -- of the triggering and abortable statements until the expansion + -- of this asynchronous select in Expand_N_Asynchronous_Select. + -- This action is required since the code replication in Expand- + -- _N_Asynchronous_Select of an already analyzed statement list + -- causes Gigi aborts. + + if Expander_Active + and then Nkind (Trigger) = N_Procedure_Call_Statement + and then Present (Parameter_Associations (Trigger)) + then + Param := First (Parameter_Associations (Trigger)); + + if Is_Controlling_Actual (Param) + and then Is_Interface (Etype (Param)) + then + if Is_Limited_Record (Etype (Param)) then + return; + else + Error_Msg_N + ("dispatching operation of limited or synchronized " & + "interface required ('R'M 9.7.2(3))!", N); + end if; + end if; + end if; + end if; + + -- Analyze the statements. We analyze statements in the abortable part, + -- because this is the section that is executed first, and that way our + -- remembering of saved values and checks is accurate. Analyze_Statements (Statements (Abortable_Part (N))); Analyze (Triggering_Alternative (N)); @@ -462,6 +506,16 @@ package body Sem_Ch9 is Check_Restriction (No_Select_Statements, N); Tasking_Used := True; Analyze (Entry_Call_Alternative (N)); + + if List_Length (Else_Statements (N)) = 1 + and then Nkind (First (Else_Statements (N))) in N_Delay_Statement + then + Error_Msg_N + ("suspicious form of conditional entry call?", N); + Error_Msg_N + ("\`SELECT OR` may be intended rather than `SELECT ELSE`", N); + end if; + Analyze_Statements (Else_Statements (N)); end Analyze_Conditional_Entry_Call; @@ -491,19 +545,19 @@ package body Sem_Ch9 is if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then Pre_Analyze_And_Resolve (Expr, Standard_Duration); - else Pre_Analyze_And_Resolve (Expr); end if; - if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement and then - not Is_RTE (Base_Type (Etype (Expr)), RO_CA_Time) and then - not Is_RTE (Base_Type (Etype (Expr)), RO_RT_Time) + if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement + and then not Is_RTE (Base_Type (Etype (Expr)), RO_CA_Time) + and then not Is_RTE (Base_Type (Etype (Expr)), RO_RT_Time) then Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr); end if; Check_Restriction (No_Fixed_Point, Expr); + else Analyze (Delay_Statement (N)); end if; @@ -632,7 +686,13 @@ package body Sem_Ch9 is then Set_Etype (Def, Empty); Set_Analyzed (Def, False); - Set_Discrete_Subtype_Definition (Index_Spec, Def); + + -- Keep the original subtree to ensure tree is + -- properly formed (e.g. for ASIS use) + + Rewrite + (Discrete_Subtype_Definition (Index_Spec), Def); + Set_Analyzed (Low_Bound (Def), False); Set_Analyzed (High_Bound (Def), False); @@ -683,12 +743,16 @@ package body Sem_Ch9 is -- The entity for the protected subprogram corresponding to the entry -- has been created. We retain the name of this entity in the entry -- body, for use when the corresponding subprogram body is created. - -- Note that entry bodies have to corresponding_spec, and there is no + -- Note that entry bodies have no corresponding_spec, and there is no -- easy link back in the tree between the entry body and the entity for - -- the entry itself. + -- the entry itself, which is why we must propagate some attributes + -- explicitly from spec to body. - Set_Protected_Body_Subprogram (Id, - Protected_Body_Subprogram (Entry_Name)); + Set_Protected_Body_Subprogram + (Id, Protected_Body_Subprogram (Entry_Name)); + + Set_Entry_Parameters_Type + (Id, Entry_Parameters_Type (Entry_Name)); if Present (Decls) then Analyze_Declarations (Decls); @@ -707,6 +771,9 @@ package body Sem_Ch9 is -- At the same time, we set the flags on the spec entities to suppress -- any warnings on the spec formals, since we also scan the spec. + -- Finally, we propagate the Entry_Component attribute to the body + -- formals, for use in the renaming declarations created later for the + -- formals (see exp_ch9.Add_Formal_Renamings). declare E1 : Entity_Id; @@ -736,6 +803,7 @@ package body Sem_Ch9 is Set_Referenced (E2, Referenced (E1)); Set_Referenced (E1); + Set_Entry_Component (E2, Entry_Component (E1)); <<Continue>> Next_Entity (E1); @@ -1011,9 +1079,7 @@ package body Sem_Ch9 is end if; E := First_Entity (Current_Scope); - while Present (E) loop - if Ekind (E) = E_Function or else Ekind (E) = E_Procedure then @@ -1072,8 +1138,9 @@ package body Sem_Ch9 is -- Ada 2005 (AI-345) if Present (Interface_List (N)) then - Iface := First (Interface_List (N)); + Set_Is_Tagged_Type (T); + Iface := First (Interface_List (N)); while Present (Iface) loop Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); Iface_Def := Type_Definition (Parent (Iface_Typ)); @@ -1147,7 +1214,6 @@ package body Sem_Ch9 is -- illegal uses. Now it can be set correctly. E := First_Entity (Current_Scope); - while Present (E) loop if Ekind (E) = E_Void then Set_Ekind (E, E_Component); @@ -1254,14 +1320,13 @@ package body Sem_Ch9 is -- Overloaded case, find right interpretation if Is_Overloaded (Entry_Name) then - Get_First_Interp (Entry_Name, I, It); Entry_Id := Empty; + Get_First_Interp (Entry_Name, I, It); while Present (It.Nam) loop if No (First_Formal (It.Nam)) or else Subtype_Conformant (Enclosing, It.Nam) then - -- Ada 2005 (AI-345): Since protected and task types have -- primitive entry wrappers, we only consider source entries. @@ -1348,9 +1413,10 @@ package body Sem_Ch9 is -- Processing for parameters accessed by the requeue declare - Ent : Entity_Id := First_Formal (Enclosing); + Ent : Entity_Id; begin + Ent := First_Formal (Enclosing); while Present (Ent) loop -- For OUT or IN OUT parameter, the effect of the requeue @@ -1399,6 +1465,8 @@ package body Sem_Ch9 is Check_Restriction (No_Select_Statements, N); Tasking_Used := True; + -- Loop to analyze alternatives + Alt := First (Alts); while Present (Alt) loop Alt_Count := Alt_Count + 1; @@ -1716,7 +1784,6 @@ package body Sem_Ch9 is begin Ent := First_Entity (Spec_Id); - while Present (Ent) loop if Is_Entry (Ent) and then not Entry_Accepted (Ent) @@ -1799,6 +1866,8 @@ package body Sem_Ch9 is -- Ada 2005 (AI-345) if Present (Interface_List (N)) then + Set_Is_Tagged_Type (T); + Iface := First (Interface_List (N)); while Present (Iface) loop Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); @@ -1919,21 +1988,20 @@ package body Sem_Ch9 is end if; Analyze (Trigger); + if Comes_From_Source (Trigger) - and then Nkind (Trigger) /= N_Delay_Until_Statement - and then Nkind (Trigger) /= N_Delay_Relative_Statement + and then Nkind (Trigger) not in N_Delay_Statement and then Nkind (Trigger) /= N_Entry_Call_Statement then if Ada_Version < Ada_05 then Error_Msg_N ("triggering statement must be delay or entry call", Trigger); - -- Ada 2005 (AI-345): If a procedure_call_statement is used - -- for a procedure_or_entry_call, the procedure_name or pro- - -- cedure_prefix of the procedure_call_statement shall denote - -- an entry renamed by a procedure, or (a view of) a primitive - -- subprogram of a limited interface whose first parameter is - -- a controlling parameter. + -- Ada 2005 (AI-345): If a procedure_call_statement is used for a + -- procedure_or_entry_call, the procedure_name or pro- cedure_prefix + -- of the procedure_call_statement shall denote an entry renamed by a + -- procedure, or (a view of) a primitive subprogram of a limited + -- interface whose first parameter is a controlling parameter. elsif Nkind (Trigger) = N_Procedure_Call_Statement and then not Is_Renamed_Entry (Entity (Name (Trigger))) @@ -2089,7 +2157,6 @@ package body Sem_Ch9 is begin Ent := First (Ifaces); - while Present (Ent) loop if Etype (Ent) = Iface then return True; @@ -2119,14 +2186,13 @@ package body Sem_Ch9 is Entry_Param := First (Entry_Params); Proc_Param := Next (Proc_Param); - while Present (Entry_Param) - and then Present (Proc_Param) - loop + while Present (Entry_Param) and then Present (Proc_Param) loop + -- The two parameters must be mode conformant and have the exact -- same types. - if In_Present (Entry_Param) /= In_Present (Proc_Param) - or else Out_Present (Entry_Param) /= Out_Present (Proc_Param) + if Ekind (Defining_Identifier (Entry_Param)) /= + Ekind (Defining_Identifier (Proc_Param)) or else Etype (Parameter_Type (Entry_Param)) /= Etype (Parameter_Type (Proc_Param)) then @@ -2177,7 +2243,6 @@ package body Sem_Ch9 is Null_Present (Parent (Hom))) then Aliased_Hom := Hom; - while Present (Alias (Aliased_Hom)) loop Aliased_Hom := Alias (Aliased_Hom); end loop; @@ -2274,7 +2339,6 @@ package body Sem_Ch9 is else Decl := First (Vis_Decls); - while Present (Decl) loop if Nkind (Decl) = N_Entry_Declaration and then Must_Override (Decl) @@ -2322,7 +2386,6 @@ package body Sem_Ch9 is begin E := First_Entity (Spec); - while Present (E) loop Prev := Current_Entity (E); Set_Current_Entity (E); diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index 4993c64..c1ca4dd 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -93,6 +93,7 @@ package body Snames is "_disp_conditional_select#" & "_disp_get_prim_op_kind#" & "_disp_timed_select#" & + "_disp_get_task_id#" & "initialize#" & "adjust#" & "finalize#" & @@ -458,6 +459,7 @@ package body Snames is "machine_mantissa#" & "machine_overflows#" & "machine_radix#" & + "machine_rounding#" & "machine_rounds#" & "machine_size#" & "mantissa#" & @@ -639,6 +641,7 @@ package body Snames is "unchecked_conversion#" & "unchecked_deallocation#" & "to_pointer#" & + "free#" & "abstract#" & "aliased#" & "protected#" & @@ -674,6 +677,7 @@ package body Snames is "include_option#" & "language_processing#" & "languages#" & + "library_ali_dir#" & "library_dir#" & "library_auto_init#" & "library_gcc#" & diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index 6cdb344..caa31e3 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -67,63 +67,63 @@ package Snames is -- The lower case letter entries are used for one character identifiers -- appearing in the source, for example in pragma Interface (C). - Name_A : constant Name_Id := First_Name_Id + Character'Pos ('a'); - Name_B : constant Name_Id := First_Name_Id + Character'Pos ('b'); - Name_C : constant Name_Id := First_Name_Id + Character'Pos ('c'); - Name_D : constant Name_Id := First_Name_Id + Character'Pos ('d'); - Name_E : constant Name_Id := First_Name_Id + Character'Pos ('e'); - Name_F : constant Name_Id := First_Name_Id + Character'Pos ('f'); - Name_G : constant Name_Id := First_Name_Id + Character'Pos ('g'); - Name_H : constant Name_Id := First_Name_Id + Character'Pos ('h'); - Name_I : constant Name_Id := First_Name_Id + Character'Pos ('i'); - Name_J : constant Name_Id := First_Name_Id + Character'Pos ('j'); - Name_K : constant Name_Id := First_Name_Id + Character'Pos ('k'); - Name_L : constant Name_Id := First_Name_Id + Character'Pos ('l'); - Name_M : constant Name_Id := First_Name_Id + Character'Pos ('m'); - Name_N : constant Name_Id := First_Name_Id + Character'Pos ('n'); - Name_O : constant Name_Id := First_Name_Id + Character'Pos ('o'); - Name_P : constant Name_Id := First_Name_Id + Character'Pos ('p'); - Name_Q : constant Name_Id := First_Name_Id + Character'Pos ('q'); - Name_R : constant Name_Id := First_Name_Id + Character'Pos ('r'); - Name_S : constant Name_Id := First_Name_Id + Character'Pos ('s'); - Name_T : constant Name_Id := First_Name_Id + Character'Pos ('t'); - Name_U : constant Name_Id := First_Name_Id + Character'Pos ('u'); - Name_V : constant Name_Id := First_Name_Id + Character'Pos ('v'); - Name_W : constant Name_Id := First_Name_Id + Character'Pos ('w'); - Name_X : constant Name_Id := First_Name_Id + Character'Pos ('x'); - Name_Y : constant Name_Id := First_Name_Id + Character'Pos ('y'); - Name_Z : constant Name_Id := First_Name_Id + Character'Pos ('z'); + Name_A : constant Name_Id := First_Name_Id + Character'Pos ('a'); + Name_B : constant Name_Id := First_Name_Id + Character'Pos ('b'); + Name_C : constant Name_Id := First_Name_Id + Character'Pos ('c'); + Name_D : constant Name_Id := First_Name_Id + Character'Pos ('d'); + Name_E : constant Name_Id := First_Name_Id + Character'Pos ('e'); + Name_F : constant Name_Id := First_Name_Id + Character'Pos ('f'); + Name_G : constant Name_Id := First_Name_Id + Character'Pos ('g'); + Name_H : constant Name_Id := First_Name_Id + Character'Pos ('h'); + Name_I : constant Name_Id := First_Name_Id + Character'Pos ('i'); + Name_J : constant Name_Id := First_Name_Id + Character'Pos ('j'); + Name_K : constant Name_Id := First_Name_Id + Character'Pos ('k'); + Name_L : constant Name_Id := First_Name_Id + Character'Pos ('l'); + Name_M : constant Name_Id := First_Name_Id + Character'Pos ('m'); + Name_N : constant Name_Id := First_Name_Id + Character'Pos ('n'); + Name_O : constant Name_Id := First_Name_Id + Character'Pos ('o'); + Name_P : constant Name_Id := First_Name_Id + Character'Pos ('p'); + Name_Q : constant Name_Id := First_Name_Id + Character'Pos ('q'); + Name_R : constant Name_Id := First_Name_Id + Character'Pos ('r'); + Name_S : constant Name_Id := First_Name_Id + Character'Pos ('s'); + Name_T : constant Name_Id := First_Name_Id + Character'Pos ('t'); + Name_U : constant Name_Id := First_Name_Id + Character'Pos ('u'); + Name_V : constant Name_Id := First_Name_Id + Character'Pos ('v'); + Name_W : constant Name_Id := First_Name_Id + Character'Pos ('w'); + Name_X : constant Name_Id := First_Name_Id + Character'Pos ('x'); + Name_Y : constant Name_Id := First_Name_Id + Character'Pos ('y'); + Name_Z : constant Name_Id := First_Name_Id + Character'Pos ('z'); -- The upper case letter entries are used by expander code for local -- variables that do not require unique names (e.g. formal parameter -- names in constructed procedures) - Name_uA : constant Name_Id := First_Name_Id + Character'Pos ('A'); - Name_uB : constant Name_Id := First_Name_Id + Character'Pos ('B'); - Name_uC : constant Name_Id := First_Name_Id + Character'Pos ('C'); - Name_uD : constant Name_Id := First_Name_Id + Character'Pos ('D'); - Name_uE : constant Name_Id := First_Name_Id + Character'Pos ('E'); - Name_uF : constant Name_Id := First_Name_Id + Character'Pos ('F'); - Name_uG : constant Name_Id := First_Name_Id + Character'Pos ('G'); - Name_uH : constant Name_Id := First_Name_Id + Character'Pos ('H'); - Name_uI : constant Name_Id := First_Name_Id + Character'Pos ('I'); - Name_uJ : constant Name_Id := First_Name_Id + Character'Pos ('J'); - Name_uK : constant Name_Id := First_Name_Id + Character'Pos ('K'); - Name_uL : constant Name_Id := First_Name_Id + Character'Pos ('L'); - Name_uM : constant Name_Id := First_Name_Id + Character'Pos ('M'); - Name_uN : constant Name_Id := First_Name_Id + Character'Pos ('N'); - Name_uO : constant Name_Id := First_Name_Id + Character'Pos ('O'); - Name_uP : constant Name_Id := First_Name_Id + Character'Pos ('P'); - Name_uQ : constant Name_Id := First_Name_Id + Character'Pos ('Q'); - Name_uR : constant Name_Id := First_Name_Id + Character'Pos ('R'); - Name_uS : constant Name_Id := First_Name_Id + Character'Pos ('S'); - Name_uT : constant Name_Id := First_Name_Id + Character'Pos ('T'); - Name_uU : constant Name_Id := First_Name_Id + Character'Pos ('U'); - Name_uV : constant Name_Id := First_Name_Id + Character'Pos ('V'); - Name_uW : constant Name_Id := First_Name_Id + Character'Pos ('W'); - Name_uX : constant Name_Id := First_Name_Id + Character'Pos ('X'); - Name_uY : constant Name_Id := First_Name_Id + Character'Pos ('Y'); - Name_uZ : constant Name_Id := First_Name_Id + Character'Pos ('Z'); + Name_uA : constant Name_Id := First_Name_Id + Character'Pos ('A'); + Name_uB : constant Name_Id := First_Name_Id + Character'Pos ('B'); + Name_uC : constant Name_Id := First_Name_Id + Character'Pos ('C'); + Name_uD : constant Name_Id := First_Name_Id + Character'Pos ('D'); + Name_uE : constant Name_Id := First_Name_Id + Character'Pos ('E'); + Name_uF : constant Name_Id := First_Name_Id + Character'Pos ('F'); + Name_uG : constant Name_Id := First_Name_Id + Character'Pos ('G'); + Name_uH : constant Name_Id := First_Name_Id + Character'Pos ('H'); + Name_uI : constant Name_Id := First_Name_Id + Character'Pos ('I'); + Name_uJ : constant Name_Id := First_Name_Id + Character'Pos ('J'); + Name_uK : constant Name_Id := First_Name_Id + Character'Pos ('K'); + Name_uL : constant Name_Id := First_Name_Id + Character'Pos ('L'); + Name_uM : constant Name_Id := First_Name_Id + Character'Pos ('M'); + Name_uN : constant Name_Id := First_Name_Id + Character'Pos ('N'); + Name_uO : constant Name_Id := First_Name_Id + Character'Pos ('O'); + Name_uP : constant Name_Id := First_Name_Id + Character'Pos ('P'); + Name_uQ : constant Name_Id := First_Name_Id + Character'Pos ('Q'); + Name_uR : constant Name_Id := First_Name_Id + Character'Pos ('R'); + Name_uS : constant Name_Id := First_Name_Id + Character'Pos ('S'); + Name_uT : constant Name_Id := First_Name_Id + Character'Pos ('T'); + Name_uU : constant Name_Id := First_Name_Id + Character'Pos ('U'); + Name_uV : constant Name_Id := First_Name_Id + Character'Pos ('V'); + Name_uW : constant Name_Id := First_Name_Id + Character'Pos ('W'); + Name_uX : constant Name_Id := First_Name_Id + Character'Pos ('X'); + Name_uY : constant Name_Id := First_Name_Id + Character'Pos ('Y'); + Name_uZ : constant Name_Id := First_Name_Id + Character'Pos ('Z'); -- Note: the following table is read by the utility program XSNAMES and -- its format should not be changed without coordinating with this program. @@ -181,127 +181,132 @@ package Snames is Name_uDisp_Get_Prim_Op_Kind : constant Name_Id := N + 034; Name_uDisp_Timed_Select : constant Name_Id := N + 035; + -- Names of routines used in the expansion of Abort, attributes 'Callable + -- and 'Terminated for task interface class-wide types. + + Name_uDisp_Get_Task_Id : constant Name_Id := N + 036; + -- Names of routines in Ada.Finalization, needed by expander - Name_Initialize : constant Name_Id := N + 036; - Name_Adjust : constant Name_Id := N + 037; - Name_Finalize : constant Name_Id := N + 038; + Name_Initialize : constant Name_Id := N + 037; + Name_Adjust : constant Name_Id := N + 038; + Name_Finalize : constant Name_Id := N + 039; -- Names of fields declared in System.Finalization_Implementation, -- needed by the expander when generating code for finalization. - Name_Next : constant Name_Id := N + 039; - Name_Prev : constant Name_Id := N + 040; + Name_Next : constant Name_Id := N + 040; + Name_Prev : constant Name_Id := N + 041; -- Names of TSS routines for implementation of DSA over PolyORB - Name_uTypeCode : constant Name_Id := N + 041; - Name_uFrom_Any : constant Name_Id := N + 042; - Name_uTo_Any : constant Name_Id := N + 043; + Name_uTypeCode : constant Name_Id := N + 042; + Name_uFrom_Any : constant Name_Id := N + 043; + Name_uTo_Any : constant Name_Id := N + 044; -- Names of allocation routines, also needed by expander - Name_Allocate : constant Name_Id := N + 044; - Name_Deallocate : constant Name_Id := N + 045; - Name_Dereference : constant Name_Id := N + 046; + Name_Allocate : constant Name_Id := N + 045; + Name_Deallocate : constant Name_Id := N + 046; + Name_Dereference : constant Name_Id := N + 047; -- Names of Text_IO generic subpackages (see Rtsfind.Text_IO_Kludge) - First_Text_IO_Package : constant Name_Id := N + 047; - Name_Decimal_IO : constant Name_Id := N + 047; - Name_Enumeration_IO : constant Name_Id := N + 048; - Name_Fixed_IO : constant Name_Id := N + 049; - Name_Float_IO : constant Name_Id := N + 050; - Name_Integer_IO : constant Name_Id := N + 051; - Name_Modular_IO : constant Name_Id := N + 052; - Last_Text_IO_Package : constant Name_Id := N + 052; + First_Text_IO_Package : constant Name_Id := N + 048; + Name_Decimal_IO : constant Name_Id := N + 048; + Name_Enumeration_IO : constant Name_Id := N + 049; + Name_Fixed_IO : constant Name_Id := N + 050; + Name_Float_IO : constant Name_Id := N + 051; + Name_Integer_IO : constant Name_Id := N + 052; + Name_Modular_IO : constant Name_Id := N + 053; + Last_Text_IO_Package : constant Name_Id := N + 053; subtype Text_IO_Package_Name is Name_Id range First_Text_IO_Package .. Last_Text_IO_Package; -- Some miscellaneous names used for error detection/recovery - Name_Const : constant Name_Id := N + 053; - Name_Error : constant Name_Id := N + 054; - Name_Go : constant Name_Id := N + 055; - Name_Put : constant Name_Id := N + 056; - Name_Put_Line : constant Name_Id := N + 057; - Name_To : constant Name_Id := N + 058; + Name_Const : constant Name_Id := N + 054; + Name_Error : constant Name_Id := N + 055; + Name_Go : constant Name_Id := N + 056; + Name_Put : constant Name_Id := N + 057; + Name_Put_Line : constant Name_Id := N + 058; + Name_To : constant Name_Id := N + 059; -- Names for packages that are treated specially by the compiler - Name_Finalization : constant Name_Id := N + 059; - Name_Finalization_Root : constant Name_Id := N + 060; - Name_Interfaces : constant Name_Id := N + 061; - Name_Standard : constant Name_Id := N + 062; - Name_System : constant Name_Id := N + 063; - Name_Text_IO : constant Name_Id := N + 064; - Name_Wide_Text_IO : constant Name_Id := N + 065; - Name_Wide_Wide_Text_IO : constant Name_Id := N + 066; + Name_Finalization : constant Name_Id := N + 060; + Name_Finalization_Root : constant Name_Id := N + 061; + Name_Interfaces : constant Name_Id := N + 062; + Name_Standard : constant Name_Id := N + 063; + Name_System : constant Name_Id := N + 064; + Name_Text_IO : constant Name_Id := N + 065; + Name_Wide_Text_IO : constant Name_Id := N + 066; + Name_Wide_Wide_Text_IO : constant Name_Id := N + 067; -- Names of implementations of the distributed systems annex - First_PCS_Name : constant Name_Id := N + 067; - Name_No_DSA : constant Name_Id := N + 067; - Name_GARLIC_DSA : constant Name_Id := N + 068; - Name_PolyORB_DSA : constant Name_Id := N + 069; - Last_PCS_Name : constant Name_Id := N + 069; + First_PCS_Name : constant Name_Id := N + 068; + Name_No_DSA : constant Name_Id := N + 068; + Name_GARLIC_DSA : constant Name_Id := N + 069; + Name_PolyORB_DSA : constant Name_Id := N + 070; + Last_PCS_Name : constant Name_Id := N + 070; subtype PCS_Names is Name_Id range First_PCS_Name .. Last_PCS_Name; -- Names of identifiers used in expanding distribution stubs - Name_Addr : constant Name_Id := N + 070; - Name_Async : constant Name_Id := N + 071; - Name_Get_Active_Partition_ID : constant Name_Id := N + 072; - Name_Get_RCI_Package_Receiver : constant Name_Id := N + 073; - Name_Get_RCI_Package_Ref : constant Name_Id := N + 074; - Name_Origin : constant Name_Id := N + 075; - Name_Params : constant Name_Id := N + 076; - Name_Partition : constant Name_Id := N + 077; - Name_Partition_Interface : constant Name_Id := N + 078; - Name_Ras : constant Name_Id := N + 079; - Name_Call : constant Name_Id := N + 080; - Name_RCI_Name : constant Name_Id := N + 081; - Name_Receiver : constant Name_Id := N + 082; - Name_Result : constant Name_Id := N + 083; - Name_Rpc : constant Name_Id := N + 084; - Name_Subp_Id : constant Name_Id := N + 085; - Name_Operation : constant Name_Id := N + 086; - Name_Argument : constant Name_Id := N + 087; - Name_Arg_Modes : constant Name_Id := N + 088; - Name_Handler : constant Name_Id := N + 089; - Name_Target : constant Name_Id := N + 090; - Name_Req : constant Name_Id := N + 091; - Name_Obj_TypeCode : constant Name_Id := N + 092; - Name_Stub : constant Name_Id := N + 093; + Name_Addr : constant Name_Id := N + 071; + Name_Async : constant Name_Id := N + 072; + Name_Get_Active_Partition_ID : constant Name_Id := N + 073; + Name_Get_RCI_Package_Receiver : constant Name_Id := N + 074; + Name_Get_RCI_Package_Ref : constant Name_Id := N + 075; + Name_Origin : constant Name_Id := N + 076; + Name_Params : constant Name_Id := N + 077; + Name_Partition : constant Name_Id := N + 078; + Name_Partition_Interface : constant Name_Id := N + 079; + Name_Ras : constant Name_Id := N + 080; + Name_Call : constant Name_Id := N + 081; + Name_RCI_Name : constant Name_Id := N + 082; + Name_Receiver : constant Name_Id := N + 083; + Name_Result : constant Name_Id := N + 084; + Name_Rpc : constant Name_Id := N + 085; + Name_Subp_Id : constant Name_Id := N + 086; + Name_Operation : constant Name_Id := N + 087; + Name_Argument : constant Name_Id := N + 088; + Name_Arg_Modes : constant Name_Id := N + 089; + Name_Handler : constant Name_Id := N + 090; + Name_Target : constant Name_Id := N + 091; + Name_Req : constant Name_Id := N + 092; + Name_Obj_TypeCode : constant Name_Id := N + 093; + Name_Stub : constant Name_Id := N + 094; -- Operator Symbol entries. The actual names have an upper case O at -- the start in place of the Op_ prefix (e.g. the actual name that -- corresponds to Name_Op_Abs is "Oabs". - First_Operator_Name : constant Name_Id := N + 094; - Name_Op_Abs : constant Name_Id := N + 094; -- "abs" - Name_Op_And : constant Name_Id := N + 095; -- "and" - Name_Op_Mod : constant Name_Id := N + 096; -- "mod" - Name_Op_Not : constant Name_Id := N + 097; -- "not" - Name_Op_Or : constant Name_Id := N + 098; -- "or" - Name_Op_Rem : constant Name_Id := N + 099; -- "rem" - Name_Op_Xor : constant Name_Id := N + 100; -- "xor" - Name_Op_Eq : constant Name_Id := N + 101; -- "=" - Name_Op_Ne : constant Name_Id := N + 102; -- "/=" - Name_Op_Lt : constant Name_Id := N + 103; -- "<" - Name_Op_Le : constant Name_Id := N + 104; -- "<=" - Name_Op_Gt : constant Name_Id := N + 105; -- ">" - Name_Op_Ge : constant Name_Id := N + 106; -- ">=" - Name_Op_Add : constant Name_Id := N + 107; -- "+" - Name_Op_Subtract : constant Name_Id := N + 108; -- "-" - Name_Op_Concat : constant Name_Id := N + 109; -- "&" - Name_Op_Multiply : constant Name_Id := N + 110; -- "*" - Name_Op_Divide : constant Name_Id := N + 111; -- "/" - Name_Op_Expon : constant Name_Id := N + 112; -- "**" - Last_Operator_Name : constant Name_Id := N + 112; + First_Operator_Name : constant Name_Id := N + 095; + Name_Op_Abs : constant Name_Id := N + 095; -- "abs" + Name_Op_And : constant Name_Id := N + 096; -- "and" + Name_Op_Mod : constant Name_Id := N + 097; -- "mod" + Name_Op_Not : constant Name_Id := N + 098; -- "not" + Name_Op_Or : constant Name_Id := N + 099; -- "or" + Name_Op_Rem : constant Name_Id := N + 100; -- "rem" + Name_Op_Xor : constant Name_Id := N + 101; -- "xor" + Name_Op_Eq : constant Name_Id := N + 102; -- "=" + Name_Op_Ne : constant Name_Id := N + 103; -- "/=" + Name_Op_Lt : constant Name_Id := N + 104; -- "<" + Name_Op_Le : constant Name_Id := N + 105; -- "<=" + Name_Op_Gt : constant Name_Id := N + 106; -- ">" + Name_Op_Ge : constant Name_Id := N + 107; -- ">=" + Name_Op_Add : constant Name_Id := N + 108; -- "+" + Name_Op_Subtract : constant Name_Id := N + 109; -- "-" + Name_Op_Concat : constant Name_Id := N + 110; -- "&" + Name_Op_Multiply : constant Name_Id := N + 111; -- "*" + Name_Op_Divide : constant Name_Id := N + 112; -- "/" + Name_Op_Expon : constant Name_Id := N + 113; -- "**" + Last_Operator_Name : constant Name_Id := N + 113; -- Names for all pragmas recognized by GNAT. The entries with the comment -- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95. @@ -324,65 +329,65 @@ package Snames is -- only in GNAT for the AAMP. They are ignored in other versions with -- appropriate warnings. - First_Pragma_Name : constant Name_Id := N + 113; + First_Pragma_Name : constant Name_Id := N + 114; -- Configuration pragmas are grouped at start - Name_Ada_83 : constant Name_Id := N + 113; -- GNAT - Name_Ada_95 : constant Name_Id := N + 114; -- GNAT - Name_Ada_05 : constant Name_Id := N + 115; -- GNAT - Name_Assertion_Policy : constant Name_Id := N + 116; -- Ada 05 - Name_C_Pass_By_Copy : constant Name_Id := N + 117; -- GNAT - Name_Compile_Time_Warning : constant Name_Id := N + 118; -- GNAT - Name_Component_Alignment : constant Name_Id := N + 119; -- GNAT - Name_Convention_Identifier : constant Name_Id := N + 120; -- GNAT - Name_Debug_Policy : constant Name_Id := N + 121; -- GNAT - Name_Detect_Blocking : constant Name_Id := N + 122; -- Ada 05 - Name_Discard_Names : constant Name_Id := N + 123; - Name_Elaboration_Checks : constant Name_Id := N + 124; -- GNAT - Name_Eliminate : constant Name_Id := N + 125; -- GNAT - Name_Explicit_Overriding : constant Name_Id := N + 126; -- Ada 05 - Name_Extend_System : constant Name_Id := N + 127; -- GNAT - Name_Extensions_Allowed : constant Name_Id := N + 128; -- GNAT - Name_External_Name_Casing : constant Name_Id := N + 129; -- GNAT - Name_Float_Representation : constant Name_Id := N + 130; -- GNAT - Name_Initialize_Scalars : constant Name_Id := N + 131; -- GNAT - Name_Interrupt_State : constant Name_Id := N + 132; -- GNAT - Name_License : constant Name_Id := N + 133; -- GNAT - Name_Locking_Policy : constant Name_Id := N + 134; - Name_Long_Float : constant Name_Id := N + 135; -- VMS - Name_No_Run_Time : constant Name_Id := N + 136; -- GNAT - Name_No_Strict_Aliasing : constant Name_Id := N + 137; -- GNAT - Name_Normalize_Scalars : constant Name_Id := N + 138; - Name_Polling : constant Name_Id := N + 139; -- GNAT - Name_Persistent_BSS : constant Name_Id := N + 140; -- GNAT - Name_Profile : constant Name_Id := N + 141; -- Ada 05 - Name_Profile_Warnings : constant Name_Id := N + 142; -- GNAT - Name_Propagate_Exceptions : constant Name_Id := N + 143; -- GNAT - Name_Queuing_Policy : constant Name_Id := N + 144; - Name_Ravenscar : constant Name_Id := N + 145; -- Ada 05 - Name_Restricted_Run_Time : constant Name_Id := N + 146; -- GNAT - Name_Restrictions : constant Name_Id := N + 147; - Name_Restriction_Warnings : constant Name_Id := N + 148; -- GNAT - Name_Reviewable : constant Name_Id := N + 149; - Name_Source_File_Name : constant Name_Id := N + 150; -- GNAT - Name_Source_File_Name_Project : constant Name_Id := N + 151; -- GNAT - Name_Style_Checks : constant Name_Id := N + 152; -- GNAT - Name_Suppress : constant Name_Id := N + 153; - Name_Suppress_Exception_Locations : constant Name_Id := N + 154; -- GNAT - Name_Task_Dispatching_Policy : constant Name_Id := N + 155; - Name_Universal_Data : constant Name_Id := N + 156; -- AAMP - Name_Unsuppress : constant Name_Id := N + 157; -- GNAT - Name_Use_VADS_Size : constant Name_Id := N + 158; -- GNAT - Name_Validity_Checks : constant Name_Id := N + 159; -- GNAT - Name_Warnings : constant Name_Id := N + 160; -- GNAT - Last_Configuration_Pragma_Name : constant Name_Id := N + 160; + Name_Ada_83 : constant Name_Id := N + 114; -- GNAT + Name_Ada_95 : constant Name_Id := N + 115; -- GNAT + Name_Ada_05 : constant Name_Id := N + 116; -- GNAT + Name_Assertion_Policy : constant Name_Id := N + 117; -- Ada 05 + Name_C_Pass_By_Copy : constant Name_Id := N + 118; -- GNAT + Name_Compile_Time_Warning : constant Name_Id := N + 119; -- GNAT + Name_Component_Alignment : constant Name_Id := N + 120; -- GNAT + Name_Convention_Identifier : constant Name_Id := N + 121; -- GNAT + Name_Debug_Policy : constant Name_Id := N + 122; -- GNAT + Name_Detect_Blocking : constant Name_Id := N + 123; -- Ada 05 + Name_Discard_Names : constant Name_Id := N + 124; + Name_Elaboration_Checks : constant Name_Id := N + 125; -- GNAT + Name_Eliminate : constant Name_Id := N + 126; -- GNAT + Name_Explicit_Overriding : constant Name_Id := N + 127; -- Ada 05 + Name_Extend_System : constant Name_Id := N + 128; -- GNAT + Name_Extensions_Allowed : constant Name_Id := N + 129; -- GNAT + Name_External_Name_Casing : constant Name_Id := N + 130; -- GNAT + Name_Float_Representation : constant Name_Id := N + 131; -- GNAT + Name_Initialize_Scalars : constant Name_Id := N + 132; -- GNAT + Name_Interrupt_State : constant Name_Id := N + 133; -- GNAT + Name_License : constant Name_Id := N + 134; -- GNAT + Name_Locking_Policy : constant Name_Id := N + 135; + Name_Long_Float : constant Name_Id := N + 136; -- VMS + Name_No_Run_Time : constant Name_Id := N + 137; -- GNAT + Name_No_Strict_Aliasing : constant Name_Id := N + 138; -- GNAT + Name_Normalize_Scalars : constant Name_Id := N + 139; + Name_Polling : constant Name_Id := N + 140; -- GNAT + Name_Persistent_BSS : constant Name_Id := N + 141; -- GNAT + Name_Profile : constant Name_Id := N + 142; -- Ada 05 + Name_Profile_Warnings : constant Name_Id := N + 143; -- GNAT + Name_Propagate_Exceptions : constant Name_Id := N + 144; -- GNAT + Name_Queuing_Policy : constant Name_Id := N + 145; + Name_Ravenscar : constant Name_Id := N + 146; -- Ada 05 + Name_Restricted_Run_Time : constant Name_Id := N + 147; -- GNAT + Name_Restrictions : constant Name_Id := N + 148; + Name_Restriction_Warnings : constant Name_Id := N + 149; -- GNAT + Name_Reviewable : constant Name_Id := N + 150; + Name_Source_File_Name : constant Name_Id := N + 151; -- GNAT + Name_Source_File_Name_Project : constant Name_Id := N + 152; -- GNAT + Name_Style_Checks : constant Name_Id := N + 153; -- GNAT + Name_Suppress : constant Name_Id := N + 154; + Name_Suppress_Exception_Locations : constant Name_Id := N + 155; -- GNAT + Name_Task_Dispatching_Policy : constant Name_Id := N + 156; + Name_Universal_Data : constant Name_Id := N + 157; -- AAMP + Name_Unsuppress : constant Name_Id := N + 158; -- GNAT + Name_Use_VADS_Size : constant Name_Id := N + 159; -- GNAT + Name_Validity_Checks : constant Name_Id := N + 160; -- GNAT + Name_Warnings : constant Name_Id := N + 161; -- GNAT + Last_Configuration_Pragma_Name : constant Name_Id := N + 161; -- Remaining pragma names - Name_Abort_Defer : constant Name_Id := N + 161; -- GNAT - Name_All_Calls_Remote : constant Name_Id := N + 162; - Name_Annotate : constant Name_Id := N + 163; -- GNAT + Name_Abort_Defer : constant Name_Id := N + 162; -- GNAT + Name_All_Calls_Remote : constant Name_Id := N + 163; + Name_Annotate : constant Name_Id := N + 164; -- GNAT -- Note: AST_Entry is not in this list because its name matches the -- name of the corresponding attribute. However, it is included in the @@ -390,80 +395,80 @@ package Snames is -- and Check_Pragma_Id correctly recognize and process Name_AST_Entry. -- AST_Entry is a VMS specific pragma. - Name_Assert : constant Name_Id := N + 164; -- Ada 05 - Name_Asynchronous : constant Name_Id := N + 165; - Name_Atomic : constant Name_Id := N + 166; - Name_Atomic_Components : constant Name_Id := N + 167; - Name_Attach_Handler : constant Name_Id := N + 168; - Name_Comment : constant Name_Id := N + 169; -- GNAT - Name_Common_Object : constant Name_Id := N + 170; -- GNAT - Name_Complex_Representation : constant Name_Id := N + 171; -- GNAT - Name_Controlled : constant Name_Id := N + 172; - Name_Convention : constant Name_Id := N + 173; - Name_CPP_Class : constant Name_Id := N + 174; -- GNAT - Name_CPP_Constructor : constant Name_Id := N + 175; -- GNAT - Name_CPP_Virtual : constant Name_Id := N + 176; -- GNAT - Name_CPP_Vtable : constant Name_Id := N + 177; -- GNAT - Name_Debug : constant Name_Id := N + 178; -- GNAT - Name_Elaborate : constant Name_Id := N + 179; -- Ada 83 - Name_Elaborate_All : constant Name_Id := N + 180; - Name_Elaborate_Body : constant Name_Id := N + 181; - Name_Export : constant Name_Id := N + 182; - Name_Export_Exception : constant Name_Id := N + 183; -- VMS - Name_Export_Function : constant Name_Id := N + 184; -- GNAT - Name_Export_Object : constant Name_Id := N + 185; -- GNAT - Name_Export_Procedure : constant Name_Id := N + 186; -- GNAT - Name_Export_Value : constant Name_Id := N + 187; -- GNAT - Name_Export_Valued_Procedure : constant Name_Id := N + 188; -- GNAT - Name_External : constant Name_Id := N + 189; -- GNAT - Name_Finalize_Storage_Only : constant Name_Id := N + 190; -- GNAT - Name_Ident : constant Name_Id := N + 191; -- VMS - Name_Import : constant Name_Id := N + 192; - Name_Import_Exception : constant Name_Id := N + 193; -- VMS - Name_Import_Function : constant Name_Id := N + 194; -- GNAT - Name_Import_Object : constant Name_Id := N + 195; -- GNAT - Name_Import_Procedure : constant Name_Id := N + 196; -- GNAT - Name_Import_Valued_Procedure : constant Name_Id := N + 197; -- GNAT - Name_Inline : constant Name_Id := N + 198; - Name_Inline_Always : constant Name_Id := N + 199; -- GNAT - Name_Inline_Generic : constant Name_Id := N + 200; -- GNAT - Name_Inspection_Point : constant Name_Id := N + 201; - Name_Interface_Name : constant Name_Id := N + 202; -- GNAT - Name_Interrupt_Handler : constant Name_Id := N + 203; - Name_Interrupt_Priority : constant Name_Id := N + 204; - Name_Java_Constructor : constant Name_Id := N + 205; -- GNAT - Name_Java_Interface : constant Name_Id := N + 206; -- GNAT - Name_Keep_Names : constant Name_Id := N + 207; -- GNAT - Name_Link_With : constant Name_Id := N + 208; -- GNAT - Name_Linker_Alias : constant Name_Id := N + 209; -- GNAT - Name_Linker_Constructor : constant Name_Id := N + 210; -- GNAT - Name_Linker_Destructor : constant Name_Id := N + 211; -- GNAT - Name_Linker_Options : constant Name_Id := N + 212; - Name_Linker_Section : constant Name_Id := N + 213; -- GNAT - Name_List : constant Name_Id := N + 214; - Name_Machine_Attribute : constant Name_Id := N + 215; -- GNAT - Name_Main : constant Name_Id := N + 216; -- GNAT - Name_Main_Storage : constant Name_Id := N + 217; -- GNAT - Name_Memory_Size : constant Name_Id := N + 218; -- Ada 83 - Name_No_Return : constant Name_Id := N + 219; -- GNAT - Name_Obsolescent : constant Name_Id := N + 220; -- GNAT - Name_Optimize : constant Name_Id := N + 221; - Name_Optional_Overriding : constant Name_Id := N + 222; -- Ada 05 - Name_Pack : constant Name_Id := N + 223; - Name_Page : constant Name_Id := N + 224; - Name_Passive : constant Name_Id := N + 225; -- GNAT - Name_Preelaborate : constant Name_Id := N + 226; - Name_Preelaborate_05 : constant Name_Id := N + 227; -- GNAT - Name_Priority : constant Name_Id := N + 228; - Name_Psect_Object : constant Name_Id := N + 229; -- VMS - Name_Pure : constant Name_Id := N + 230; - Name_Pure_05 : constant Name_Id := N + 231; -- GNAT - Name_Pure_Function : constant Name_Id := N + 232; -- GNAT - Name_Remote_Call_Interface : constant Name_Id := N + 233; - Name_Remote_Types : constant Name_Id := N + 234; - Name_Share_Generic : constant Name_Id := N + 235; -- GNAT - Name_Shared : constant Name_Id := N + 236; -- Ada 83 - Name_Shared_Passive : constant Name_Id := N + 237; + Name_Assert : constant Name_Id := N + 165; -- Ada 05 + Name_Asynchronous : constant Name_Id := N + 166; + Name_Atomic : constant Name_Id := N + 167; + Name_Atomic_Components : constant Name_Id := N + 168; + Name_Attach_Handler : constant Name_Id := N + 169; + Name_Comment : constant Name_Id := N + 170; -- GNAT + Name_Common_Object : constant Name_Id := N + 171; -- GNAT + Name_Complex_Representation : constant Name_Id := N + 172; -- GNAT + Name_Controlled : constant Name_Id := N + 173; + Name_Convention : constant Name_Id := N + 174; + Name_CPP_Class : constant Name_Id := N + 175; -- GNAT + Name_CPP_Constructor : constant Name_Id := N + 176; -- GNAT + Name_CPP_Virtual : constant Name_Id := N + 177; -- GNAT + Name_CPP_Vtable : constant Name_Id := N + 178; -- GNAT + Name_Debug : constant Name_Id := N + 179; -- GNAT + Name_Elaborate : constant Name_Id := N + 180; -- Ada 83 + Name_Elaborate_All : constant Name_Id := N + 181; + Name_Elaborate_Body : constant Name_Id := N + 182; + Name_Export : constant Name_Id := N + 183; + Name_Export_Exception : constant Name_Id := N + 184; -- VMS + Name_Export_Function : constant Name_Id := N + 185; -- GNAT + Name_Export_Object : constant Name_Id := N + 186; -- GNAT + Name_Export_Procedure : constant Name_Id := N + 187; -- GNAT + Name_Export_Value : constant Name_Id := N + 188; -- GNAT + Name_Export_Valued_Procedure : constant Name_Id := N + 189; -- GNAT + Name_External : constant Name_Id := N + 190; -- GNAT + Name_Finalize_Storage_Only : constant Name_Id := N + 191; -- GNAT + Name_Ident : constant Name_Id := N + 192; -- VMS + Name_Import : constant Name_Id := N + 193; + Name_Import_Exception : constant Name_Id := N + 194; -- VMS + Name_Import_Function : constant Name_Id := N + 195; -- GNAT + Name_Import_Object : constant Name_Id := N + 196; -- GNAT + Name_Import_Procedure : constant Name_Id := N + 197; -- GNAT + Name_Import_Valued_Procedure : constant Name_Id := N + 198; -- GNAT + Name_Inline : constant Name_Id := N + 199; + Name_Inline_Always : constant Name_Id := N + 200; -- GNAT + Name_Inline_Generic : constant Name_Id := N + 201; -- GNAT + Name_Inspection_Point : constant Name_Id := N + 202; + Name_Interface_Name : constant Name_Id := N + 203; -- GNAT + Name_Interrupt_Handler : constant Name_Id := N + 204; + Name_Interrupt_Priority : constant Name_Id := N + 205; + Name_Java_Constructor : constant Name_Id := N + 206; -- GNAT + Name_Java_Interface : constant Name_Id := N + 207; -- GNAT + Name_Keep_Names : constant Name_Id := N + 208; -- GNAT + Name_Link_With : constant Name_Id := N + 209; -- GNAT + Name_Linker_Alias : constant Name_Id := N + 210; -- GNAT + Name_Linker_Constructor : constant Name_Id := N + 211; -- GNAT + Name_Linker_Destructor : constant Name_Id := N + 212; -- GNAT + Name_Linker_Options : constant Name_Id := N + 213; + Name_Linker_Section : constant Name_Id := N + 214; -- GNAT + Name_List : constant Name_Id := N + 215; + Name_Machine_Attribute : constant Name_Id := N + 216; -- GNAT + Name_Main : constant Name_Id := N + 217; -- GNAT + Name_Main_Storage : constant Name_Id := N + 218; -- GNAT + Name_Memory_Size : constant Name_Id := N + 219; -- Ada 83 + Name_No_Return : constant Name_Id := N + 220; -- GNAT + Name_Obsolescent : constant Name_Id := N + 221; -- GNAT + Name_Optimize : constant Name_Id := N + 222; + Name_Optional_Overriding : constant Name_Id := N + 223; -- Ada 05 + Name_Pack : constant Name_Id := N + 224; + Name_Page : constant Name_Id := N + 225; + Name_Passive : constant Name_Id := N + 226; -- GNAT + Name_Preelaborate : constant Name_Id := N + 227; + Name_Preelaborate_05 : constant Name_Id := N + 228; -- GNAT + Name_Priority : constant Name_Id := N + 229; + Name_Psect_Object : constant Name_Id := N + 230; -- VMS + Name_Pure : constant Name_Id := N + 231; + Name_Pure_05 : constant Name_Id := N + 232; -- GNAT + Name_Pure_Function : constant Name_Id := N + 233; -- GNAT + Name_Remote_Call_Interface : constant Name_Id := N + 234; + Name_Remote_Types : constant Name_Id := N + 235; + Name_Share_Generic : constant Name_Id := N + 236; -- GNAT + Name_Shared : constant Name_Id := N + 237; -- Ada 83 + Name_Shared_Passive : constant Name_Id := N + 238; -- Note: Storage_Size is not in this list because its name matches the -- name of the corresponding attribute. However, it is included in the @@ -473,27 +478,27 @@ package Snames is -- Note: Storage_Unit is also omitted from the list because of a clash -- with an attribute name, and is treated similarly. - Name_Source_Reference : constant Name_Id := N + 238; -- GNAT - Name_Stream_Convert : constant Name_Id := N + 239; -- GNAT - Name_Subtitle : constant Name_Id := N + 240; -- GNAT - Name_Suppress_All : constant Name_Id := N + 241; -- GNAT - Name_Suppress_Debug_Info : constant Name_Id := N + 242; -- GNAT - Name_Suppress_Initialization : constant Name_Id := N + 243; -- GNAT - Name_System_Name : constant Name_Id := N + 244; -- Ada 83 - Name_Task_Info : constant Name_Id := N + 245; -- GNAT - Name_Task_Name : constant Name_Id := N + 246; -- GNAT - Name_Task_Storage : constant Name_Id := N + 247; -- VMS - Name_Thread_Body : constant Name_Id := N + 248; -- GNAT - Name_Time_Slice : constant Name_Id := N + 249; -- GNAT - Name_Title : constant Name_Id := N + 250; -- GNAT - Name_Unchecked_Union : constant Name_Id := N + 251; -- GNAT - Name_Unimplemented_Unit : constant Name_Id := N + 252; -- GNAT - Name_Unreferenced : constant Name_Id := N + 253; -- GNAT - Name_Unreserve_All_Interrupts : constant Name_Id := N + 254; -- GNAT - Name_Volatile : constant Name_Id := N + 255; - Name_Volatile_Components : constant Name_Id := N + 256; - Name_Weak_External : constant Name_Id := N + 257; -- GNAT - Last_Pragma_Name : constant Name_Id := N + 257; + Name_Source_Reference : constant Name_Id := N + 239; -- GNAT + Name_Stream_Convert : constant Name_Id := N + 240; -- GNAT + Name_Subtitle : constant Name_Id := N + 241; -- GNAT + Name_Suppress_All : constant Name_Id := N + 242; -- GNAT + Name_Suppress_Debug_Info : constant Name_Id := N + 243; -- GNAT + Name_Suppress_Initialization : constant Name_Id := N + 244; -- GNAT + Name_System_Name : constant Name_Id := N + 245; -- Ada 83 + Name_Task_Info : constant Name_Id := N + 246; -- GNAT + Name_Task_Name : constant Name_Id := N + 247; -- GNAT + Name_Task_Storage : constant Name_Id := N + 248; -- VMS + Name_Thread_Body : constant Name_Id := N + 249; -- GNAT + Name_Time_Slice : constant Name_Id := N + 250; -- GNAT + Name_Title : constant Name_Id := N + 251; -- GNAT + Name_Unchecked_Union : constant Name_Id := N + 252; -- GNAT + Name_Unimplemented_Unit : constant Name_Id := N + 253; -- GNAT + Name_Unreferenced : constant Name_Id := N + 254; -- GNAT + Name_Unreserve_All_Interrupts : constant Name_Id := N + 255; -- GNAT + Name_Volatile : constant Name_Id := N + 256; + Name_Volatile_Components : constant Name_Id := N + 257; + Name_Weak_External : constant Name_Id := N + 258; -- GNAT + Last_Pragma_Name : constant Name_Id := N + 258; -- Language convention names for pragma Convention/Export/Import/Interface -- Note that Name_C is not included in this list, since it was already @@ -504,114 +509,114 @@ package Snames is -- Entry and Protected, this is because these conventions cannot be -- specified by a pragma. - First_Convention_Name : constant Name_Id := N + 258; - Name_Ada : constant Name_Id := N + 258; - Name_Assembler : constant Name_Id := N + 259; - Name_COBOL : constant Name_Id := N + 260; - Name_CPP : constant Name_Id := N + 261; - Name_Fortran : constant Name_Id := N + 262; - Name_Intrinsic : constant Name_Id := N + 263; - Name_Java : constant Name_Id := N + 264; - Name_Stdcall : constant Name_Id := N + 265; - Name_Stubbed : constant Name_Id := N + 266; - Last_Convention_Name : constant Name_Id := N + 266; + First_Convention_Name : constant Name_Id := N + 259; + Name_Ada : constant Name_Id := N + 259; + Name_Assembler : constant Name_Id := N + 260; + Name_COBOL : constant Name_Id := N + 261; + Name_CPP : constant Name_Id := N + 262; + Name_Fortran : constant Name_Id := N + 263; + Name_Intrinsic : constant Name_Id := N + 264; + Name_Java : constant Name_Id := N + 265; + Name_Stdcall : constant Name_Id := N + 266; + Name_Stubbed : constant Name_Id := N + 267; + Last_Convention_Name : constant Name_Id := N + 267; -- The following names are preset as synonyms for Assembler - Name_Asm : constant Name_Id := N + 267; - Name_Assembly : constant Name_Id := N + 268; + Name_Asm : constant Name_Id := N + 268; + Name_Assembly : constant Name_Id := N + 269; -- The following names are preset as synonyms for C - Name_Default : constant Name_Id := N + 269; + Name_Default : constant Name_Id := N + 270; -- Name_Exernal (previously defined as pragma) -- The following names are present as synonyms for Stdcall - Name_DLL : constant Name_Id := N + 270; - Name_Win32 : constant Name_Id := N + 271; + Name_DLL : constant Name_Id := N + 271; + Name_Win32 : constant Name_Id := N + 272; -- Other special names used in processing pragmas - Name_As_Is : constant Name_Id := N + 272; - Name_Attribute_Name : constant Name_Id := N + 273; - Name_Body_File_Name : constant Name_Id := N + 274; - Name_Boolean_Entry_Barriers : constant Name_Id := N + 275; - Name_Check : constant Name_Id := N + 276; - Name_Casing : constant Name_Id := N + 277; - Name_Code : constant Name_Id := N + 278; - Name_Component : constant Name_Id := N + 279; - Name_Component_Size_4 : constant Name_Id := N + 280; - Name_Copy : constant Name_Id := N + 281; - Name_D_Float : constant Name_Id := N + 282; - Name_Descriptor : constant Name_Id := N + 283; - Name_Dot_Replacement : constant Name_Id := N + 284; - Name_Dynamic : constant Name_Id := N + 285; - Name_Entity : constant Name_Id := N + 286; - Name_Entry_Count : constant Name_Id := N + 287; - Name_External_Name : constant Name_Id := N + 288; - Name_First_Optional_Parameter : constant Name_Id := N + 289; - Name_Form : constant Name_Id := N + 290; - Name_G_Float : constant Name_Id := N + 291; - Name_Gcc : constant Name_Id := N + 292; - Name_Gnat : constant Name_Id := N + 293; - Name_GPL : constant Name_Id := N + 294; - Name_IEEE_Float : constant Name_Id := N + 295; - Name_Ignore : constant Name_Id := N + 296; - Name_Info : constant Name_Id := N + 297; - Name_Internal : constant Name_Id := N + 298; - Name_Link_Name : constant Name_Id := N + 299; - Name_Lowercase : constant Name_Id := N + 300; - Name_Max_Entry_Queue_Depth : constant Name_Id := N + 301; - Name_Max_Entry_Queue_Length : constant Name_Id := N + 302; - Name_Max_Size : constant Name_Id := N + 303; - Name_Mechanism : constant Name_Id := N + 304; - Name_Message : constant Name_Id := N + 305; - Name_Mixedcase : constant Name_Id := N + 306; - Name_Modified_GPL : constant Name_Id := N + 307; - Name_Name : constant Name_Id := N + 308; - Name_NCA : constant Name_Id := N + 309; - Name_No : constant Name_Id := N + 310; - Name_No_Dependence : constant Name_Id := N + 311; - Name_No_Dynamic_Attachment : constant Name_Id := N + 312; - Name_No_Dynamic_Interrupts : constant Name_Id := N + 313; - Name_No_Requeue : constant Name_Id := N + 314; - Name_No_Requeue_Statements : constant Name_Id := N + 315; - Name_No_Task_Attributes : constant Name_Id := N + 316; - Name_No_Task_Attributes_Package : constant Name_Id := N + 317; - Name_On : constant Name_Id := N + 318; - Name_Parameter_Types : constant Name_Id := N + 319; - Name_Reference : constant Name_Id := N + 320; - Name_Restricted : constant Name_Id := N + 321; - Name_Result_Mechanism : constant Name_Id := N + 322; - Name_Result_Type : constant Name_Id := N + 323; - Name_Runtime : constant Name_Id := N + 324; - Name_SB : constant Name_Id := N + 325; - Name_Secondary_Stack_Size : constant Name_Id := N + 326; - Name_Section : constant Name_Id := N + 327; - Name_Semaphore : constant Name_Id := N + 328; - Name_Simple_Barriers : constant Name_Id := N + 329; - Name_Spec_File_Name : constant Name_Id := N + 330; - Name_State : constant Name_Id := N + 331; - Name_Static : constant Name_Id := N + 332; - Name_Stack_Size : constant Name_Id := N + 333; - Name_Subunit_File_Name : constant Name_Id := N + 334; - Name_Task_Stack_Size_Default : constant Name_Id := N + 335; - Name_Task_Type : constant Name_Id := N + 336; - Name_Time_Slicing_Enabled : constant Name_Id := N + 337; - Name_Top_Guard : constant Name_Id := N + 338; - Name_UBA : constant Name_Id := N + 339; - Name_UBS : constant Name_Id := N + 340; - Name_UBSB : constant Name_Id := N + 341; - Name_Unit_Name : constant Name_Id := N + 342; - Name_Unknown : constant Name_Id := N + 343; - Name_Unrestricted : constant Name_Id := N + 344; - Name_Uppercase : constant Name_Id := N + 345; - Name_User : constant Name_Id := N + 346; - Name_VAX_Float : constant Name_Id := N + 347; - Name_VMS : constant Name_Id := N + 348; - Name_Vtable_Ptr : constant Name_Id := N + 349; - Name_Working_Storage : constant Name_Id := N + 350; + Name_As_Is : constant Name_Id := N + 273; + Name_Attribute_Name : constant Name_Id := N + 274; + Name_Body_File_Name : constant Name_Id := N + 275; + Name_Boolean_Entry_Barriers : constant Name_Id := N + 276; + Name_Check : constant Name_Id := N + 277; + Name_Casing : constant Name_Id := N + 278; + Name_Code : constant Name_Id := N + 279; + Name_Component : constant Name_Id := N + 280; + Name_Component_Size_4 : constant Name_Id := N + 281; + Name_Copy : constant Name_Id := N + 282; + Name_D_Float : constant Name_Id := N + 283; + Name_Descriptor : constant Name_Id := N + 284; + Name_Dot_Replacement : constant Name_Id := N + 285; + Name_Dynamic : constant Name_Id := N + 286; + Name_Entity : constant Name_Id := N + 287; + Name_Entry_Count : constant Name_Id := N + 288; + Name_External_Name : constant Name_Id := N + 289; + Name_First_Optional_Parameter : constant Name_Id := N + 290; + Name_Form : constant Name_Id := N + 291; + Name_G_Float : constant Name_Id := N + 292; + Name_Gcc : constant Name_Id := N + 293; + Name_Gnat : constant Name_Id := N + 294; + Name_GPL : constant Name_Id := N + 295; + Name_IEEE_Float : constant Name_Id := N + 296; + Name_Ignore : constant Name_Id := N + 297; + Name_Info : constant Name_Id := N + 298; + Name_Internal : constant Name_Id := N + 299; + Name_Link_Name : constant Name_Id := N + 300; + Name_Lowercase : constant Name_Id := N + 301; + Name_Max_Entry_Queue_Depth : constant Name_Id := N + 302; + Name_Max_Entry_Queue_Length : constant Name_Id := N + 303; + Name_Max_Size : constant Name_Id := N + 304; + Name_Mechanism : constant Name_Id := N + 305; + Name_Message : constant Name_Id := N + 306; + Name_Mixedcase : constant Name_Id := N + 307; + Name_Modified_GPL : constant Name_Id := N + 308; + Name_Name : constant Name_Id := N + 309; + Name_NCA : constant Name_Id := N + 310; + Name_No : constant Name_Id := N + 311; + Name_No_Dependence : constant Name_Id := N + 312; + Name_No_Dynamic_Attachment : constant Name_Id := N + 313; + Name_No_Dynamic_Interrupts : constant Name_Id := N + 314; + Name_No_Requeue : constant Name_Id := N + 315; + Name_No_Requeue_Statements : constant Name_Id := N + 316; + Name_No_Task_Attributes : constant Name_Id := N + 317; + Name_No_Task_Attributes_Package : constant Name_Id := N + 318; + Name_On : constant Name_Id := N + 319; + Name_Parameter_Types : constant Name_Id := N + 320; + Name_Reference : constant Name_Id := N + 321; + Name_Restricted : constant Name_Id := N + 322; + Name_Result_Mechanism : constant Name_Id := N + 323; + Name_Result_Type : constant Name_Id := N + 324; + Name_Runtime : constant Name_Id := N + 325; + Name_SB : constant Name_Id := N + 326; + Name_Secondary_Stack_Size : constant Name_Id := N + 327; + Name_Section : constant Name_Id := N + 328; + Name_Semaphore : constant Name_Id := N + 329; + Name_Simple_Barriers : constant Name_Id := N + 330; + Name_Spec_File_Name : constant Name_Id := N + 331; + Name_State : constant Name_Id := N + 332; + Name_Static : constant Name_Id := N + 333; + Name_Stack_Size : constant Name_Id := N + 334; + Name_Subunit_File_Name : constant Name_Id := N + 335; + Name_Task_Stack_Size_Default : constant Name_Id := N + 336; + Name_Task_Type : constant Name_Id := N + 337; + Name_Time_Slicing_Enabled : constant Name_Id := N + 338; + Name_Top_Guard : constant Name_Id := N + 339; + Name_UBA : constant Name_Id := N + 340; + Name_UBS : constant Name_Id := N + 341; + Name_UBSB : constant Name_Id := N + 342; + Name_Unit_Name : constant Name_Id := N + 343; + Name_Unknown : constant Name_Id := N + 344; + Name_Unrestricted : constant Name_Id := N + 345; + Name_Uppercase : constant Name_Id := N + 346; + Name_User : constant Name_Id := N + 347; + Name_VAX_Float : constant Name_Id := N + 348; + Name_VMS : constant Name_Id := N + 349; + Name_Vtable_Ptr : constant Name_Id := N + 350; + Name_Working_Storage : constant Name_Id := N + 351; -- Names of recognized attributes. The entries with the comment "Ada 83" -- are attributes that are defined in Ada 83, but not in Ada 95. These @@ -625,165 +630,166 @@ package Snames is -- The entries marked VMS are recognized only in OpenVMS implementations -- of GNAT, and are treated as illegal in all other contexts. - First_Attribute_Name : constant Name_Id := N + 351; - Name_Abort_Signal : constant Name_Id := N + 351; -- GNAT - Name_Access : constant Name_Id := N + 352; - Name_Address : constant Name_Id := N + 353; - Name_Address_Size : constant Name_Id := N + 354; -- GNAT - Name_Aft : constant Name_Id := N + 355; - Name_Alignment : constant Name_Id := N + 356; - Name_Asm_Input : constant Name_Id := N + 357; -- GNAT - Name_Asm_Output : constant Name_Id := N + 358; -- GNAT - Name_AST_Entry : constant Name_Id := N + 359; -- VMS - Name_Bit : constant Name_Id := N + 360; -- GNAT - Name_Bit_Order : constant Name_Id := N + 361; - Name_Bit_Position : constant Name_Id := N + 362; -- GNAT - Name_Body_Version : constant Name_Id := N + 363; - Name_Callable : constant Name_Id := N + 364; - Name_Caller : constant Name_Id := N + 365; - Name_Code_Address : constant Name_Id := N + 366; -- GNAT - Name_Component_Size : constant Name_Id := N + 367; - Name_Compose : constant Name_Id := N + 368; - Name_Constrained : constant Name_Id := N + 369; - Name_Count : constant Name_Id := N + 370; - Name_Default_Bit_Order : constant Name_Id := N + 371; -- GNAT - Name_Definite : constant Name_Id := N + 372; - Name_Delta : constant Name_Id := N + 373; - Name_Denorm : constant Name_Id := N + 374; - Name_Digits : constant Name_Id := N + 375; - Name_Elaborated : constant Name_Id := N + 376; -- GNAT - Name_Emax : constant Name_Id := N + 377; -- Ada 83 - Name_Enum_Rep : constant Name_Id := N + 378; -- GNAT - Name_Epsilon : constant Name_Id := N + 379; -- Ada 83 - Name_Exponent : constant Name_Id := N + 380; - Name_External_Tag : constant Name_Id := N + 381; - Name_First : constant Name_Id := N + 382; - Name_First_Bit : constant Name_Id := N + 383; - Name_Fixed_Value : constant Name_Id := N + 384; -- GNAT - Name_Fore : constant Name_Id := N + 385; - Name_Has_Access_Values : constant Name_Id := N + 386; -- GNAT - Name_Has_Discriminants : constant Name_Id := N + 387; -- GNAT - Name_Identity : constant Name_Id := N + 388; - Name_Img : constant Name_Id := N + 389; -- GNAT - Name_Integer_Value : constant Name_Id := N + 390; -- GNAT - Name_Large : constant Name_Id := N + 391; -- Ada 83 - Name_Last : constant Name_Id := N + 392; - Name_Last_Bit : constant Name_Id := N + 393; - Name_Leading_Part : constant Name_Id := N + 394; - Name_Length : constant Name_Id := N + 395; - Name_Machine_Emax : constant Name_Id := N + 396; - Name_Machine_Emin : constant Name_Id := N + 397; - Name_Machine_Mantissa : constant Name_Id := N + 398; - Name_Machine_Overflows : constant Name_Id := N + 399; - Name_Machine_Radix : constant Name_Id := N + 400; - Name_Machine_Rounds : constant Name_Id := N + 401; - Name_Machine_Size : constant Name_Id := N + 402; -- GNAT - Name_Mantissa : constant Name_Id := N + 403; -- Ada 83 - Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 404; - Name_Maximum_Alignment : constant Name_Id := N + 405; -- GNAT - Name_Mechanism_Code : constant Name_Id := N + 406; -- GNAT - Name_Mod : constant Name_Id := N + 407; - Name_Model_Emin : constant Name_Id := N + 408; - Name_Model_Epsilon : constant Name_Id := N + 409; - Name_Model_Mantissa : constant Name_Id := N + 410; - Name_Model_Small : constant Name_Id := N + 411; - Name_Modulus : constant Name_Id := N + 412; - Name_Null_Parameter : constant Name_Id := N + 413; -- GNAT - Name_Object_Size : constant Name_Id := N + 414; -- GNAT - Name_Partition_ID : constant Name_Id := N + 415; - Name_Passed_By_Reference : constant Name_Id := N + 416; -- GNAT - Name_Pool_Address : constant Name_Id := N + 417; - Name_Pos : constant Name_Id := N + 418; - Name_Position : constant Name_Id := N + 419; - Name_Range : constant Name_Id := N + 420; - Name_Range_Length : constant Name_Id := N + 421; -- GNAT - Name_Round : constant Name_Id := N + 422; - Name_Safe_Emax : constant Name_Id := N + 423; -- Ada 83 - Name_Safe_First : constant Name_Id := N + 424; - Name_Safe_Large : constant Name_Id := N + 425; -- Ada 83 - Name_Safe_Last : constant Name_Id := N + 426; - Name_Safe_Small : constant Name_Id := N + 427; -- Ada 83 - Name_Scale : constant Name_Id := N + 428; - Name_Scaling : constant Name_Id := N + 429; - Name_Signed_Zeros : constant Name_Id := N + 430; - Name_Size : constant Name_Id := N + 431; - Name_Small : constant Name_Id := N + 432; - Name_Storage_Size : constant Name_Id := N + 433; - Name_Storage_Unit : constant Name_Id := N + 434; -- GNAT - Name_Stream_Size : constant Name_Id := N + 435; -- Ada 05 - Name_Tag : constant Name_Id := N + 436; - Name_Target_Name : constant Name_Id := N + 437; -- GNAT - Name_Terminated : constant Name_Id := N + 438; - Name_To_Address : constant Name_Id := N + 439; -- GNAT - Name_Type_Class : constant Name_Id := N + 440; -- GNAT - Name_UET_Address : constant Name_Id := N + 441; -- GNAT - Name_Unbiased_Rounding : constant Name_Id := N + 442; - Name_Unchecked_Access : constant Name_Id := N + 443; - Name_Unconstrained_Array : constant Name_Id := N + 444; - Name_Universal_Literal_String : constant Name_Id := N + 445; -- GNAT - Name_Unrestricted_Access : constant Name_Id := N + 446; -- GNAT - Name_VADS_Size : constant Name_Id := N + 447; -- GNAT - Name_Val : constant Name_Id := N + 448; - Name_Valid : constant Name_Id := N + 449; - Name_Value_Size : constant Name_Id := N + 450; -- GNAT - Name_Version : constant Name_Id := N + 451; - Name_Wchar_T_Size : constant Name_Id := N + 452; -- GNAT - Name_Wide_Wide_Width : constant Name_Id := N + 453; -- Ada 05 - Name_Wide_Width : constant Name_Id := N + 454; - Name_Width : constant Name_Id := N + 455; - Name_Word_Size : constant Name_Id := N + 456; -- GNAT + First_Attribute_Name : constant Name_Id := N + 352; + Name_Abort_Signal : constant Name_Id := N + 352; -- GNAT + Name_Access : constant Name_Id := N + 353; + Name_Address : constant Name_Id := N + 354; + Name_Address_Size : constant Name_Id := N + 355; -- GNAT + Name_Aft : constant Name_Id := N + 356; + Name_Alignment : constant Name_Id := N + 357; + Name_Asm_Input : constant Name_Id := N + 358; -- GNAT + Name_Asm_Output : constant Name_Id := N + 359; -- GNAT + Name_AST_Entry : constant Name_Id := N + 360; -- VMS + Name_Bit : constant Name_Id := N + 361; -- GNAT + Name_Bit_Order : constant Name_Id := N + 362; + Name_Bit_Position : constant Name_Id := N + 363; -- GNAT + Name_Body_Version : constant Name_Id := N + 364; + Name_Callable : constant Name_Id := N + 365; + Name_Caller : constant Name_Id := N + 366; + Name_Code_Address : constant Name_Id := N + 367; -- GNAT + Name_Component_Size : constant Name_Id := N + 368; + Name_Compose : constant Name_Id := N + 369; + Name_Constrained : constant Name_Id := N + 370; + Name_Count : constant Name_Id := N + 371; + Name_Default_Bit_Order : constant Name_Id := N + 372; -- GNAT + Name_Definite : constant Name_Id := N + 373; + Name_Delta : constant Name_Id := N + 374; + Name_Denorm : constant Name_Id := N + 375; + Name_Digits : constant Name_Id := N + 376; + Name_Elaborated : constant Name_Id := N + 377; -- GNAT + Name_Emax : constant Name_Id := N + 378; -- Ada 83 + Name_Enum_Rep : constant Name_Id := N + 379; -- GNAT + Name_Epsilon : constant Name_Id := N + 380; -- Ada 83 + Name_Exponent : constant Name_Id := N + 381; + Name_External_Tag : constant Name_Id := N + 382; + Name_First : constant Name_Id := N + 383; + Name_First_Bit : constant Name_Id := N + 384; + Name_Fixed_Value : constant Name_Id := N + 385; -- GNAT + Name_Fore : constant Name_Id := N + 386; + Name_Has_Access_Values : constant Name_Id := N + 387; -- GNAT + Name_Has_Discriminants : constant Name_Id := N + 388; -- GNAT + Name_Identity : constant Name_Id := N + 389; + Name_Img : constant Name_Id := N + 390; -- GNAT + Name_Integer_Value : constant Name_Id := N + 391; -- GNAT + Name_Large : constant Name_Id := N + 392; -- Ada 83 + Name_Last : constant Name_Id := N + 393; + Name_Last_Bit : constant Name_Id := N + 394; + Name_Leading_Part : constant Name_Id := N + 395; + Name_Length : constant Name_Id := N + 396; + Name_Machine_Emax : constant Name_Id := N + 397; + Name_Machine_Emin : constant Name_Id := N + 398; + Name_Machine_Mantissa : constant Name_Id := N + 399; + Name_Machine_Overflows : constant Name_Id := N + 400; + Name_Machine_Radix : constant Name_Id := N + 401; + Name_Machine_Rounding : constant Name_Id := N + 402; -- Ada 05 + Name_Machine_Rounds : constant Name_Id := N + 403; + Name_Machine_Size : constant Name_Id := N + 404; -- GNAT + Name_Mantissa : constant Name_Id := N + 405; -- Ada 83 + Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 406; + Name_Maximum_Alignment : constant Name_Id := N + 407; -- GNAT + Name_Mechanism_Code : constant Name_Id := N + 408; -- GNAT + Name_Mod : constant Name_Id := N + 409; + Name_Model_Emin : constant Name_Id := N + 410; + Name_Model_Epsilon : constant Name_Id := N + 411; + Name_Model_Mantissa : constant Name_Id := N + 412; + Name_Model_Small : constant Name_Id := N + 413; + Name_Modulus : constant Name_Id := N + 414; + Name_Null_Parameter : constant Name_Id := N + 415; -- GNAT + Name_Object_Size : constant Name_Id := N + 416; -- GNAT + Name_Partition_ID : constant Name_Id := N + 417; + Name_Passed_By_Reference : constant Name_Id := N + 418; -- GNAT + Name_Pool_Address : constant Name_Id := N + 419; + Name_Pos : constant Name_Id := N + 420; + Name_Position : constant Name_Id := N + 421; + Name_Range : constant Name_Id := N + 422; + Name_Range_Length : constant Name_Id := N + 423; -- GNAT + Name_Round : constant Name_Id := N + 424; + Name_Safe_Emax : constant Name_Id := N + 425; -- Ada 83 + Name_Safe_First : constant Name_Id := N + 426; + Name_Safe_Large : constant Name_Id := N + 427; -- Ada 83 + Name_Safe_Last : constant Name_Id := N + 428; + Name_Safe_Small : constant Name_Id := N + 429; -- Ada 83 + Name_Scale : constant Name_Id := N + 430; + Name_Scaling : constant Name_Id := N + 431; + Name_Signed_Zeros : constant Name_Id := N + 432; + Name_Size : constant Name_Id := N + 433; + Name_Small : constant Name_Id := N + 434; + Name_Storage_Size : constant Name_Id := N + 435; + Name_Storage_Unit : constant Name_Id := N + 436; -- GNAT + Name_Stream_Size : constant Name_Id := N + 437; -- Ada 05 + Name_Tag : constant Name_Id := N + 438; + Name_Target_Name : constant Name_Id := N + 439; -- GNAT + Name_Terminated : constant Name_Id := N + 440; + Name_To_Address : constant Name_Id := N + 441; -- GNAT + Name_Type_Class : constant Name_Id := N + 442; -- GNAT + Name_UET_Address : constant Name_Id := N + 443; -- GNAT + Name_Unbiased_Rounding : constant Name_Id := N + 444; + Name_Unchecked_Access : constant Name_Id := N + 445; + Name_Unconstrained_Array : constant Name_Id := N + 446; + Name_Universal_Literal_String : constant Name_Id := N + 447; -- GNAT + Name_Unrestricted_Access : constant Name_Id := N + 448; -- GNAT + Name_VADS_Size : constant Name_Id := N + 449; -- GNAT + Name_Val : constant Name_Id := N + 450; + Name_Valid : constant Name_Id := N + 451; + Name_Value_Size : constant Name_Id := N + 452; -- GNAT + Name_Version : constant Name_Id := N + 453; + Name_Wchar_T_Size : constant Name_Id := N + 454; -- GNAT + Name_Wide_Wide_Width : constant Name_Id := N + 455; -- Ada 05 + Name_Wide_Width : constant Name_Id := N + 456; + Name_Width : constant Name_Id := N + 457; + Name_Word_Size : constant Name_Id := N + 458; -- GNAT -- Attributes that designate attributes returning renamable functions, -- i.e. functions that return other than a universal value and that -- have non-universal arguments. - First_Renamable_Function_Attribute : constant Name_Id := N + 457; - Name_Adjacent : constant Name_Id := N + 457; - Name_Ceiling : constant Name_Id := N + 458; - Name_Copy_Sign : constant Name_Id := N + 459; - Name_Floor : constant Name_Id := N + 460; - Name_Fraction : constant Name_Id := N + 461; - Name_Image : constant Name_Id := N + 462; - Name_Input : constant Name_Id := N + 463; - Name_Machine : constant Name_Id := N + 464; - Name_Max : constant Name_Id := N + 465; - Name_Min : constant Name_Id := N + 466; - Name_Model : constant Name_Id := N + 467; - Name_Pred : constant Name_Id := N + 468; - Name_Remainder : constant Name_Id := N + 469; - Name_Rounding : constant Name_Id := N + 470; - Name_Succ : constant Name_Id := N + 471; - Name_Truncation : constant Name_Id := N + 472; - Name_Value : constant Name_Id := N + 473; - Name_Wide_Image : constant Name_Id := N + 474; - Name_Wide_Wide_Image : constant Name_Id := N + 475; - Name_Wide_Value : constant Name_Id := N + 476; - Name_Wide_Wide_Value : constant Name_Id := N + 477; - Last_Renamable_Function_Attribute : constant Name_Id := N + 477; + First_Renamable_Function_Attribute : constant Name_Id := N + 459; + Name_Adjacent : constant Name_Id := N + 459; + Name_Ceiling : constant Name_Id := N + 460; + Name_Copy_Sign : constant Name_Id := N + 461; + Name_Floor : constant Name_Id := N + 462; + Name_Fraction : constant Name_Id := N + 463; + Name_Image : constant Name_Id := N + 464; + Name_Input : constant Name_Id := N + 465; + Name_Machine : constant Name_Id := N + 466; + Name_Max : constant Name_Id := N + 467; + Name_Min : constant Name_Id := N + 468; + Name_Model : constant Name_Id := N + 469; + Name_Pred : constant Name_Id := N + 470; + Name_Remainder : constant Name_Id := N + 471; + Name_Rounding : constant Name_Id := N + 472; + Name_Succ : constant Name_Id := N + 473; + Name_Truncation : constant Name_Id := N + 474; + Name_Value : constant Name_Id := N + 475; + Name_Wide_Image : constant Name_Id := N + 476; + Name_Wide_Wide_Image : constant Name_Id := N + 477; + Name_Wide_Value : constant Name_Id := N + 478; + Name_Wide_Wide_Value : constant Name_Id := N + 479; + Last_Renamable_Function_Attribute : constant Name_Id := N + 479; -- Attributes that designate procedures - First_Procedure_Attribute : constant Name_Id := N + 478; - Name_Output : constant Name_Id := N + 478; - Name_Read : constant Name_Id := N + 479; - Name_Write : constant Name_Id := N + 480; - Last_Procedure_Attribute : constant Name_Id := N + 480; + First_Procedure_Attribute : constant Name_Id := N + 480; + Name_Output : constant Name_Id := N + 480; + Name_Read : constant Name_Id := N + 481; + Name_Write : constant Name_Id := N + 482; + Last_Procedure_Attribute : constant Name_Id := N + 482; -- Remaining attributes are ones that return entities - First_Entity_Attribute_Name : constant Name_Id := N + 481; - Name_Elab_Body : constant Name_Id := N + 481; -- GNAT - Name_Elab_Spec : constant Name_Id := N + 482; -- GNAT - Name_Storage_Pool : constant Name_Id := N + 483; + First_Entity_Attribute_Name : constant Name_Id := N + 483; + Name_Elab_Body : constant Name_Id := N + 483; -- GNAT + Name_Elab_Spec : constant Name_Id := N + 484; -- GNAT + Name_Storage_Pool : constant Name_Id := N + 485; -- These attributes are the ones that return types - First_Type_Attribute_Name : constant Name_Id := N + 484; - Name_Base : constant Name_Id := N + 484; - Name_Class : constant Name_Id := N + 485; - Last_Type_Attribute_Name : constant Name_Id := N + 485; - Last_Entity_Attribute_Name : constant Name_Id := N + 485; - Last_Attribute_Name : constant Name_Id := N + 485; + First_Type_Attribute_Name : constant Name_Id := N + 486; + Name_Base : constant Name_Id := N + 486; + Name_Class : constant Name_Id := N + 487; + Last_Type_Attribute_Name : constant Name_Id := N + 487; + Last_Entity_Attribute_Name : constant Name_Id := N + 487; + Last_Attribute_Name : constant Name_Id := N + 487; -- Names of recognized locking policy identifiers @@ -791,10 +797,10 @@ package Snames is -- name (e.g. C for Ceiling_Locking). If new policy names are added, -- the first character must be distinct. - First_Locking_Policy_Name : constant Name_Id := N + 486; - Name_Ceiling_Locking : constant Name_Id := N + 486; - Name_Inheritance_Locking : constant Name_Id := N + 487; - Last_Locking_Policy_Name : constant Name_Id := N + 487; + First_Locking_Policy_Name : constant Name_Id := N + 488; + Name_Ceiling_Locking : constant Name_Id := N + 488; + Name_Inheritance_Locking : constant Name_Id := N + 489; + Last_Locking_Policy_Name : constant Name_Id := N + 489; -- Names of recognized queuing policy identifiers @@ -802,10 +808,10 @@ package Snames is -- name (e.g. F for FIFO_Queuing). If new policy names are added, -- the first character must be distinct. - First_Queuing_Policy_Name : constant Name_Id := N + 488; - Name_FIFO_Queuing : constant Name_Id := N + 488; - Name_Priority_Queuing : constant Name_Id := N + 489; - Last_Queuing_Policy_Name : constant Name_Id := N + 489; + First_Queuing_Policy_Name : constant Name_Id := N + 490; + Name_FIFO_Queuing : constant Name_Id := N + 490; + Name_Priority_Queuing : constant Name_Id := N + 491; + Last_Queuing_Policy_Name : constant Name_Id := N + 491; -- Names of recognized task dispatching policy identifiers @@ -813,215 +819,220 @@ package Snames is -- name (e.g. F for FIFO_WIthinn_Priorities). If new policy names -- are added, the first character must be distinct. - First_Task_Dispatching_Policy_Name : constant Name_Id := N + 490; - Name_FIFO_Within_Priorities : constant Name_Id := N + 490; - Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 490; + First_Task_Dispatching_Policy_Name : constant Name_Id := N + 492; + Name_FIFO_Within_Priorities : constant Name_Id := N + 492; + Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 492; -- Names of recognized checks for pragma Suppress - First_Check_Name : constant Name_Id := N + 491; - Name_Access_Check : constant Name_Id := N + 491; - Name_Accessibility_Check : constant Name_Id := N + 492; - Name_Discriminant_Check : constant Name_Id := N + 493; - Name_Division_Check : constant Name_Id := N + 494; - Name_Elaboration_Check : constant Name_Id := N + 495; - Name_Index_Check : constant Name_Id := N + 496; - Name_Length_Check : constant Name_Id := N + 497; - Name_Overflow_Check : constant Name_Id := N + 498; - Name_Range_Check : constant Name_Id := N + 499; - Name_Storage_Check : constant Name_Id := N + 500; - Name_Tag_Check : constant Name_Id := N + 501; - Name_All_Checks : constant Name_Id := N + 502; - Last_Check_Name : constant Name_Id := N + 502; + First_Check_Name : constant Name_Id := N + 493; + Name_Access_Check : constant Name_Id := N + 493; + Name_Accessibility_Check : constant Name_Id := N + 494; + Name_Discriminant_Check : constant Name_Id := N + 495; + Name_Division_Check : constant Name_Id := N + 496; + Name_Elaboration_Check : constant Name_Id := N + 497; + Name_Index_Check : constant Name_Id := N + 498; + Name_Length_Check : constant Name_Id := N + 499; + Name_Overflow_Check : constant Name_Id := N + 500; + Name_Range_Check : constant Name_Id := N + 501; + Name_Storage_Check : constant Name_Id := N + 502; + Name_Tag_Check : constant Name_Id := N + 503; + Name_All_Checks : constant Name_Id := N + 504; + Last_Check_Name : constant Name_Id := N + 504; -- Names corresponding to reserved keywords, excluding those already -- declared in the attribute list (Access, Delta, Digits, Mod, Range). - Name_Abort : constant Name_Id := N + 503; - Name_Abs : constant Name_Id := N + 504; - Name_Accept : constant Name_Id := N + 505; - Name_And : constant Name_Id := N + 506; - Name_All : constant Name_Id := N + 507; - Name_Array : constant Name_Id := N + 508; - Name_At : constant Name_Id := N + 509; - Name_Begin : constant Name_Id := N + 510; - Name_Body : constant Name_Id := N + 511; - Name_Case : constant Name_Id := N + 512; - Name_Constant : constant Name_Id := N + 513; - Name_Declare : constant Name_Id := N + 514; - Name_Delay : constant Name_Id := N + 515; - Name_Do : constant Name_Id := N + 516; - Name_Else : constant Name_Id := N + 517; - Name_Elsif : constant Name_Id := N + 518; - Name_End : constant Name_Id := N + 519; - Name_Entry : constant Name_Id := N + 520; - Name_Exception : constant Name_Id := N + 521; - Name_Exit : constant Name_Id := N + 522; - Name_For : constant Name_Id := N + 523; - Name_Function : constant Name_Id := N + 524; - Name_Generic : constant Name_Id := N + 525; - Name_Goto : constant Name_Id := N + 526; - Name_If : constant Name_Id := N + 527; - Name_In : constant Name_Id := N + 528; - Name_Is : constant Name_Id := N + 529; - Name_Limited : constant Name_Id := N + 530; - Name_Loop : constant Name_Id := N + 531; - Name_New : constant Name_Id := N + 532; - Name_Not : constant Name_Id := N + 533; - Name_Null : constant Name_Id := N + 534; - Name_Of : constant Name_Id := N + 535; - Name_Or : constant Name_Id := N + 536; - Name_Others : constant Name_Id := N + 537; - Name_Out : constant Name_Id := N + 538; - Name_Package : constant Name_Id := N + 539; - Name_Pragma : constant Name_Id := N + 540; - Name_Private : constant Name_Id := N + 541; - Name_Procedure : constant Name_Id := N + 542; - Name_Raise : constant Name_Id := N + 543; - Name_Record : constant Name_Id := N + 544; - Name_Rem : constant Name_Id := N + 545; - Name_Renames : constant Name_Id := N + 546; - Name_Return : constant Name_Id := N + 547; - Name_Reverse : constant Name_Id := N + 548; - Name_Select : constant Name_Id := N + 549; - Name_Separate : constant Name_Id := N + 550; - Name_Subtype : constant Name_Id := N + 551; - Name_Task : constant Name_Id := N + 552; - Name_Terminate : constant Name_Id := N + 553; - Name_Then : constant Name_Id := N + 554; - Name_Type : constant Name_Id := N + 555; - Name_Use : constant Name_Id := N + 556; - Name_When : constant Name_Id := N + 557; - Name_While : constant Name_Id := N + 558; - Name_With : constant Name_Id := N + 559; - Name_Xor : constant Name_Id := N + 560; + Name_Abort : constant Name_Id := N + 505; + Name_Abs : constant Name_Id := N + 506; + Name_Accept : constant Name_Id := N + 507; + Name_And : constant Name_Id := N + 508; + Name_All : constant Name_Id := N + 509; + Name_Array : constant Name_Id := N + 510; + Name_At : constant Name_Id := N + 511; + Name_Begin : constant Name_Id := N + 512; + Name_Body : constant Name_Id := N + 513; + Name_Case : constant Name_Id := N + 514; + Name_Constant : constant Name_Id := N + 515; + Name_Declare : constant Name_Id := N + 516; + Name_Delay : constant Name_Id := N + 517; + Name_Do : constant Name_Id := N + 518; + Name_Else : constant Name_Id := N + 519; + Name_Elsif : constant Name_Id := N + 520; + Name_End : constant Name_Id := N + 521; + Name_Entry : constant Name_Id := N + 522; + Name_Exception : constant Name_Id := N + 523; + Name_Exit : constant Name_Id := N + 524; + Name_For : constant Name_Id := N + 525; + Name_Function : constant Name_Id := N + 526; + Name_Generic : constant Name_Id := N + 527; + Name_Goto : constant Name_Id := N + 528; + Name_If : constant Name_Id := N + 529; + Name_In : constant Name_Id := N + 530; + Name_Is : constant Name_Id := N + 531; + Name_Limited : constant Name_Id := N + 532; + Name_Loop : constant Name_Id := N + 533; + Name_New : constant Name_Id := N + 534; + Name_Not : constant Name_Id := N + 535; + Name_Null : constant Name_Id := N + 536; + Name_Of : constant Name_Id := N + 537; + Name_Or : constant Name_Id := N + 538; + Name_Others : constant Name_Id := N + 539; + Name_Out : constant Name_Id := N + 540; + Name_Package : constant Name_Id := N + 541; + Name_Pragma : constant Name_Id := N + 542; + Name_Private : constant Name_Id := N + 543; + Name_Procedure : constant Name_Id := N + 544; + Name_Raise : constant Name_Id := N + 545; + Name_Record : constant Name_Id := N + 546; + Name_Rem : constant Name_Id := N + 547; + Name_Renames : constant Name_Id := N + 548; + Name_Return : constant Name_Id := N + 549; + Name_Reverse : constant Name_Id := N + 550; + Name_Select : constant Name_Id := N + 551; + Name_Separate : constant Name_Id := N + 552; + Name_Subtype : constant Name_Id := N + 553; + Name_Task : constant Name_Id := N + 554; + Name_Terminate : constant Name_Id := N + 555; + Name_Then : constant Name_Id := N + 556; + Name_Type : constant Name_Id := N + 557; + Name_Use : constant Name_Id := N + 558; + Name_When : constant Name_Id := N + 559; + Name_While : constant Name_Id := N + 560; + Name_With : constant Name_Id := N + 561; + Name_Xor : constant Name_Id := N + 562; -- Names of intrinsic subprograms -- Note: Asm is missing from this list, since Asm is a legitimate -- convention name. So is To_Adress, which is a GNAT attribute. - First_Intrinsic_Name : constant Name_Id := N + 561; - Name_Divide : constant Name_Id := N + 561; - Name_Enclosing_Entity : constant Name_Id := N + 562; - Name_Exception_Information : constant Name_Id := N + 563; - Name_Exception_Message : constant Name_Id := N + 564; - Name_Exception_Name : constant Name_Id := N + 565; - Name_File : constant Name_Id := N + 566; - Name_Generic_Dispatching_Constructor : constant Name_Id := N + 567; - Name_Import_Address : constant Name_Id := N + 568; - Name_Import_Largest_Value : constant Name_Id := N + 569; - Name_Import_Value : constant Name_Id := N + 570; - Name_Is_Negative : constant Name_Id := N + 571; - Name_Line : constant Name_Id := N + 572; - Name_Rotate_Left : constant Name_Id := N + 573; - Name_Rotate_Right : constant Name_Id := N + 574; - Name_Shift_Left : constant Name_Id := N + 575; - Name_Shift_Right : constant Name_Id := N + 576; - Name_Shift_Right_Arithmetic : constant Name_Id := N + 577; - Name_Source_Location : constant Name_Id := N + 578; - Name_Unchecked_Conversion : constant Name_Id := N + 579; - Name_Unchecked_Deallocation : constant Name_Id := N + 580; - Name_To_Pointer : constant Name_Id := N + 581; - Last_Intrinsic_Name : constant Name_Id := N + 581; + First_Intrinsic_Name : constant Name_Id := N + 563; + Name_Divide : constant Name_Id := N + 563; + Name_Enclosing_Entity : constant Name_Id := N + 564; + Name_Exception_Information : constant Name_Id := N + 565; + Name_Exception_Message : constant Name_Id := N + 566; + Name_Exception_Name : constant Name_Id := N + 567; + Name_File : constant Name_Id := N + 568; + Name_Generic_Dispatching_Constructor : constant Name_Id := N + 569; + Name_Import_Address : constant Name_Id := N + 570; + Name_Import_Largest_Value : constant Name_Id := N + 571; + Name_Import_Value : constant Name_Id := N + 572; + Name_Is_Negative : constant Name_Id := N + 573; + Name_Line : constant Name_Id := N + 574; + Name_Rotate_Left : constant Name_Id := N + 575; + Name_Rotate_Right : constant Name_Id := N + 576; + Name_Shift_Left : constant Name_Id := N + 577; + Name_Shift_Right : constant Name_Id := N + 578; + Name_Shift_Right_Arithmetic : constant Name_Id := N + 579; + Name_Source_Location : constant Name_Id := N + 580; + Name_Unchecked_Conversion : constant Name_Id := N + 581; + Name_Unchecked_Deallocation : constant Name_Id := N + 582; + Name_To_Pointer : constant Name_Id := N + 583; + Last_Intrinsic_Name : constant Name_Id := N + 583; + + -- Names used in processing intrinsic calls + + Name_Free : constant Name_Id := N + 584; -- Reserved words used only in Ada 95 - First_95_Reserved_Word : constant Name_Id := N + 582; - Name_Abstract : constant Name_Id := N + 582; - Name_Aliased : constant Name_Id := N + 583; - Name_Protected : constant Name_Id := N + 584; - Name_Until : constant Name_Id := N + 585; - Name_Requeue : constant Name_Id := N + 586; - Name_Tagged : constant Name_Id := N + 587; - Last_95_Reserved_Word : constant Name_Id := N + 587; + First_95_Reserved_Word : constant Name_Id := N + 585; + Name_Abstract : constant Name_Id := N + 585; + Name_Aliased : constant Name_Id := N + 586; + Name_Protected : constant Name_Id := N + 587; + Name_Until : constant Name_Id := N + 588; + Name_Requeue : constant Name_Id := N + 589; + Name_Tagged : constant Name_Id := N + 590; + Last_95_Reserved_Word : constant Name_Id := N + 590; subtype Ada_95_Reserved_Words is Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word; -- Miscellaneous names used in semantic checking - Name_Raise_Exception : constant Name_Id := N + 588; + Name_Raise_Exception : constant Name_Id := N + 591; -- Additional reserved words and identifiers used in GNAT Project Files -- Note that Name_External is already previously declared - Name_Ada_Roots : constant Name_Id := N + 589; - Name_Binder : constant Name_Id := N + 590; - Name_Binder_Driver : constant Name_Id := N + 591; - Name_Body_Suffix : constant Name_Id := N + 592; - Name_Builder : constant Name_Id := N + 593; - Name_Compiler : constant Name_Id := N + 594; - Name_Compiler_Driver : constant Name_Id := N + 595; - Name_Compiler_Kind : constant Name_Id := N + 596; - Name_Compute_Dependency : constant Name_Id := N + 597; - Name_Cross_Reference : constant Name_Id := N + 598; - Name_Default_Linker : constant Name_Id := N + 599; - Name_Default_Switches : constant Name_Id := N + 600; - Name_Dependency_Option : constant Name_Id := N + 601; - Name_Exec_Dir : constant Name_Id := N + 602; - Name_Executable : constant Name_Id := N + 603; - Name_Executable_Suffix : constant Name_Id := N + 604; - Name_Extends : constant Name_Id := N + 605; - Name_Externally_Built : constant Name_Id := N + 606; - Name_Finder : constant Name_Id := N + 607; - Name_Global_Configuration_Pragmas : constant Name_Id := N + 608; - Name_Gnatls : constant Name_Id := N + 609; - Name_Gnatstub : constant Name_Id := N + 610; - Name_Implementation : constant Name_Id := N + 611; - Name_Implementation_Exceptions : constant Name_Id := N + 612; - Name_Implementation_Suffix : constant Name_Id := N + 613; - Name_Include_Option : constant Name_Id := N + 614; - Name_Language_Processing : constant Name_Id := N + 615; - Name_Languages : constant Name_Id := N + 616; - Name_Library_Dir : constant Name_Id := N + 617; - Name_Library_Auto_Init : constant Name_Id := N + 618; - Name_Library_GCC : constant Name_Id := N + 619; - Name_Library_Interface : constant Name_Id := N + 620; - Name_Library_Kind : constant Name_Id := N + 621; - Name_Library_Name : constant Name_Id := N + 622; - Name_Library_Options : constant Name_Id := N + 623; - Name_Library_Reference_Symbol_File : constant Name_Id := N + 624; - Name_Library_Src_Dir : constant Name_Id := N + 625; - Name_Library_Symbol_File : constant Name_Id := N + 626; - Name_Library_Symbol_Policy : constant Name_Id := N + 627; - Name_Library_Version : constant Name_Id := N + 628; - Name_Linker : constant Name_Id := N + 629; - Name_Local_Configuration_Pragmas : constant Name_Id := N + 630; - Name_Locally_Removed_Files : constant Name_Id := N + 631; - Name_Metrics : constant Name_Id := N + 632; - Name_Naming : constant Name_Id := N + 633; - Name_Object_Dir : constant Name_Id := N + 634; - Name_Pretty_Printer : constant Name_Id := N + 635; - Name_Project : constant Name_Id := N + 636; - Name_Separate_Suffix : constant Name_Id := N + 637; - Name_Source_Dirs : constant Name_Id := N + 638; - Name_Source_Files : constant Name_Id := N + 639; - Name_Source_List_File : constant Name_Id := N + 640; - Name_Spec : constant Name_Id := N + 641; - Name_Spec_Suffix : constant Name_Id := N + 642; - Name_Specification : constant Name_Id := N + 643; - Name_Specification_Exceptions : constant Name_Id := N + 644; - Name_Specification_Suffix : constant Name_Id := N + 645; - Name_Switches : constant Name_Id := N + 646; + Name_Ada_Roots : constant Name_Id := N + 592; + Name_Binder : constant Name_Id := N + 593; + Name_Binder_Driver : constant Name_Id := N + 594; + Name_Body_Suffix : constant Name_Id := N + 595; + Name_Builder : constant Name_Id := N + 596; + Name_Compiler : constant Name_Id := N + 597; + Name_Compiler_Driver : constant Name_Id := N + 598; + Name_Compiler_Kind : constant Name_Id := N + 599; + Name_Compute_Dependency : constant Name_Id := N + 600; + Name_Cross_Reference : constant Name_Id := N + 601; + Name_Default_Linker : constant Name_Id := N + 602; + Name_Default_Switches : constant Name_Id := N + 603; + Name_Dependency_Option : constant Name_Id := N + 604; + Name_Exec_Dir : constant Name_Id := N + 605; + Name_Executable : constant Name_Id := N + 606; + Name_Executable_Suffix : constant Name_Id := N + 607; + Name_Extends : constant Name_Id := N + 608; + Name_Externally_Built : constant Name_Id := N + 609; + Name_Finder : constant Name_Id := N + 610; + Name_Global_Configuration_Pragmas : constant Name_Id := N + 611; + Name_Gnatls : constant Name_Id := N + 612; + Name_Gnatstub : constant Name_Id := N + 613; + Name_Implementation : constant Name_Id := N + 614; + Name_Implementation_Exceptions : constant Name_Id := N + 615; + Name_Implementation_Suffix : constant Name_Id := N + 616; + Name_Include_Option : constant Name_Id := N + 617; + Name_Language_Processing : constant Name_Id := N + 618; + Name_Languages : constant Name_Id := N + 619; + Name_Library_Ali_Dir : constant Name_Id := N + 620; + Name_Library_Dir : constant Name_Id := N + 621; + Name_Library_Auto_Init : constant Name_Id := N + 622; + Name_Library_GCC : constant Name_Id := N + 623; + Name_Library_Interface : constant Name_Id := N + 624; + Name_Library_Kind : constant Name_Id := N + 625; + Name_Library_Name : constant Name_Id := N + 626; + Name_Library_Options : constant Name_Id := N + 627; + Name_Library_Reference_Symbol_File : constant Name_Id := N + 628; + Name_Library_Src_Dir : constant Name_Id := N + 629; + Name_Library_Symbol_File : constant Name_Id := N + 630; + Name_Library_Symbol_Policy : constant Name_Id := N + 631; + Name_Library_Version : constant Name_Id := N + 632; + Name_Linker : constant Name_Id := N + 633; + Name_Local_Configuration_Pragmas : constant Name_Id := N + 634; + Name_Locally_Removed_Files : constant Name_Id := N + 635; + Name_Metrics : constant Name_Id := N + 636; + Name_Naming : constant Name_Id := N + 637; + Name_Object_Dir : constant Name_Id := N + 638; + Name_Pretty_Printer : constant Name_Id := N + 639; + Name_Project : constant Name_Id := N + 640; + Name_Separate_Suffix : constant Name_Id := N + 641; + Name_Source_Dirs : constant Name_Id := N + 642; + Name_Source_Files : constant Name_Id := N + 643; + Name_Source_List_File : constant Name_Id := N + 644; + Name_Spec : constant Name_Id := N + 645; + Name_Spec_Suffix : constant Name_Id := N + 646; + Name_Specification : constant Name_Id := N + 647; + Name_Specification_Exceptions : constant Name_Id := N + 648; + Name_Specification_Suffix : constant Name_Id := N + 649; + Name_Switches : constant Name_Id := N + 650; -- Other miscellaneous names used in front end - Name_Unaligned_Valid : constant Name_Id := N + 647; + Name_Unaligned_Valid : constant Name_Id := N + 651; -- ---------------------------------------------------------------- - First_2005_Reserved_Word : constant Name_Id := N + 648; - Name_Interface : constant Name_Id := N + 648; - Name_Overriding : constant Name_Id := N + 649; - Name_Synchronized : constant Name_Id := N + 650; - Last_2005_Reserved_Word : constant Name_Id := N + 650; + First_2005_Reserved_Word : constant Name_Id := N + 652; + Name_Interface : constant Name_Id := N + 652; + Name_Overriding : constant Name_Id := N + 653; + Name_Synchronized : constant Name_Id := N + 654; + Last_2005_Reserved_Word : constant Name_Id := N + 654; subtype Ada_2005_Reserved_Words is Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word; -- Mark last defined name for consistency check in Snames body - Last_Predefined_Name : constant Name_Id := N + 650; + Last_Predefined_Name : constant Name_Id := N + 654; subtype Any_Operator_Name is Name_Id range First_Operator_Name .. Last_Operator_Name; @@ -1081,6 +1092,7 @@ package Snames is Attribute_Machine_Mantissa, Attribute_Machine_Overflows, Attribute_Machine_Radix, + Attribute_Machine_Rounding, Attribute_Machine_Rounds, Attribute_Machine_Size, Attribute_Mantissa, |