-- --
-- 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- --
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;
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;
-- 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
-- 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,
-- 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
-- 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 --
---------------------------------------------
-- 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
-- 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).
package body HTable_Subprograms is
- -----------
- -- Equal --
- -----------
+ -----------
+ -- Equal --
+ -----------
function Equal (A, B : System.Address) return Boolean is
Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
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 --
-------------------
-- = 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;
-- 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;
--------------------
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;
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;
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));
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;
-- 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;
----------------------
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;
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;
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;
-- 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);
-----------------
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) :=
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;
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) :=
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 --
------------
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));
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
-- 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
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;
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;
-----------------------
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;
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 --
-----------------------
- 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 --
-------------------------
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;
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;
-------------------
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;
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 --
------------------
-- --
-- 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 --
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
-- 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;
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;
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;
-- 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
-- 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;
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).
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.
-- 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);
-- 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;
-- 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.
-- 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);
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 :=
-- 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);
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;
-- Abstract_Interfaces Elist24
-- Abstract_Interface_Alias Node25
+ -- Current_Use_Clause Node25
-- Overridden_Operation Node26
+ -- Package_Instantiation Node26
-- Wrapped_Entity Node27
-- 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
-- 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
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);
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
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));
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);
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);
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);
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);
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;
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));
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);
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
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);
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);
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);
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);
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);
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;
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));
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 --
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));
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));
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));
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));
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));
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 =>
E_Function =>
Write_Str ("Abstract_Interface_Alias");
+ when E_Package =>
+ Write_Str ("Current_Use_Clause");
+
when others =>
Write_Str ("Field25??");
end case;
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");
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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.
-- 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
-- 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
-- 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.
-- 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)
-- 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
-- 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)
-- 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)
-- 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)
-- 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)
-- 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)
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;
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;
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;
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;
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;
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;
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;
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;
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
-- 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);
-- --
-- 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- --
-- 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;
M_Id : Entity_Id;
Decl : Node_Id;
P : Node_Id;
+ Par : Node_Id;
begin
-- Nothing to do if there is no task hierarchy
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
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;
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);
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))
-- 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
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:
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);
-- 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;
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;
-- 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.
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
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
-- 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);
-- 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 (
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)
-- --
-- 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- --
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
-- 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
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;
-- --
-- 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- --
-- 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:
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
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;
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,
-- 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;
-- 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
-- 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 --
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
-----------------------
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
-- 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 --
-------------------------------------------
-- 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
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
-- 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);
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
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;
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.
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
-- --
-- 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- --
-- 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
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
-----------------------
-----------------------
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,
New_List (
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier =>
- Blk_Ent,
+ Cln_Blk_Ent,
Label_Construct =>
Blk),
Blk),
(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,
(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,
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;
-- 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
-- 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.
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
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
Pid : Entity_Id;
Loc : Source_Ptr)
is
+ Decl : Node_Id;
Obj_Ptr : Node_Id;
begin
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,
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 --
------------------------------
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;
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
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;
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);
E : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
-
begin
return
Make_Function_Call (Loc,
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;
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;
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
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;
------------------------
-- 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
return Type_Conformant_Parameters (
Parameter_Specifications (Prim_Op_Spec),
Parameter_Specifications (Proc_Spec));
-
end Overriding_Possible;
-----------------------------
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;
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.
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;
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));
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
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
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,
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;
begin
New_Plist := New_List;
Formal := First_Formal (Ident);
-
while Present (Formal) loop
New_Param :=
Make_Parameter_Specification (Loc,
-- 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),
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;
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;
end if;
Ident := Defining_Unit_Name (Specification (Decl));
- Nam := Chars (Ident);
New_Plist :=
Build_Protected_Spec (Decl,
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
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
-- Start of processing for Has_Side_Effect
begin
+ Stmt := N;
while Present (Stmt) loop
if Is_Call_Or_Raise (Stmt) then
return True;
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))),
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
-------------------------
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.
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;
-----------------------------
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
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);
-- 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;
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 :=
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);
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);
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)))
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 :=
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;
-- 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
-- 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
-- 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);
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;
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,
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 +
-- 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
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);
-- 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);
-- 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
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 :=
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 :=
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.
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);
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;
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,
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.
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));
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
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;
-- 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
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;
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,
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);
-- 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);
-- ParamN := P.ParamN;
-- if Enqueued (Bnn) then
- -- <temp>A;
+ -- <abortable-statements>
-- end if;
-- at end
-- _clean;
-- end;
-- if not Cancelled (Bnn) then
- -- <temp>T;
+ -- <triggering-statements>
-- end if;
-- elsif C = POK_Task_Entry then
-- begin
-- begin
-- Abort_Undefer;
- -- <temp>A;
+ -- <abortable-statements>
-- at end
-- _clean;
-- end;
-- 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
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'));
-- 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:
-- ...
-- ParamN := P.ParamN;
- Cleanup_Stmts := Parameter_Block_Unpack (Loc, Actuals, Formals);
+ Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
-- Generate:
-- _dispatching_asynchronous_select
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 =>
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.
-- _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
-- 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 =>
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:
-- ...
-- ParamN := P.ParamN;
- TaskE_Stmts := Parameter_Block_Unpack (Loc, Actuals, Formals);
+ TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
-- Generate:
-- _dispatching_asynchronous_select
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))));
-- 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.
-- _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
-- 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
New_Reference_To (C, Loc),
Right_Opnd =>
New_Reference_To (RTE (RE_POK_Task_Entry), Loc)),
+
Then_Statements =>
TaskE_Stmts)),
Analyze (N);
return;
end if;
+
else
N_Orig := N;
end if;
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
-- 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);
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))));
-- 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
-- <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,
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);
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)))
-- 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);
-----------------------------
-- 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;
Actuals := New_List;
Formal := First (Parameter_Specifications (Spec));
-
while Present (Formal) loop
Append_To (Actuals,
Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
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)));
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
-- <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);
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;
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.
----------------------
-- 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.
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);
-- 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;
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
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));
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;
(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;
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);
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 =>
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 =>
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,
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 =>
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,
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;
--------------------------------
-- 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;
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);
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))));
-- 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);
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));
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,
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
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
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);
--------------------------------------
-- 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
-- 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
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,
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)));
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
-- 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:
-- 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
-- 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.
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
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,
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
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;
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)
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
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;
-- 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;
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
-- 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);
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));
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));
-- 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
-- <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,
-- 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).
-- 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
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));
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 --
elsif Is_Protected_Type (Ttyp) then
D := First_Discriminant (Ttyp);
-
while Chars (D) /= Chars (Entity (Bound)) loop
Next_Discriminant (D);
end loop;
begin
N := First (Visible_Declarations (T));
-
while Present (N) loop
if Nkind (N) = N_Pragma then
if Chars (N) = P then
end loop;
N := First (Private_Declarations (T));
-
while Present (N) loop
if Nkind (N) = N_Pragma then
if Chars (N) = P then
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 --
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
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);
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));
begin
if not Restricted then
+
-- Appends the _object argument
Append_To (Args,
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
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
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);
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;
----------------------------
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>;
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;
----------------------
-----------------
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)));
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));
if Is_Entity_Name (N) then
declare
E : constant Entity_Id := Entity (N);
-
begin
if Present (E)
and then (Ekind (E) = E_Constant
-- --
-- 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- --
-- 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;
-- --
-- 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- --
-- 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
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
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 --
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 ("__");
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;
-- 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 ???
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 --
---------------------------------
else
Add_Char_To_Name_Buffer ('X');
end if;
-
end Set_BNPE_Suffix;
---------------------
exit;
end if;
end loop;
-
end Strip_Suffixes;
end Exp_Dbug;
-- --
-- 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- --
-- 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.
-- 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:
-- 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 --
-----------------------
-- 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 --
----------------------------
-- --
-- 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- --
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;
-- 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.
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);
Make_Identifier (Loc, Name_uS)))));
-- Generate:
+
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure;
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,
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);
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,
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);
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,
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);
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;
-----------------------------
(Etype (First_Entity (Target)),
Make_Explicit_Dereference (Loc,
New_Reference_To (Defining_Identifier (Decl_2), Loc))));
-
end if;
Formal := Next (First (Formals));
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),
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.
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);
+ ----------------------------------------
+ -- Make_Disp_Asynchronous_Select_Body --
+ ----------------------------------------
- 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;
+ 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;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Stmts : constant List_Id := New_List;
begin
- if not RTE_Available (RE_Tag) then
- Error_Msg_CRT ("tagged types", Typ);
- return New_List;
+ 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;
- -- Collect the full list of directly and indirectly implemented
- -- interfaces
+ if Is_Concurrent_Record_Type (Typ) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
+ end if;
- Set_Parent (Typ_Copy, Parent (Typ));
- Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List);
- Collect_All_Interfaces (Typ_Copy);
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
- -- Calculate the number of entries required in the table of interfaces
+ if Present (Conc_Typ) then
- Num_Ifaces := 0;
- AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
- while Present (AI) loop
- Num_Ifaces := Num_Ifaces + 1;
- Next_Elmt (AI);
- end loop;
+ -- Generate:
+ -- I : Integer := get_entry_index (tag! (<type>VP), S);
- -- Count ancestors to compute the inheritance depth. For private
- -- extensions, always go to the full view in order to compute the real
- -- inheritance depth.
+ -- where I will be used to capture the entry index of the primitive
+ -- wrapper at position S.
- declare
- Parent_Type : Entity_Id := Typ;
- P : Entity_Id;
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition =>
+ New_Reference_To (Standard_Integer, Loc),
+ Expression =>
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Get_Entry_Index,
+ Args =>
+ New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))));
- begin
- I_Depth := 0;
- loop
- P := Etype (Parent_Type);
+ if Ekind (Conc_Typ) = E_Protected_Type then
- if Is_Private_Type (P) then
- P := Full_View (Base_Type (P));
- end if;
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._object'access,
+ -- protected_entry_index! (I),
+ -- P,
+ -- Asynchronous_Call,
+ -- B);
- exit when P = Parent_Type;
+ -- where T is the protected object, I is the entry index, P are
+ -- the wrapped parameters and B is the name of the communication
+ -- block.
- I_Depth := I_Depth + 1;
- Parent_Type := P;
- end loop;
- end;
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
- Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
+ Make_Attribute_Reference (Loc, -- T._object'access
+ Attribute_Name =>
+ Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject))),
- -- 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.
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
- 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;
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Asynchronous_Call
+ RTE (RE_Asynchronous_Call), Loc),
+ Make_Identifier (Loc, Name_uB)))); -- comm block
+ else
+ pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
- -- ----------------------------------------------------------------
- -- Dispatch table and related entities are allocated statically
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._task_id,
+ -- task_entry_index! (I),
+ -- P,
+ -- Conditional_Call,
+ -- F);
- Set_Ekind (DT, E_Variable);
- Set_Is_Statically_Allocated (DT);
+ -- where T is the task object, I is the entry index, P are the
+ -- wrapped parameters and F is the status flag.
- Set_Ekind (DT_Ptr, E_Variable);
- Set_Is_Statically_Allocated (DT_Ptr);
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
- Set_Ekind (TSD, E_Variable);
- Set_Is_Statically_Allocated (TSD);
+ Make_Selected_Component (Loc, -- T._task_id
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id)),
- Set_Ekind (Exname, E_Variable);
- Set_Is_Statically_Allocated (Exname);
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
- Set_Ekind (No_Reg, E_Variable);
- Set_Is_Statically_Allocated (No_Reg);
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Asynchronous_Call
+ RTE (RE_Asynchronous_Call), Loc),
+ Make_Identifier (Loc, Name_uF)))); -- status flag
+ end if;
- -- Generate code to create the storage for the Dispatch_Table object:
+ -- Implementation for limited tagged types
- -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
- -- for DT'Alignment use Address'Alignment
+ else
+ Append_To (Stmts,
+ Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
+ end if;
- 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)));
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Asynchronous_Select_Spec (Typ),
+ Declarations =>
+ Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ end Make_Disp_Asynchronous_Select_Body;
- 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))))));
+ ----------------------------------------
+ -- Make_Disp_Asynchronous_Select_Spec --
+ ----------------------------------------
- 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)));
+ function Make_Disp_Asynchronous_Select_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_Asynchronous_Select);
+ Params : constant List_Id := New_List;
- -- Generate code to create the pointer to the dispatch table
+ begin
+ -- "T" - Object parameter
+ -- "S" - Primitive operation slot
+ -- "P" - Wrapped parameters
+ -- "B" - Communication block
+ -- "F" - Status flag
- -- DT_Ptr : Tag := Tag!(DT'Address);
+ SEU.Build_T (Loc, Typ, Params);
+ SEU.Build_S (Loc, Params);
+ SEU.Build_P (Loc, Params);
+ SEU.Build_B (Loc, Params);
+ SEU.Build_F (Loc, Params);
- -- 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
+ Set_Is_Internal (Def_Id);
- 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)))));
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Def_Id,
+ Parameter_Specifications => Params);
+ end Make_Disp_Asynchronous_Select_Spec;
- -- Generate code to define the boolean that controls registration, in
- -- order to avoid multiple registrations for tagged types defined in
- -- multiple-called scopes.
+ ---------------------------------------
+ -- Make_Disp_Conditional_Select_Body --
+ ---------------------------------------
- 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)));
+ function Make_Disp_Conditional_Select_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ 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;
- -- Set Access_Disp_Table field to be the dispatch table pointer
+ 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 not Present (Access_Disp_Table (Typ)) then
- Set_Access_Disp_Table (Typ, New_Elmt_List);
+ if Is_Concurrent_Record_Type (Typ) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
end if;
- Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ));
+ DT_Ptr := Node (First_Elmt (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
+ if Present (Conc_Typ) then
- 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)));
+ -- Generate:
+ -- I : Integer;
- 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))))));
+ -- where I will be used to capture the entry index of the primitive
+ -- wrapper at position S.
- 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)));
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition =>
+ New_Reference_To (Standard_Integer, Loc)));
+ end if;
- -- Generate code to put the Address of the TSD in the dispatch table
- -- Set_TSD (DT_Ptr, TSD);
+ -- Generate:
+ -- C := get_prim_op_kind (tag! (<type>VP), S);
- 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))));
+ -- if C = POK_Procedure
+ -- or else C = POK_Protected_Procedure
+ -- or else C = POK_Task_Procedure;
+ -- then
+ -- F := True;
+ -- return;
+ -- 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.
+ SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, DT_Ptr, Stmts);
- 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)))));
+ if Present (Conc_Typ) then
+
+ -- Generate:
+ -- Bnn : Communication_Block;
+
+ -- where Bnn is the name of the communication block used in
+ -- the call to Protected_Entry_Call.
+
+ Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Blk_Nam,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Communication_Block), Loc)));
+
+ -- Generate:
+ -- I := get_entry_index (tag! (<type>VP), S);
+
+ -- I is the entry index and S is the dispatch table slot
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uI),
+ Expression =>
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Get_Entry_Index,
+ Args =>
+ New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))));
+
+ if Ekind (Conc_Typ) = E_Protected_Type then
+
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._object'access,
+ -- protected_entry_index! (I),
+ -- P,
+ -- Conditional_Call,
+ -- Bnn);
+
+ -- where T is the protected object, I is the entry index, P are
+ -- the wrapped parameters and Bnn is the name of the communication
+ -- block.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Attribute_Reference (Loc, -- T._object'access
+ Attribute_Name =>
+ Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject))),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Conditional_Call
+ RTE (RE_Conditional_Call), Loc),
+ New_Reference_To ( -- Bnn
+ Blk_Nam, Loc))));
+
+ -- Generate:
+ -- F := not Cancelled (Bnn);
+
+ -- where F is the success flag. The status of Cancelled is negated
+ -- in order to match the behaviour of the version for task types.
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uF),
+ Expression =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Cancelled), Loc),
+ Parameter_Associations =>
+ New_List (
+ New_Reference_To (Blk_Nam, Loc))))));
+ else
+ pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._task_id,
+ -- task_entry_index! (I),
+ -- P,
+ -- Conditional_Call,
+ -- F);
+
+ -- where T is the task object, I is the entry index, P are the
+ -- wrapped parameters and F is the status flag.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Selected_Component (Loc, -- T._task_id
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id)),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Conditional_Call
+ RTE (RE_Conditional_Call), Loc),
+ Make_Identifier (Loc, Name_uF)))); -- status flag
+ end if;
+
+ -- Implementation for limited tagged types
+
+ else
+ Append_To (Stmts,
+ Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
+ end if;
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Conditional_Select_Spec (Typ),
+ Declarations =>
+ Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ end Make_Disp_Conditional_Select_Body;
+
+ ---------------------------------------
+ -- Make_Disp_Conditional_Select_Spec --
+ ---------------------------------------
+
+ function Make_Disp_Conditional_Select_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_Conditional_Select);
+ Params : constant List_Id := New_List;
+
+ begin
+ -- "T" - Object parameter
+ -- "S" - Primitive operation slot
+ -- "P" - Wrapped parameters
+ -- "C" - Call kind
+ -- "F" - Status flag
+
+ SEU.Build_T (Loc, Typ, Params);
+ SEU.Build_S (Loc, Params);
+ SEU.Build_P (Loc, Params);
+ SEU.Build_C (Loc, Params);
+ SEU.Build_F (Loc, Params);
+
+ Set_Is_Internal (Def_Id);
+
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Def_Id,
+ Parameter_Specifications => Params);
+ end Make_Disp_Conditional_Select_Spec;
+
+ -------------------------------------
+ -- Make_Disp_Get_Prim_Op_Kind_Body --
+ -------------------------------------
+
+ 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;
+
+ begin
+ 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 (Typ)));
+
+ -- Generate:
+ -- C := get_prim_op_kind (tag! (<type>VP), S);
+
+ -- where C is the out parameter capturing the call kind and S is the
+ -- dispatch table slot number.
+
+ 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_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uC),
+ Expression =>
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Get_Prim_Op_Kind,
+ Args =>
+ New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))))));
+ end Make_Disp_Get_Prim_Op_Kind_Body;
+
+ -------------------------------------
+ -- Make_Disp_Get_Prim_Op_Kind_Spec --
+ -------------------------------------
+
+ function Make_Disp_Get_Prim_Op_Kind_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_Prim_Op_Kind);
+ Params : constant List_Id := New_List;
+
+ begin
+ -- "T" - Object parameter
+ -- "S" - Primitive operation slot
+ -- "C" - Call kind
+
+ SEU.Build_T (Loc, Typ, Params);
+ SEU.Build_S (Loc, Params);
+ SEU.Build_C (Loc, Params);
+
+ Set_Is_Internal (Def_Id);
+
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Def_Id,
+ Parameter_Specifications => Params);
+ end Make_Disp_Get_Prim_Op_Kind_Spec;
+
+ --------------------------------
+ -- Make_Disp_Get_Task_Id_Body --
+ --------------------------------
+
+ function Make_Disp_Get_Task_Id_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Ret : Node_Id;
+
+ begin
+ 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)));
+
+ -- A null body is constructed for non-task types
+
+ else
+ Ret :=
+ Make_Return_Statement (Loc,
+ Expression =>
+ New_Reference_To (RTE (RO_ST_Null_Task), Loc));
+ end if;
+
+ 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;
+
+ --------------------------------
+ -- Make_Disp_Get_Task_Id_Spec --
+ --------------------------------
+
+ 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);
+
+ begin
+ Set_Is_Internal (Def_Id);
+
+ 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 --
+ ---------------------------------
+
+ 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;
+ 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;
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+
+ if Present (Conc_Typ) then
+
+ -- Generate:
+ -- I : Integer;
+
+ -- where I will be used to capture the entry index of the primitive
+ -- wrapper at position S.
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition =>
+ New_Reference_To (Standard_Integer, Loc)));
+ end if;
+
+ -- Generate:
+ -- C := get_prim_op_kind (tag! (<type>VP), S);
- -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
+ -- if C = POK_Procedure
+ -- or else C = POK_Protected_Procedure
+ -- or else C = POK_Task_Procedure;
+ -- then
+ -- F := True;
+ -- return;
+ -- end if;
- 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))));
+ SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, DT_Ptr, Stmts);
- -- Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>);
+ if Present (Conc_Typ) then
- 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:
+ -- I := get_entry_index (tag! (<type>VP), S);
- -- Generate:
- -- Set_Offset_To_Top (DT_Ptr, 0);
+ -- I is the entry index and S is the dispatch table slot
- 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))));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uI),
+ Expression =>
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Get_Entry_Index,
+ Args =>
+ New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))));
- 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));
+ if Ekind (Conc_Typ) = E_Protected_Type then
- 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;
+ -- Generate:
+ -- Timed_Protected_Entry_Call (
+ -- T._object'access,
+ -- protected_entry_index! (I),
+ -- P,
+ -- D,
+ -- M,
+ -- F);
- 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);
+ -- where T is the protected object, I is the entry index, P are
+ -- the wrapped parameters, D is the delay amount, M is the delay
+ -- mode and F is the status flag.
- 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)))))));
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
- -- Inherit the secondary dispatch tables of the ancestor
+ Make_Attribute_Reference (Loc, -- T._object'access
+ Attribute_Name =>
+ Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject))),
- 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)));
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
- 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.
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ Make_Identifier (Loc, Name_uD), -- delay
+ Make_Identifier (Loc, Name_uM), -- delay mode
+ Make_Identifier (Loc, Name_uF)))); -- status flag
- ------------------------
- -- Copy_Secondary_DTs --
- ------------------------
+ else
+ pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
- procedure Copy_Secondary_DTs (Typ : Entity_Id) is
- E : Entity_Id;
+ -- Generate:
+ -- Timed_Task_Entry_Call (
+ -- T._task_id,
+ -- task_entry_index! (I),
+ -- P,
+ -- D,
+ -- M,
+ -- F);
- begin
- if Etype (Typ) /= Typ then
- Copy_Secondary_DTs (Etype (Typ));
- end if;
+ -- where T is the task object, I is the entry index, P are the
+ -- wrapped parameters, D is the delay amount, M is the delay
+ -- mode and F is the status flag.
- 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)))));
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
- Next_Elmt (Sec_DT_Ancestor);
- Next_Elmt (Sec_DT_Typ);
- end if;
+ Make_Selected_Component (Loc, -- T._task_id
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id)),
- Next_Entity (E);
- end loop;
- end if;
- end Copy_Secondary_DTs;
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
- begin
- if Present (Node (Sec_DT_Ancestor)) then
- Copy_Secondary_DTs (Typ);
- end if;
- end;
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ Make_Identifier (Loc, Name_uD), -- delay
+ Make_Identifier (Loc, Name_uM), -- delay mode
+ Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
- end if;
- -- Generate:
- -- Inherit_TSD (parent'tag, DT_Ptr);
+ -- Implementation for limited tagged types
- 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))));
+ else
+ Append_To (Stmts,
+ Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
+ end if;
- -- For types with no controlled components, generate:
- -- Set_RC_Offset (DT_Ptr, 0);
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Timed_Select_Spec (Typ),
+ Declarations =>
+ Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ end Make_Disp_Timed_Select_Body;
- -- For simple types with controlled components, generate:
- -- Set_RC_Offset (DT_Ptr, type._record_controller'position);
+ ---------------------------------
+ -- Make_Disp_Timed_Select_Spec --
+ ---------------------------------
- -- 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
+ function Make_Disp_Timed_Select_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_Timed_Select);
+ Params : constant List_Id := New_List;
- -- 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.
+ begin
+ -- "T" - Object parameter
+ -- "S" - Primitive operation slot
+ -- "P" - Wrapped parameters
+ -- "D" - Delay
+ -- "M" - Delay Mode
+ -- "C" - Call kind
+ -- "F" - Status flag
- declare
- Position : Node_Id;
+ SEU.Build_T (Loc, Typ, Params);
+ SEU.Build_S (Loc, Params);
+ SEU.Build_P (Loc, Params);
- begin
- if not Has_Controlled_Component (Typ) then
- Position := Make_Integer_Literal (Loc, 0);
+ Append_To (Params,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uD),
+ Parameter_Type =>
+ New_Reference_To (Standard_Duration, Loc)));
- 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 (Params,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uM),
+ Parameter_Type =>
+ New_Reference_To (Standard_Integer, Loc)));
- 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;
+ SEU.Build_C (Loc, Params);
+ SEU.Build_F (Loc, Params);
- -- Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is
- -- described in E.4 (18)
+ Set_Is_Internal (Def_Id);
- declare
- Status : Entity_Id;
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Def_Id,
+ Parameter_Specifications => Params);
+ end Make_Disp_Timed_Select_Spec;
- 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));
+ -------------
+ -- Make_DT --
+ -------------
- 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;
+ 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;
- -- Generate: Set_External_Tag (DT_Ptr, exname'Address);
- -- Should be the external name not the qualified name???
+ 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');
- 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))));
+ 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);
- -- Generate code to register the Tag in the External_Tag hash
- -- table for the pure Ada type only.
+ 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;
- -- Register_Tag (Dt_Ptr);
+ begin
+ if not RTE_Available (RE_Tag) then
+ Error_Msg_CRT ("tagged types", Typ);
+ return New_List;
+ end if;
- -- Skip this if routine not available, or in No_Run_Time mode
+ -- Collect full list of directly and indirectly implemented interfaces
- 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;
+ Set_Parent (Typ_Copy, Parent (Typ));
+ Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List);
+ Collect_All_Interfaces (Typ_Copy);
- -- Generate:
- -- if No_Reg then
- -- <elab_code>
- -- No_Reg := False;
- -- end if;
+ -- Calculate the size of the DT and the TSD
- Append_To (Elab_Code,
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (No_Reg, Loc),
- Expression => New_Reference_To (Standard_False, Loc)));
+ 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.
- Append_To (Result,
- Make_Implicit_If_Statement (Typ,
- Condition => New_Reference_To (No_Reg, Loc),
- Then_Statements => Elab_Code));
+ Nb_Prim := 1;
+ TSD_Num_Entries := 0;
- -- Ada 2005 (AI-251): Register the tag of the interfaces into
- -- the table of implemented interfaces
+ else
+ -- Calculate the number of entries for the table of interfaces
- if Present (Abstract_Interfaces (Typ_Copy))
- and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ_Copy))
- then
+ Num_Ifaces := 0;
AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
while Present (AI) loop
+ Num_Ifaces := Num_Ifaces + 1;
+ Next_Elmt (AI);
+ end loop;
- -- Generate:
- -- Register_Interface (DT_Ptr, Interface'Tag);
+ -- Count ancestors to compute the inheritance depth. For private
+ -- extensions, always go to the full view in order to compute the
+ -- real inheritance depth.
- 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))));
+ declare
+ Parent_Type : Entity_Id := Typ;
+ P : Entity_Id;
- Next_Elmt (AI);
- end loop;
- end if;
+ begin
+ I_Depth := 0;
+ loop
+ P := Etype (Parent_Type);
- return Result;
- end Make_DT;
+ if Is_Private_Type (P) then
+ P := Full_View (Base_Type (P));
+ end if;
- --------------------------------
- -- Make_Abstract_Interface_DT --
- --------------------------------
+ exit when P = Parent_Type;
- 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');
+ I_Depth := I_Depth + 1;
+ Parent_Type := P;
+ end loop;
+ end;
- Iface_DT : constant Node_Id :=
- Make_Defining_Identifier (Loc, Name_DT);
- Iface_DT_Ptr : constant Node_Id :=
- Make_Defining_Identifier (Loc, Name_DT_Ptr);
+ TSD_Num_Entries := I_Depth + Num_Ifaces + 1;
+ Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
- Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
- Size_Expr_Node : Node_Id;
- Nb_Prim : Int;
+ -- 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.
- begin
- Result := New_List;
+ 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 (Iface_DT, E_Variable);
- Set_Is_Statically_Allocated (Iface_DT);
+ Set_Ekind (DT, E_Variable);
+ Set_Is_Statically_Allocated (DT);
- Set_Ekind (Iface_DT_Ptr, E_Variable);
- Set_Is_Statically_Allocated (Iface_DT_Ptr);
+ Set_Ekind (DT_Ptr, E_Variable);
+ Set_Is_Statically_Allocated (DT_Ptr);
- -- Generate code to create the storage for the Dispatch_Table object
+ Set_Ekind (SSD, E_Variable);
+ Set_Is_Statically_Allocated (SSD);
- -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
- -- for DT'Alignment use Address'Alignment
+ Set_Ekind (TSD, E_Variable);
+ Set_Is_Statically_Allocated (TSD);
- Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
+ 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 (Etype (AI_Tag),
- DT_Prologue_Size,
- No_List),
+ Left_Opnd => Make_DT_Access_Action (Typ, 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),
+ 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 => Iface_DT,
+ Defining_Identifier => DT,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), 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))))));
+ High_Bound => Size_Expr_Node))))));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
- Name => New_Reference_To (Iface_DT, 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
- -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
+ -- 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.
+ -- 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 => Iface_DT_Ptr,
+ Defining_Identifier => DT_Ptr,
Constant_Present => True,
Object_Definition => New_Reference_To (Generalized_Tag, Loc),
Expression =>
Left_Opnd =>
Unchecked_Convert_To (RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Iface_DT, Loc),
+ Prefix => New_Reference_To (DT, Loc),
Attribute_Name => Name_Address)),
Right_Opnd =>
- Make_DT_Access_Action (Etype (AI_Tag),
+ Make_DT_Access_Action (Typ,
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;
+ -- Generate code to define the boolean that controls registration, in
+ -- order to avoid multiple registrations for tagged types defined in
+ -- multiple-called scopes.
- ----------------------------------------
- -- Make_Disp_Asynchronous_Select_Body --
- ----------------------------------------
+ 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)));
- 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;
+ -- Set Access_Disp_Table field to be the dispatch table pointer
- begin
- if Is_Concurrent_Record_Type (Typ) then
- Conc_Typ := Corresponding_Concurrent_Type (Typ);
+ if not Present (Access_Disp_Table (Typ)) then
+ Set_Access_Disp_Table (Typ, New_Elmt_List);
end if;
- -- Typ may be a derived type, climb the derivation chain in order to
- -- find the root.
+ Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ));
- DT_Ptr_Typ := Typ;
- while Present (Parent_Subtype (DT_Ptr_Typ)) loop
- DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
- end loop;
+ -- 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).
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+ -- TSD: Storage_Array
+ -- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size);
+ -- for TSD'Alignment use Address'Alignment
- if Present (Conc_Typ) then
+ 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)));
- -- Generate:
- -- I : Integer := get_entry_index (tag! (<type>VP), S);
+ 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))))));
- -- where I will be used to capture the entry index of the primitive
- -- wrapper at position S.
+ 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)));
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uI),
- Object_Definition =>
- New_Reference_To (Standard_Integer, Loc),
- Expression =>
- Make_DT_Access_Action (Typ,
- Action =>
- Get_Entry_Index,
- Args =>
- New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
- Make_Identifier (Loc, Name_uS)))));
+ -- Generate code to put the Address of the TSD in the dispatch table
+ -- Set_TSD (DT_Ptr, TSD);
- if Ekind (Conc_Typ) = E_Protected_Type then
+ 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:
- -- Protected_Entry_Call (
- -- T._object'access,
- -- protected_entry_index! (I),
- -- P,
- -- Asynchronous_Call,
- -- B);
+ -- Generate:
+ -- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
- -- where T is the protected object, I is the entry index, P are
- -- the wrapped parameters and B is the name of the communication
- -- block.
+ 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;
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ 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.
- Make_Attribute_Reference (Loc, -- T._object'access
- Attribute_Name =>
- Name_Unchecked_Access,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uObject))),
+ 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))))));
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ -- Set the pointer to the Select Specific Data table in the TSD
- Make_Identifier (Loc, Name_uP), -- parameter block
- New_Reference_To ( -- Asynchronous_Call
- RTE (RE_Asynchronous_Call), Loc),
- Make_Identifier (Loc, Name_uB)))); -- comm block
- else
- pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+ 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:
- -- Protected_Entry_Call (
- -- T._task_id,
- -- task_entry_index! (I),
- -- P,
- -- Conditional_Call,
- -- F);
+ -- 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.
- -- where T is the task object, I is the entry index, P are the
- -- wrapped parameters and F is the status flag.
+ 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)))));
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
- Make_Selected_Component (Loc, -- T._task_id
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTask_Id)),
+ 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))));
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ if not Is_Interface (Typ) then
+ -- Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>);
- Make_Identifier (Loc, Name_uP), -- parameter block
- New_Reference_To ( -- Asynchronous_Call
- RTE (RE_Asynchronous_Call), Loc),
- Make_Identifier (Loc, Name_uF)))); -- status flag
- end if;
+ 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;
- -- Null implementation for limited tagged types
+ 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
- Append_To (Stmts,
- Make_Null_Statement (Loc));
+ 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;
- return
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Asynchronous_Select_Spec (Typ),
- Declarations =>
- Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Stmts));
- end Make_Disp_Asynchronous_Select_Body;
+ if Typ /= Etype (Typ)
+ and then not Is_Interface (Typ)
+ then
+ -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
- ----------------------------------------
- -- Make_Disp_Asynchronous_Select_Spec --
- ----------------------------------------
+ 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;
- function Make_Disp_Asynchronous_Select_Spec
- (Typ : Entity_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (Typ);
- Params : constant List_Id := New_List;
+ -- Inherit the secondary dispatch tables of the ancestor
- begin
- -- "T" - Object parameter
- -- "S" - Primitive operation slot
- -- "P" - Wrapped parameters
- -- "B" - Communication block
- -- "F" - Status flag
+ 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 --
+ ------------------------
- SEU.Build_T (Loc, Typ, Params);
- SEU.Build_S (Loc, Params);
- SEU.Build_P (Loc, Params);
- SEU.Build_B (Loc, Params);
- SEU.Build_F (Loc, Params);
+ procedure Copy_Secondary_DTs (Typ : Entity_Id) is
+ E : Entity_Id;
+ Iface : Elmt_Id;
- return
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Name_uDisp_Asynchronous_Select),
- Parameter_Specifications =>
- Params);
- end Make_Disp_Asynchronous_Select_Spec;
+ begin
+ -- Climb to the ancestor (if any) handling private types
- ---------------------------------------
- -- Make_Disp_Conditional_Select_Body --
- ---------------------------------------
+ if Present (Full_View (Etype (Typ))) then
+ if Full_View (Etype (Typ)) /= Typ then
+ Copy_Secondary_DTs (Full_View (Etype (Typ)));
+ end if;
- 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;
+ elsif Etype (Typ) /= Typ then
+ Copy_Secondary_DTs (Etype (Typ));
+ end if;
- begin
- if Is_Concurrent_Record_Type (Typ) then
- Conc_Typ := Corresponding_Concurrent_Type (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);
- -- Typ may be a derived type, climb the derivation chain in order to
- -- find the root.
+ 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;
- DT_Ptr_Typ := Typ;
- while Present (Parent_Subtype (DT_Ptr_Typ)) loop
- DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
- end loop;
+ Next_Elmt (Sec_DT_Ancestor);
+ Next_Elmt (Sec_DT_Typ);
+ Next_Elmt (Iface);
+ end if;
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+ Next_Entity (E);
+ end loop;
+ end if;
+ end Copy_Secondary_DTs;
- if Present (Conc_Typ) then
- -- Generate:
- -- I : Integer;
+ begin
+ if Present (Node (Sec_DT_Ancestor)) then
- -- where I will be used to capture the entry index of the primitive
- -- wrapper at position S.
+ -- Handle private types
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uI),
- Object_Definition =>
- New_Reference_To (Standard_Integer, Loc)));
+ 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:
- -- C := get_prim_op_kind (tag! (<type>VP), S);
-
- -- if C = POK_Procedure
- -- or else C = POK_Protected_Procedure
- -- or else C = POK_Task_Procedure;
- -- then
- -- F := True;
- -- return;
- -- end if;
-
- SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts);
+ -- Inherit_TSD (parent'tag, DT_Ptr);
- if Present (Conc_Typ) then
+ 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))));
- -- Generate:
- -- Bnn : Communication_Block;
+ -- For types with no controlled components, generate:
+ -- Set_RC_Offset (DT_Ptr, 0);
- -- where Bnn is the name of the communication block used in
- -- the call to Protected_Entry_Call.
+ -- For simple types with controlled components, generate:
+ -- Set_RC_Offset (DT_Ptr, type._record_controller'position);
- Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
+ -- 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
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Blk_Nam,
- Object_Definition =>
- New_Reference_To (RTE (RE_Communication_Block), Loc)));
+ -- 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.
- -- Generate:
- -- I := get_entry_index (tag! (<type>VP), S);
+ if not Is_Interface (Typ) then
+ declare
+ Position : Node_Id;
- -- where I is the entry index and S is the dispatch table slot.
+ begin
+ if not Has_Controlled_Component (Typ) then
+ Position := Make_Integer_Literal (Loc, 0);
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Identifier (Loc, Name_uI),
- Expression =>
- Make_DT_Access_Action (Typ,
- Action =>
- Get_Entry_Index,
- Args =>
- New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
- Make_Identifier (Loc, Name_uS)))));
+ 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;
- if Ekind (Conc_Typ) = E_Protected_Type then
+ 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:
- -- Protected_Entry_Call (
- -- T._object'access,
- -- protected_entry_index! (I),
- -- P,
- -- Conditional_Call,
- -- Bnn);
+ -- Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is
+ -- described in E.4 (18)
- -- where T is the protected object, I is the entry index, P are
- -- the wrapped parameters and Bnn is the name of the communication
- -- block.
+ declare
+ Status : Entity_Id;
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ 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));
- Make_Attribute_Reference (Loc, -- T._object'access
- Attribute_Name =>
- Name_Unchecked_Access,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uObject))),
+ 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;
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ -- Generate:
+ -- Set_Offset_To_Top (DT_Ptr, 0);
- Make_Identifier (Loc, Name_uP), -- parameter block
- New_Reference_To ( -- Conditional_Call
- RTE (RE_Conditional_Call), Loc),
- New_Reference_To ( -- Bnn
- Blk_Nam, Loc))));
+ 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:
- -- F := not Cancelled (Bnn);
+ -- Generate: Set_External_Tag (DT_Ptr, exname'Address);
+ -- Should be the external name not the qualified name???
- -- where F is the success flag. The status of Cancelled is negated
- -- in order to match the behaviour of the version for task types.
+ 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))));
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Identifier (Loc, Name_uF),
- Expression =>
- Make_Op_Not (Loc,
- Right_Opnd =>
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Cancelled), Loc),
- Parameter_Associations =>
- New_List (
- New_Reference_To (Blk_Nam, Loc))))));
- else
- pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+ -- Generate code to register the Tag in the External_Tag hash
+ -- table for the pure Ada type only.
- -- Generate:
- -- Protected_Entry_Call (
- -- T._task_id,
- -- task_entry_index! (I),
- -- P,
- -- Conditional_Call,
- -- F);
+ -- Register_Tag (Dt_Ptr);
- -- where T is the task object, I is the entry index, P are the
- -- wrapped parameters and F is the status flag.
+ -- 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)
- Append_To (Stmts,
+ 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_Task_Entry_Call), Loc),
+ Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
Parameter_Associations =>
- New_List (
+ New_List (New_Reference_To (DT_Ptr, Loc))));
+ end if;
+ end if;
- Make_Selected_Component (Loc, -- T._task_id
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTask_Id)),
+ -- Generate:
+ -- if No_Reg then
+ -- <elab_code>
+ -- No_Reg := False;
+ -- end if;
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ 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 ...
- Make_Identifier (Loc, Name_uP), -- parameter block
- New_Reference_To ( -- Conditional_Call
- RTE (RE_Conditional_Call), Loc),
- Make_Identifier (Loc, Name_uF)))); -- status flag
- end if;
+ 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
- -- Null implementation for limited tagged types
+ -- Generate:
+ -- Register_Interface (DT_Ptr, Interface'Tag);
- else
- Append_To (Stmts,
- Make_Null_Statement (Loc));
+ 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
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Conditional_Select_Spec (Typ),
- Declarations =>
- Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Stmts));
- end Make_Disp_Conditional_Select_Body;
+ return Result;
+ end Make_DT;
- ---------------------------------------
- -- Make_Disp_Conditional_Select_Spec --
- ---------------------------------------
+ ---------------------------
+ -- Make_DT_Access_Action --
+ ---------------------------
- function Make_Disp_Conditional_Select_Spec
- (Typ : Entity_Id) return Node_Id
+ function Make_DT_Access_Action
+ (Typ : Entity_Id;
+ Action : DT_Access_Action;
+ Args : List_Id) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (Typ);
- Params : constant List_Id := New_List;
+ Action_Name : constant Entity_Id := RTE (Ada_Actions (Action));
+ Loc : Source_Ptr;
begin
- -- "T" - Object parameter
- -- "S" - Primitive operation slot
- -- "P" - Wrapped parameters
- -- "C" - Call kind
- -- "F" - Status flag
+ if No (Args) then
- SEU.Build_T (Loc, Typ, Params);
- SEU.Build_S (Loc, Params);
- SEU.Build_P (Loc, Params);
- SEU.Build_C (Loc, Params);
- SEU.Build_F (Loc, Params);
+ -- This is a constant
- return
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Name_uDisp_Conditional_Select),
- Parameter_Specifications =>
- Params);
- end Make_Disp_Conditional_Select_Spec;
+ return New_Reference_To (Action_Name, Sloc (Typ));
+ end if;
- -------------------------------------
- -- Make_Disp_Get_Prim_Op_Kind_Body --
- -------------------------------------
+ pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));
- 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 := Sloc (First (Args));
- begin
- -- Typ may be a derived type, climb the derivation chain in order to
- -- find the root.
+ if Action_Is_Proc (Action) then
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (Action_Name, Loc),
+ Parameter_Associations => Args);
- DT_Ptr_Typ := Typ;
- while Present (Parent_Subtype (DT_Ptr_Typ)) loop
- DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
- end loop;
+ else
+ return
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Action_Name, Loc),
+ Parameter_Associations => Args);
+ end if;
+ end Make_DT_Access_Action;
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+ -----------------------
+ -- Make_Secondary_DT --
+ -----------------------
- -- Generate:
- -- C := get_prim_op_kind (tag! (<type>VP), S);
+ 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;
- -- where C is the out parameter capturing the call kind and S is the
- -- dispatch table slot number.
+ begin
+ Result := New_List;
- return
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
- Declarations =>
- No_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- New_List (
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Identifier (Loc, Name_uC),
- Expression =>
- Make_DT_Access_Action (Typ,
- Action =>
- Get_Prim_Op_Kind,
- Args =>
- New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
- Make_Identifier (Loc, Name_uS)))))));
- end Make_Disp_Get_Prim_Op_Kind_Body;
+ -- 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.
- -------------------------------------
- -- Make_Disp_Get_Prim_Op_Kind_Spec --
- -------------------------------------
+ Get_Secondary_DT_External_Name (Typ, Ancestor_Typ, Suffix_Index);
- function Make_Disp_Get_Prim_Op_Kind_Spec
- (Typ : Entity_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (Typ);
- Params : constant List_Id := New_List;
+ 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);
- begin
- -- "T" - Object parameter
- -- "S" - Primitive operation slot
- -- "C" - Call kind
+ -- Dispatch table and related entities are allocated statically
- SEU.Build_T (Loc, Typ, Params);
- SEU.Build_S (Loc, Params);
- SEU.Build_C (Loc, Params);
+ Set_Ekind (Iface_DT, E_Variable);
+ Set_Is_Statically_Allocated (Iface_DT);
- return
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind),
- Parameter_Specifications =>
- Params);
- end Make_Disp_Get_Prim_Op_Kind_Spec;
+ Set_Ekind (Iface_DT_Ptr, E_Variable);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr);
- -----------------------------
- -- Make_Disp_Select_Tables --
- -----------------------------
+ -- 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.
- function Make_Disp_Select_Tables
- (Typ : Entity_Id) return List_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;
+ Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
- begin
- pragma Assert (Present (Primitive_Operations (Typ)));
+ if Nb_Prim < Default_Prim_Op_Count then
+ Nb_Prim := Default_Prim_Op_Count;
+ end if;
- -- Typ may be a derived type, climb the derivation chain in order to
- -- find the root.
+ -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
+ -- for DT'Alignment use Address'Alignment
- DT_Ptr_Typ := Typ;
- while Present (Parent_Subtype (DT_Ptr_Typ)) loop
- DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
- end loop;
+ 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)));
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+ 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))))));
- Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ 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)));
- -- Retrieve the root of the alias chain
+ -- 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).
- 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;
+ 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))));
- -- We either have a procedure or a wrapper. Set the primitive
- -- operation kind for both cases and set the entry index for
- -- wrappers.
+ -- Generate code to create the pointer to the dispatch table
- if Ekind (Prim) = E_Procedure
- and then Present (Prim_Als)
- and then Is_Primitive_Wrapper (Prim_Als)
- then
- Prim_Pos := DT_Position (Prim);
+ -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
- -- Generate:
- -- set_prim_op_kind (<tag>, <position>, <kind>);
+ -- 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 (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))));
+ 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)))));
- -- The wrapped entity of the alias is an entry
+ -- Note: Offset_To_Top will be initialized by the init subprogram
- if Ekind (Wrapped_Entity (Prim_Als)) = E_Entry then
- -- Generate:
- -- set_entry_index (<tag>, <position>, <index>);
+ -- Set Access_Disp_Table field to be the dispatch table pointer
- 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))));
+ if not (Present (Acc_Disp_Tables)) then
+ Acc_Disp_Tables := New_Elmt_List;
+ end if;
- Index := Index + 1;
- end if;
- end if;
+ Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables);
- Next_Elmt (Prim_Elmt);
- end loop;
+ -- Step 1: Generate an Object Specific Data (OSD) table
- return Assignments;
- end Make_Disp_Select_Tables;
+ 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.
- ---------------------------------
- -- Make_Disp_Timed_Select_Body --
- ---------------------------------
+ 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))))));
- 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;
+ -- Generate:
+ -- Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD);
- begin
- if Is_Concurrent_Record_Type (Typ) then
- Conc_Typ := Corresponding_Concurrent_Type (Typ);
- end if;
+ 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))));
- -- Typ may be a derived type, climb the derivation chain in order to
- -- find the root.
+ -- Offset table creation
- DT_Ptr_Typ := Typ;
- while Present (Parent_Subtype (DT_Ptr_Typ)) loop
- DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
- end loop;
+ 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;
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+ begin
+ -- Step 2: Populate the OSD table
- if Present (Conc_Typ) then
+ Prim_Alias := Empty;
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
- -- Generate:
- -- I : Integer;
+ if Present (Abstract_Interface_Alias (Prim)) then
+ Prim_Alias := Abstract_Interface_Alias (Prim);
+ end if;
- -- where I will be used to capture the entry index of the primitive
- -- wrapper at position S.
+ 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;
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uI),
- Object_Definition =>
- New_Reference_To (Standard_Integer, Loc)));
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end;
end if;
-- Generate:
- -- C := get_prim_op_kind (tag! (<type>VP), S);
+ -- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
- -- if C = POK_Procedure
- -- or else C = POK_Protected_Procedure
- -- or else C = POK_Task_Procedure;
- -- then
- -- F := True;
- -- return;
- -- end if;
+ 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))));
- SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts);
+ end Make_Secondary_DT;
- if Present (Conc_Typ) then
+ -------------------------------------
+ -- Make_Select_Specific_Data_Table --
+ -------------------------------------
- -- Generate:
- -- I := get_entry_index (tag! (<type>VP), S);
+ 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);
- -- where I is the entry index and S is the dispatch table slot.
+ 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;
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Identifier (Loc, Name_uI),
- Expression =>
- Make_DT_Access_Action (Typ,
- Action =>
- Get_Entry_Index,
- Args =>
- New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
- Make_Identifier (Loc, Name_uS)))));
+ type Examined_Array is array (Int range <>) of Boolean;
- if Ekind (Conc_Typ) = E_Protected_Type then
+ 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.
- -- Generate:
- -- Timed_Protected_Entry_Call (
- -- T._object'access,
- -- protected_entry_index! (I),
- -- P,
- -- D,
- -- M,
- -- F);
+ ----------------------
+ -- Find_Entry_Index --
+ ----------------------
- -- where T is the protected object, I is the entry index, P are
- -- the wrapped parameters, D is the delay amount, M is the delay
- -- mode and F is the status flag.
+ function Find_Entry_Index (E : Entity_Id) return Uint is
+ Index : Uint := Uint_1;
+ Subp_Decl : Entity_Id;
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ 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;
- Make_Attribute_Reference (Loc, -- T._object'access
- Attribute_Name =>
- Name_Unchecked_Access,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uObject))),
+ Index := Index + 1;
+ end if;
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ Next (Subp_Decl);
+ end loop;
+ end if;
- Make_Identifier (Loc, Name_uP), -- parameter block
- Make_Identifier (Loc, Name_uD), -- delay
- Make_Identifier (Loc, Name_uM), -- delay mode
- Make_Identifier (Loc, Name_uF)))); -- status flag
+ 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;
- -- Generate:
- -- Timed_Task_Entry_Call (
- -- T._task_id,
- -- task_entry_index! (I),
- -- P,
- -- D,
- -- M,
- -- F);
+ -- Count the non-predefined primitive operations
- -- where T is the task object, I is the entry index, P are the
- -- wrapped parameters, D is the delay amount, M is the delay
- -- mode and F is the status flag.
+ 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;
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ Next_Elmt (Prim_Elmt);
+ end loop;
- Make_Selected_Component (Loc, -- T._task_id
- Prefix =>
- Make_Identifier (Loc, Name_uT),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTask_Id)),
+ declare
+ Examined_Size : constant Int := Nb_Prim + Default_Prim_Op_Count;
+ Examined : Examined_Array (1 .. Examined_Size) := (others => False);
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ begin
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+ Prim_Pos := DT_Position (Prim);
- Make_Identifier (Loc, Name_uP), -- parameter block
- Make_Identifier (Loc, Name_uD), -- delay
- Make_Identifier (Loc, Name_uM), -- delay mode
- Make_Identifier (Loc, Name_uF)))); -- status flag
- end if;
+ pragma Assert (UI_To_Int (Prim_Pos) <= Examined_Size);
- -- Null implementation for limited tagged types
+ if Examined (UI_To_Int (Prim_Pos)) then
+ goto Continue;
+ else
+ Examined (UI_To_Int (Prim_Pos)) := True;
+ end if;
- else
- Append_To (Stmts,
- Make_Null_Statement (Loc));
- end if;
+ -- The current primitive overrides an interface-level subprogram
- return
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Timed_Select_Spec (Typ),
- Declarations =>
- Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Stmts));
- end Make_Disp_Timed_Select_Body;
+ if Present (Abstract_Interface_Alias (Prim)) then
- ---------------------------------
- -- Make_Disp_Timed_Select_Spec --
- ---------------------------------
+ -- Set the primitive operation kind regardless of subprogram
+ -- type. Generate:
+ -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
- function Make_Disp_Timed_Select_Spec
- (Typ : Entity_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (Typ);
- Params : constant List_Id := New_List;
+ 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))));
- begin
- -- "T" - Object parameter
- -- "S" - Primitive operation slot
- -- "P" - Wrapped parameters
- -- "D" - Delay
- -- "M" - Delay Mode
- -- "C" - Call kind
- -- "F" - Status flag
+ -- Retrieve the root of the alias chain if one is present
- SEU.Build_T (Loc, Typ, Params);
- SEU.Build_S (Loc, Params);
- SEU.Build_P (Loc, Params);
+ 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;
- Append_To (Params,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uD),
- Parameter_Type =>
- New_Reference_To (Standard_Duration, Loc)));
+ -- In the case of an entry wrapper, set the entry index
- Append_To (Params,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uM),
- Parameter_Type =>
- New_Reference_To (Standard_Integer, Loc)));
+ 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
- SEU.Build_C (Loc, Params);
- SEU.Build_F (Loc, Params);
+ -- Generate:
+ -- Ada.Tags.Set_Entry_Index (DT_Ptr, <position>, <index>);
- return
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Name_uDisp_Timed_Select),
- Parameter_Specifications =>
- Params);
- end Make_Disp_Timed_Select_Spec;
+ 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 --
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
-- 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,
-- --
-- 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- --
-- 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:
-- 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,
Get_Access_Level,
Get_Entry_Index,
Get_External_Tag,
+ Get_Offset_Index,
Get_Prim_Op_Address,
Get_Prim_Op_Kind,
Get_RC_Offset,
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);
-- 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;
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;
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;
(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;
-- 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
-- --
-- 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- --
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.
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
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 --
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
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;
-- Start of processing for Find_Interface_Tag
begin
+ pragma Assert (Is_Interface (Iface));
+
-- Handle private types
if Has_Private_Declaration (Typ)
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 --
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
-
begin
Scope_Suppress := (others => True);
Insert_Actions (Assoc_Node, Ins_Actions);
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
-
begin
Scope_Suppress (Suppress) := True;
Insert_Actions (Assoc_Node, Ins_Actions);
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;
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;
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);
-- --
-- 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- --
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 --
-----------------------------------------------
-- 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
-- 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
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,
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
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
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
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
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
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
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
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
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,
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,
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,
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,
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,
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,
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,
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,
-- --
-- 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- --
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;
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);
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)
begin
Decl := First (Declarations (N));
-
while Present (Decl) loop
Analyze (Decl);
-- 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.
---------------------------------
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));
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;
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;
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);
-- 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);
-- 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;
Set_Referenced (E2, Referenced (E1));
Set_Referenced (E1);
+ Set_Entry_Component (E2, Entry_Component (E1));
<<Continue>>
Next_Entity (E1);
end if;
E := First_Entity (Current_Scope);
-
while Present (E) loop
-
if Ekind (E) = E_Function
or else Ekind (E) = E_Procedure
then
-- 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));
-- 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);
-- 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.
-- 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
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;
begin
Ent := First_Entity (Spec_Id);
-
while Present (Ent) loop
if Is_Entry (Ent)
and then not Entry_Accepted (Ent)
-- 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);
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)))
begin
Ent := First (Ifaces);
-
while Present (Ent) loop
if Etype (Ent) = Iface then
return True;
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
Null_Present (Parent (Hom)))
then
Aliased_Hom := Hom;
-
while Present (Alias (Aliased_Hom)) loop
Aliased_Hom := Alias (Aliased_Hom);
end loop;
else
Decl := First (Vis_Decls);
-
while Present (Decl) loop
if Nkind (Decl) = N_Entry_Declaration
and then Must_Override (Decl)
begin
E := First_Entity (Spec);
-
while Present (E) loop
Prev := Current_Entity (E);
Set_Current_Entity (E);
"_disp_conditional_select#" &
"_disp_get_prim_op_kind#" &
"_disp_timed_select#" &
+ "_disp_get_task_id#" &
"initialize#" &
"adjust#" &
"finalize#" &
"machine_mantissa#" &
"machine_overflows#" &
"machine_radix#" &
+ "machine_rounding#" &
"machine_rounds#" &
"machine_size#" &
"mantissa#" &
"unchecked_conversion#" &
"unchecked_deallocation#" &
"to_pointer#" &
+ "free#" &
"abstract#" &
"aliased#" &
"protected#" &
"include_option#" &
"language_processing#" &
"languages#" &
+ "library_ali_dir#" &
"library_dir#" &
"library_auto_init#" &
"library_gcc#" &
-- 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.
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.
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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;
Attribute_Machine_Mantissa,
Attribute_Machine_Overflows,
Attribute_Machine_Radix,
+ Attribute_Machine_Rounding,
Attribute_Machine_Rounds,
Attribute_Machine_Size,
Attribute_Mantissa,
projects / thirdparty / gcc.git / commitdiff
