Skip to content

R
riscv-gcc-1
Commit f4d379b8 by Hristian Kirtchev Committed by Arnaud Charlet
Options

rtsfind.ads, [...]: Complete support for Ada 2005 interfaces. 

2005-11-14  Hristian Kirtchev  <kirtchev@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* rtsfind.ads, exp_util.adb, exp_util.ads, exp_disp.adb, exp_disp.ads,
	exp_ch7.adb, sem_ch9.adb, snames.adb, snames.ads,
	exp_ch9.adb, exp_ch9.ads, exp_ch6.adb, exp_ch3.adb, exp_ch3.ads,
	einfo.ads, einfo.adb: Complete support for Ada 2005 interfaces.

	* a-tags.ads, a-tags.adb: Major rewrite and additions to implement
	properly new Ada 2005 interfaces (AI-345) and add run-time checks (via
	assertions).

	* exp_dbug.ads, exp_dbug.adb (Get_Secondary_DT_External_Name): New
	subprogram that generates the external name associated with a
	secondary dispatch table.
	(Get_Secondary_DT_External_Name): New subprogram that generates the
	external name associated with a secondary dispatch table.

From-SVN: r106965
parent 748d8778
Showing with 2006 additions and 597 deletions
gcc/ada/a-tags.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -39,43 +39,64 @@ pragma Elaborate_All (System.HTable);
package body Ada.Tags is
-- Structure of the GNAT Dispatch Table
-- Structure of the GNAT Primary Dispatch Table
-- +-----------------------+
-- | Signature |
-- +-----------------------+
-- | Offset_To_Top |
-- +-----------------------+
-- | Typeinfo_Ptr/TSD_Ptr |----> Type Specific Data
-- | Typeinfo_Ptr/TSD_Ptr | ---> Type Specific Data
-- Tag ---> +-----------------------+ +-------------------+
-- | table of | | inheritance depth |
-- : primitive ops : +-------------------+
-- | pointers | | expanded name |
-- | pointers | | access level |
-- +-----------------------+ +-------------------+
-- | external tag |
-- +-------------------+
-- | Hash table link |
-- | expanded name |
-- +-------------------+
-- | Remotely Callable |
-- +-------------------+
-- | Rec Ctrler offset |
-- | external tag |
-- +-------------------+
-- | Num_Interfaces |
-- | hash table link |
-- +-------------------+
-- | table of |
-- : ancestor :
-- | tags |
-- | remotely callable |
-- +-------------------+
-- | table of |
-- : interface :
-- | tags |
-- | rec ctrler offset |
-- +-------------------+
-- | table of |
-- : primitive op :
-- | kinds |
-- | num prim ops |
-- +-------------------+
-- | table of |
-- : entry :
-- | indices |
-- | num interfaces |
-- +-------------------+
-- Select Specific Data <--- | SSD_Ptr |
-- +-----------------------+ +-------------------+
-- | table of primitive | | table of |
-- : operation : : ancestor :
-- | kinds | | tags |
-- +-----------------------+ +-------------------+
-- | table of | | table of |
-- : entry : : interface :
-- | indices | | tags |
-- +-----------------------+ +-------------------+
-- Structure of the GNAT Secondary Dispatch Table
-- +-----------------------+
-- | Signature |
-- +-----------------------+
-- | Offset_To_Top |
-- +-----------------------+
-- | OSD_Ptr |---> Object Specific Data
-- Tag ---> +-----------------------+ +---------------+
-- | table of | | num prim ops |
-- : primitive op : +---------------+
-- | thunk pointers | | table of |
-- +-----------------------+ + primitive |
-- | op offsets |
-- +---------------+
Offset_To_Signature : constant SSE.Storage_Count :=
DT_Typeinfo_Ptr_Size
+ DT_Offset_To_Top_Size
+ DT_Signature_Size;
subtype Cstring is String (Positive);
type Cstring_Ptr is access all Cstring;
......@@ -87,13 +108,39 @@ package body Ada.Tags is
pragma Suppress_Initialization (Tag_Table);
pragma Suppress (Index_Check, On => Tag_Table);
type Prim_Op_Kind_Table is array (Natural range <>) of Prim_Op_Kind;
pragma Suppress_Initialization (Prim_Op_Kind_Table);
pragma Suppress (Index_Check, On => Prim_Op_Kind_Table);
-- Object specific data types
type Object_Specific_Data_Array is array (Positive range <>) of Positive;
type Object_Specific_Data (Nb_Prim : Positive) is record
Num_Prim_Ops : Natural;
-- Number of primitive operations of the dispatch table. This field is
-- used by the run-time check routines that are activated when the
-- run-time is compiled with assertions enabled.
OSD_Table : Object_Specific_Data_Array (1 .. Nb_Prim);
-- Table used in secondary DT to reference their counterpart in the
-- select specific data (in the TSD of the primary DT). This construct
-- is used in the handling of dispatching triggers in select statements.
-- Nb_Prim is the number of non-predefined primitive operations.
end record;
-- Select specific data types
type Select_Specific_Data_Element is record
Index : Positive;
Kind : Prim_Op_Kind;
end record;
type Select_Specific_Data_Array is
array (Positive range <>) of Select_Specific_Data_Element;
type Select_Specific_Data (Nb_Prim : Positive) is record
SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim);
-- NOTE: Nb_Prim is the number of non-predefined primitive operations
end record;
type Entry_Index_Table is array (Natural range <>) of Positive;
pragma Suppress_Initialization (Entry_Index_Table);
pragma Suppress (Index_Check, On => Entry_Index_Table);
-- Type specific data types
type Type_Specific_Data is record
Idepth : Natural;
......@@ -124,11 +171,22 @@ package body Ada.Tags is
-- Controller Offset: Used to give support to tagged controlled objects
-- (see Get_Deep_Controller at s-finimp)
Num_Prim_Ops : Natural;
-- Number of primitive operations of the dispatch table. This field is
-- used for additional run-time checks when the run-time is compiled
-- with assertions enabled.
Num_Interfaces : Natural;
-- Number of abstract interface types implemented by the tagged type.
-- The value Idepth+Num_Interfaces indicates the end of the second table
-- stored in the Tags_Table component. It is used to implement the
-- membership test associated with interfaces (Ada 2005:AI-251)
-- membership test associated with interfaces (Ada 2005:AI-251).
SSD_Ptr : System.Address;
-- Pointer to a table of records used in dispatching selects. This
-- field has a meaningful value for all tagged types that implement
-- a limited, protected, synchronized or task interfaces and have
-- non-predefined primitive operations.
Tags_Table : Tag_Table (0 .. 1);
-- The size of the Tags_Table array actually depends on the tagged type
......@@ -138,21 +196,9 @@ package body Ada.Tags is
-- purpose we are using the same mechanism as for the Prims_Ptr array in
-- the Dispatch_Table record. See comments below on Prims_Ptr for
-- further details.
POK_Table : Prim_Op_Kind_Table (1 .. 1);
Ent_Index_Table : Entry_Index_Table (1 .. 1);
-- Two auxiliary tables used for dispatching in asynchronous,
-- conditional and timed selects. Their size depends on the number
-- of primitive operations. Indexing in these two tables is performed
-- by subtracting the number of predefined primitive operations from
-- the given index value. POK_Table contains the callable entity kinds
-- of all non-predefined primitive operations. Ent_Index_Table contains
-- the entry index of primitive entry wrappers.
end record;
type Dispatch_Table is record
-- Offset_To_Top : Natural;
-- Typeinfo_Ptr : System.Address;
-- According to the C++ ABI the components Offset_To_Top and
-- Typeinfo_Ptr are stored just "before" the dispatch table (that is,
......@@ -164,6 +210,9 @@ package body Ada.Tags is
-- enough space for these additional components, and generates code that
-- displaces the _Tag to point after these components.
-- Offset_To_Top : Natural;
-- Typeinfo_Ptr : System.Address;
Prims_Ptr : Address_Array (1 .. 1);
-- The size of the Prims_Ptr array actually depends on the tagged type
-- to which it applies. For each tagged type, the expander computes the
......@@ -185,6 +234,20 @@ package body Ada.Tags is
-- only to declare the corresponding access type.
end record;
-- Run-time check types and subprograms: These subprograms are used only
-- when the run-time is compiled with assertions enabled.
type Signature_Type is
(Must_Be_Primary_DT,
Must_Be_Secondary_DT,
Must_Be_Primary_Or_Secondary_DT,
Must_Be_Interface,
Must_Be_Primary_Or_Interface);
-- Type of signature accepted by primitives in this package that are called
-- during the elaboration of tagged types. This type is used by the routine
-- Check_Signature that is called only when the run-time is compiled with
-- assertions enabled.
---------------------------------------------
-- Unchecked Conversions for String Fields --
---------------------------------------------
......@@ -199,6 +262,12 @@ package body Ada.Tags is
-- Unchecked Conversions for other components --
------------------------------------------------
type Acc_Size
is access function (A : System.Address) return Long_Long_Integer;
function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
-- The profile of the implicitly defined _size primitive
type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset;
function To_Storage_Offset_Ptr is
......@@ -208,6 +277,30 @@ package body Ada.Tags is
-- Local Subprograms --
-----------------------
function Check_Index
(T : Tag;
Index : Natural) return Boolean;
-- Check that Index references a valid entry of the dispatch table of T
function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean;
-- Check that the signature of T is valid and corresponds with the subset
-- specified by the signature Kind.
function Check_Size
(Old_T : Tag;
New_T : Tag;
Entry_Count : Natural) return Boolean;
-- Verify that Old_T and New_T have at least Entry_Count entries
function Get_Num_Prim_Ops (T : Tag) return Natural;
-- Retrieve the number of primitive operations in the dispatch table of T
function Is_Primary_DT (T : Tag) return Boolean;
pragma Inline_Always (Is_Primary_DT);
-- Given a tag returns True if it has the signature of a primary dispatch
-- table. This is Inline_Always since it is called from other Inline_
-- Always subprograms where we want no out of line code to be generated.
function Length (Str : Cstring_Ptr) return Natural;
-- Length of string represented by the given pointer (treating the string
-- as a C-style string, which is Nul terminated).
......@@ -261,9 +354,9 @@ package body Ada.Tags is
package body HTable_Subprograms is
-----------
-- Equal --
-----------
-----------
-- Equal --
-----------
function Equal (A, B : System.Address) return Boolean is
Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
......@@ -313,6 +406,93 @@ package body Ada.Tags is
end HTable_Subprograms;
-----------------
-- Check_Index --
-----------------
function Check_Index
(T : Tag;
Index : Natural) return Boolean
is
Max_Entries : constant Natural := Get_Num_Prim_Ops (T);
begin
return Index /= 0 and then Index <= Max_Entries;
end Check_Index;
---------------------
-- Check_Signature --
---------------------
function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean is
Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
To_Storage_Offset_Ptr (To_Address (T)
- Offset_To_Signature);
Signature : constant Signature_Values :=
To_Signature_Values (Offset_To_Top_Ptr.all);
Signature_Id : Signature_Kind;
begin
if Signature (1) /= Valid_Signature then
Signature_Id := Unknown;
elsif Signature (2) in Primary_DT .. Abstract_Interface then
Signature_Id := Signature (2);
else
Signature_Id := Unknown;
end if;
case Signature_Id is
when Primary_DT =>
if Kind = Must_Be_Secondary_DT
or else Kind = Must_Be_Interface
then
return False;
end if;
when Secondary_DT =>
if Kind = Must_Be_Primary_DT
or else Kind = Must_Be_Interface
then
return False;
end if;
when Abstract_Interface =>
if Kind = Must_Be_Primary_DT
or else Kind = Must_Be_Secondary_DT
or else Kind = Must_Be_Primary_Or_Secondary_DT
then
return False;
end if;
when others =>
return False;
end case;
return True;
end Check_Signature;
----------------
-- Check_Size --
----------------
function Check_Size
(Old_T : Tag;
New_T : Tag;
Entry_Count : Natural) return Boolean
is
Max_Entries_Old : constant Natural := Get_Num_Prim_Ops (Old_T);
Max_Entries_New : constant Natural := Get_Num_Prim_Ops (New_T);
begin
return Entry_Count <= Max_Entries_Old
and then Entry_Count <= Max_Entries_New;
end Check_Size;
-------------------
-- CW_Membership --
-------------------
......@@ -334,8 +514,11 @@ package body Ada.Tags is
-- = Typ'tag
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
Pos : constant Integer := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
Pos : Integer;
begin
pragma Assert (Check_Signature (Obj_Tag, Must_Be_Primary_DT));
pragma Assert (Check_Signature (Typ_Tag, Must_Be_Primary_DT));
Pos := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag;
end CW_Membership;
......@@ -353,23 +536,34 @@ package body Ada.Tags is
-- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
-- that are contained in the dispatch table referenced by Obj'Tag.
function IW_Membership
(This : System.Address;
T : Tag) return Boolean
is
function IW_Membership (This : System.Address; T : Tag) return Boolean is
Curr_DT : constant Tag := To_Tag_Ptr (This).all;
Obj_Base : constant System.Address := This - Offset_To_Top (Curr_DT);
Obj_DT : constant Tag := To_Tag_Ptr (Obj_Base).all;
Obj_TSD : constant Type_Specific_Data_Ptr := TSD (Obj_DT);
Last_Id : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces;
Id : Natural;
Id : Natural;
Last_Id : Natural;
Obj_Base : System.Address;
Obj_DT : Tag;
Obj_TSD : Type_Specific_Data_Ptr;
begin
pragma Assert
(Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT));
pragma Assert
(Check_Signature (T, Must_Be_Primary_Or_Interface));
Obj_Base := This - Offset_To_Top (Curr_DT);
Obj_DT := To_Tag_Ptr (Obj_Base).all;
pragma Assert
(Check_Signature (Curr_DT, Must_Be_Primary_DT));
Obj_TSD := TSD (Obj_DT);
Last_Id := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces;
if Obj_TSD.Num_Interfaces > 0 then
-- Traverse the ancestor tags table plus the interface tags table.
-- The former part is required to give support to:
-- The former part is required for:
-- Iface_CW in Typ'Class
Id := 0;
......@@ -391,9 +585,13 @@ package body Ada.Tags is
--------------------
function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
Int_Tag : constant Tag := Internal_Tag (External);
Int_Tag : Tag;
begin
pragma Assert (Check_Signature (Ancestor, Must_Be_Primary_DT));
Int_Tag := Internal_Tag (External);
pragma Assert (Check_Signature (Int_Tag, Must_Be_Primary_DT));
if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
raise Tag_Error;
end if;
......@@ -413,6 +611,7 @@ package body Ada.Tags is
raise Tag_Error;
end if;
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
Result := TSD (T).Expanded_Name;
return Result (1 .. Length (Result));
end Expanded_Name;
......@@ -423,11 +622,13 @@ package body Ada.Tags is
function External_Tag (T : Tag) return String is
Result : Cstring_Ptr;
begin
if T = No_Tag then
raise Tag_Error;
end if;
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
Result := TSD (T).External_Tag;
return Result (1 .. Length (Result));
......@@ -439,6 +640,7 @@ package body Ada.Tags is
function Get_Access_Level (T : Tag) return Natural is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
return TSD (T).Access_Level;
end Get_Access_Level;
......@@ -446,11 +648,12 @@ package body Ada.Tags is
-- Get_Entry_Index --
---------------------
function Get_Entry_Index
(T : Tag;
Position : Positive) return Positive is
function Get_Entry_Index (T : Tag; Position : Positive) return Positive is
Index : constant Integer := Position - Default_Prim_Op_Count;
begin
return TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count);
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
pragma Assert (Index > 0);
return SSD (T).SSD_Table (Index).Index;
end Get_Entry_Index;
----------------------
......@@ -459,17 +662,36 @@ package body Ada.Tags is
function Get_External_Tag (T : Tag) return System.Address is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
return To_Address (TSD (T).External_Tag);
end Get_External_Tag;
----------------------
-- Get_Num_Prim_Ops --
----------------------
function Get_Num_Prim_Ops (T : Tag) return Natural is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
if Is_Primary_DT (T) then
return TSD (T).Num_Prim_Ops;
else
return OSD (Interface_Tag (T)).Num_Prim_Ops;
end if;
end Get_Num_Prim_Ops;
-------------------------
-- Get_Prim_Op_Address --
-------------------------
function Get_Prim_Op_Address
(T : Tag;
Position : Positive) return System.Address is
Position : Positive) return System.Address
is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Check_Index (T, Position));
return T.Prims_Ptr (Position);
end Get_Prim_Op_Address;
......@@ -479,17 +701,37 @@ package body Ada.Tags is
function Get_Prim_Op_Kind
(T : Tag;
Position : Positive) return Prim_Op_Kind is
Position : Positive) return Prim_Op_Kind
is
Index : constant Integer := Position - Default_Prim_Op_Count;
begin
return TSD (T).POK_Table (Position - Default_Prim_Op_Count);
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
pragma Assert (Index > 0);
return SSD (T).SSD_Table (Index).Kind;
end Get_Prim_Op_Kind;
----------------------
-- Get_Offset_Index --
----------------------
function Get_Offset_Index
(T : Interface_Tag;
Position : Positive) return Positive
is
Index : constant Integer := Position - Default_Prim_Op_Count;
begin
pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT));
pragma Assert (Index > 0);
return OSD (T).OSD_Table (Index);
end Get_Offset_Index;
-------------------
-- Get_RC_Offset --
-------------------
function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
return TSD (T).RC_Offset;
end Get_RC_Offset;
......@@ -499,6 +741,7 @@ package body Ada.Tags is
function Get_Remotely_Callable (T : Tag) return Boolean is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
return TSD (T).Remotely_Callable;
end Get_Remotely_Callable;
......@@ -506,12 +749,12 @@ package body Ada.Tags is
-- Inherit_DT --
----------------
procedure Inherit_DT
(Old_T : Tag;
New_T : Tag;
Entry_Count : Natural)
is
procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is
begin
pragma Assert (Check_Signature (Old_T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Check_Signature (New_T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Check_Size (Old_T, New_T, Entry_Count));
if Old_T /= null then
New_T.Prims_Ptr (1 .. Entry_Count) :=
Old_T.Prims_Ptr (1 .. Entry_Count);
......@@ -523,17 +766,22 @@ package body Ada.Tags is
-----------------
procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag) is
New_TSD_Ptr : constant Type_Specific_Data_Ptr := TSD (New_Tag);
New_TSD_Ptr : Type_Specific_Data_Ptr;
Old_TSD_Ptr : Type_Specific_Data_Ptr;
begin
pragma Assert (Check_Signature (New_Tag, Must_Be_Primary_Or_Interface));
New_TSD_Ptr := TSD (New_Tag);
if Old_Tag /= null then
pragma Assert
(Check_Signature (Old_Tag, Must_Be_Primary_Or_Interface));
Old_TSD_Ptr := TSD (Old_Tag);
New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
New_TSD_Ptr.Num_Interfaces := Old_TSD_Ptr.Num_Interfaces;
-- Copy the "table of ancestor tags" plus the "table of interfaces"
-- of the parent
-- of the parent.
New_TSD_Ptr.Tags_Table
(1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces) :=
......@@ -557,7 +805,7 @@ package body Ada.Tags is
begin
-- Make a copy of the string representing the external tag with
-- a null at the end
-- a null at the end.
Ext_Copy (External'Range) := External;
Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
......@@ -567,6 +815,7 @@ package body Ada.Tags is
declare
Msg1 : constant String := "unknown tagged type: ";
Msg2 : String (1 .. Msg1'Length + External'Length);
begin
Msg2 (1 .. Msg1'Length) := Msg1;
Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
......@@ -591,6 +840,20 @@ package body Ada.Tags is
and then TSD (Descendant).Access_Level = TSD (Ancestor).Access_Level;
end Is_Descendant_At_Same_Level;
-------------------
-- Is_Primary_DT --
-------------------
function Is_Primary_DT (T : Tag) return Boolean is
Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
To_Storage_Offset_Ptr (To_Address (T)
- Offset_To_Signature);
Signature : constant Signature_Values :=
To_Signature_Values (Offset_To_Top_Ptr.all);
begin
return Signature (2) = Primary_DT;
end Is_Primary_DT;
------------
-- Length --
------------
......@@ -617,32 +880,45 @@ package body Ada.Tags is
To_Storage_Offset_Ptr (To_Address (T)
- DT_Typeinfo_Ptr_Size
- DT_Offset_To_Top_Size);
begin
return Offset_To_Top_Ptr.all;
end Offset_To_Top;
---------
-- OSD --
---------
function OSD
(T : Interface_Tag) return Object_Specific_Data_Ptr
is
OSD_Ptr : Addr_Ptr;
begin
OSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
end OSD;
-----------------
-- Parent_Size --
-----------------
type Acc_Size
is access function (A : System.Address) return Long_Long_Integer;
function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
-- The profile of the implicitly defined _size primitive
function Parent_Size
(Obj : System.Address;
T : Tag) return SSE.Storage_Count
is
Parent_Tag : constant Tag := TSD (T).Tags_Table (1);
Parent_Tag : Tag;
-- The tag of the parent type through the dispatch table
F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
F : Acc_Size;
-- Access to the _size primitive of the parent. We assume that it is
-- always in the first slot of the dispatch table
-- always in the first slot of the dispatch table.
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
Parent_Tag := TSD (T).Tags_Table (1);
F := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
-- Here we compute the size of the _parent field of the object
return SSE.Storage_Count (F.all (Obj));
......@@ -658,6 +934,8 @@ package body Ada.Tags is
raise Tag_Error;
end if;
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
-- The Parent_Tag of a root-level tagged type is defined to be No_Tag.
-- The first entry in the Ancestors_Tags array will be null for such
-- a type, but it's better to be explicit about returning No_Tag in
......@@ -674,20 +952,24 @@ package body Ada.Tags is
-- Register_Interface_Tag --
----------------------------
procedure Register_Interface_Tag
(T : Tag;
Interface_T : Tag)
is
New_T_TSD : constant Type_Specific_Data_Ptr := TSD (T);
procedure Register_Interface_Tag (T : Tag; Interface_T : Tag) is
New_T_TSD : Type_Specific_Data_Ptr;
Index : Natural;
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
pragma Assert (Check_Signature (Interface_T, Must_Be_Interface));
New_T_TSD := TSD (T);
-- Check if the interface is already registered
if New_T_TSD.Num_Interfaces > 0 then
declare
Id : Natural := New_T_TSD.Idepth + 1;
Last_Id : constant Natural := New_T_TSD.Idepth
Id : Natural := New_T_TSD.Idepth + 1;
Last_Id : constant Natural := New_T_TSD.Idepth
+ New_T_TSD.Num_Interfaces;
begin
loop
if New_T_TSD.Tags_Table (Id) = Interface_T then
......@@ -720,6 +1002,7 @@ package body Ada.Tags is
procedure Set_Access_Level (T : Tag; Value : Natural) is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
TSD (T).Access_Level := Value;
end Set_Access_Level;
......@@ -730,9 +1013,14 @@ package body Ada.Tags is
procedure Set_Entry_Index
(T : Tag;
Position : Positive;
Value : Positive) is
Value : Positive)
is
Index : constant Integer := Position - Default_Prim_Op_Count;
begin
TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count) := Value;
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
pragma Assert (Index > 0);
SSD (T).SSD_Table (Index).Index := Value;
end Set_Entry_Index;
-----------------------
......@@ -741,6 +1029,8 @@ package body Ada.Tags is
procedure Set_Expanded_Name (T : Tag; Value : System.Address) is
begin
pragma Assert
(Check_Signature (T, Must_Be_Primary_Or_Interface));
TSD (T).Expanded_Name := To_Cstring_Ptr (Value);
end Set_Expanded_Name;
......@@ -750,9 +1040,41 @@ package body Ada.Tags is
procedure Set_External_Tag (T : Tag; Value : System.Address) is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
TSD (T).External_Tag := To_Cstring_Ptr (Value);
end Set_External_Tag;
----------------------
-- Set_Num_Prim_Ops --
----------------------
procedure Set_Num_Prim_Ops (T : Tag; Value : Natural) is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
if Is_Primary_DT (T) then
TSD (T).Num_Prim_Ops := Value;
else
OSD (Interface_Tag (T)).Num_Prim_Ops := Value;
end if;
end Set_Num_Prim_Ops;
----------------------
-- Set_Offset_Index --
----------------------
procedure Set_Offset_Index
(T : Interface_Tag;
Position : Positive;
Value : Positive)
is
Index : constant Integer := Position - Default_Prim_Op_Count;
begin
pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT));
pragma Assert (Index > 0);
OSD (T).OSD_Table (Index) := Value;
end Set_Offset_Index;
-----------------------
-- Set_Offset_To_Top --
-----------------------
......@@ -766,9 +1088,22 @@ package body Ada.Tags is
- DT_Typeinfo_Ptr_Size
- DT_Offset_To_Top_Size);
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
Offset_To_Top_Ptr.all := Value;
end Set_Offset_To_Top;
-------------
-- Set_OSD --
-------------
procedure Set_OSD (T : Interface_Tag; Value : System.Address) is
OSD_Ptr : Addr_Ptr;
begin
pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT));
OSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
OSD_Ptr.all := Value;
end Set_OSD;
-------------------------
-- Set_Prim_Op_Address --
-------------------------
......@@ -776,8 +1111,11 @@ package body Ada.Tags is
procedure Set_Prim_Op_Address
(T : Tag;
Position : Positive;
Value : System.Address) is
Value : System.Address)
is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Check_Index (T, Position));
T.Prims_Ptr (Position) := Value;
end Set_Prim_Op_Address;
......@@ -788,9 +1126,13 @@ package body Ada.Tags is
procedure Set_Prim_Op_Kind
(T : Tag;
Position : Positive;
Value : Prim_Op_Kind) is
Value : Prim_Op_Kind)
is
Index : constant Integer := Position - Default_Prim_Op_Count;
begin
TSD (T).POK_Table (Position - Default_Prim_Op_Count) := Value;
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
pragma Assert (Index > 0);
SSD (T).SSD_Table (Index).Kind := Value;
end Set_Prim_Op_Kind;
-------------------
......@@ -799,6 +1141,7 @@ package body Ada.Tags is
procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
TSD (T).RC_Offset := Value;
end Set_RC_Offset;
......@@ -808,20 +1151,41 @@ package body Ada.Tags is
procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
TSD (T).Remotely_Callable := Value;
end Set_Remotely_Callable;
-------------
-- Set_SSD --
-------------
procedure Set_SSD (T : Tag; Value : System.Address) is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
TSD (T).SSD_Ptr := Value;
end Set_SSD;
-------------
-- Set_TSD --
-------------
procedure Set_TSD (T : Tag; Value : System.Address) is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD_Ptr : Addr_Ptr;
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD_Ptr.all := Value;
end Set_TSD;
---------
-- SSD --
---------
function SSD (T : Tag) return Select_Specific_Data_Ptr is
begin
return To_Select_Specific_Data_Ptr (TSD (T).SSD_Ptr);
end SSD;
------------------
-- Typeinfo_Ptr --
------------------
......
gcc/ada/a-tags.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
......@@ -53,31 +53,38 @@ package Ada.Tags is
function Internal_Tag (External : String) return Tag;
function Descendant_Tag (External : String; Ancestor : Tag) return Tag;
function Descendant_Tag
(External : String;
Ancestor : Tag) return Tag;
pragma Ada_05 (Descendant_Tag);
function Is_Descendant_At_Same_Level
(Descendant : Tag;
Ancestor : Tag) return Boolean;
pragma Ada_05 (Is_Descendant_At_Same_Level);
function Parent_Tag (T : Tag) return Tag;
pragma Ada_05 (Parent_Tag);
Tag_Error : exception;
private
-- The following subprogram specifications are placed here instead of
-- the package body to see them from the frontend through rtsfind.
---------------------------------------------------------------
-- Abstract Procedural Interface For The GNAT Dispatch Table --
---------------------------------------------------------------
-- GNAT's Dispatch Table format is customizable in order to match the
-- format used in another language. GNAT supports programs that use
-- two different dispatch table formats at the same time: the native
-- format that supports Ada 95 tagged types and which is described in
-- Ada.Tags, and a foreign format for types that are imported from some
-- other language (typically C++) which is described in Interfaces.CPP.
-- The runtime information kept for each tagged type is separated into
-- two objects: the Dispatch Table and the Type Specific Data record.
-- These two objects are allocated statically using the constants:
-- format used in another language. GNAT supports programs that use two
-- different dispatch table formats at the same time: the native format
-- that supports Ada 95 tagged types and which is described in Ada.Tags,
-- and a foreign format for types that are imported from some other
-- language (typically C++) which is described in Interfaces.CPP. The
-- runtime information kept for each tagged type is separated into two
-- objects: the Dispatch Table and the Type Specific Data record. These
-- two objects are allocated statically using the constants:
-- DT Size = DT_Prologue_Size + Nb_Prim * DT_Entry_Size
-- TSD Size = TSD_Prologue_Size + (1 + Idepth) * TSD_Entry_Size
......@@ -85,9 +92,9 @@ private
-- where Nb_prim is the number of primitive operations of the given
-- type and Idepth its inheritance depth.
-- The compiler generates calls to the following SET routines to
-- initialize those structures and uses the GET functions to
-- retreive the information when needed
-- In order to set or retrieve information from the Dispatch Table or
-- the Type Specific Data record, GNAT generates calls to Set_XXX or
-- Get_XXX routines, where XXX is the name of the field of interest.
type Dispatch_Table;
type Tag is access all Dispatch_Table;
......@@ -95,6 +102,19 @@ private
No_Tag : constant Tag := null;
type Object_Specific_Data (Nb_Prim : Positive);
type Object_Specific_Data_Ptr is access all Object_Specific_Data;
-- Information associated with the secondary dispatch table of tagged-type
-- objects implementing abstract interfaces.
type Select_Specific_Data (Nb_Prim : Positive);
type Select_Specific_Data_Ptr is access all Select_Specific_Data;
-- A table used to store the primitive operation kind and entry index of
-- primitive subprograms of a type that implements a limited interface.
-- The Select Specific Data table resides in the Type Specific Data of a
-- type. This construct is used in the handling of dispatching triggers
-- in select statements.
type Type_Specific_Data;
type Type_Specific_Data_Ptr is access all Type_Specific_Data;
......@@ -109,17 +129,16 @@ private
POK_Protected_Function,
POK_Protected_Procedure,
POK_Task_Entry,
POK_Task_Function,
POK_Task_Procedure);
-- Number of predefined primitive operations added by the Expander
-- for a tagged type. It is utilized for indexing in the two auxiliary
-- tables used for dispatching asynchronous, conditional and timed
-- selects. In order to be space efficien, indexing is performed by
-- subtracting this constant value from the provided position in the
-- auxiliary tables.
-- This value is mirrored from Exp_Disp.ads.
Default_Prim_Op_Count : constant Positive := 14;
Default_Prim_Op_Count : constant Positive := 15;
-- Number of predefined primitive operations added by the Expander for a
-- tagged type. It is utilized for indexing in the two auxiliary tables
-- used for dispatching asynchronous, conditional and timed selects. In
-- order to be space efficient, indexing is performed by subtracting this
-- constant value from the provided position in the auxiliary tables (must
-- match Exp_Disp.Default_Prim_Op_Count).
package SSE renames System.Storage_Elements;
......@@ -127,9 +146,7 @@ private
-- Given the tag of an object and the tag associated to a type, return
-- true if Obj is in Typ'Class.
function IW_Membership
(This : System.Address;
T : Tag) return Boolean;
function IW_Membership (This : System.Address; T : Tag) return Boolean;
-- Ada 2005 (AI-251): General routine that checks if a given object
-- implements a tagged type. Its common usage is to check if Obj is in
-- Iface'Class, but it is also used to check if a class-wide interface
......@@ -147,22 +164,27 @@ private
-- Given the tag associated with a type, returns the accessibility level
-- of the type.
function Get_Entry_Index
(T : Tag;
Position : Positive) return Positive;
function Get_Entry_Index (T : Tag; Position : Positive) return Positive;
-- Return a primitive operation's entry index (if entry) given a dispatch
-- table T and a position of a primitive operation in T.
function Get_External_Tag (T : Tag) return System.Address;
-- Retrieve the address of a null terminated string containing
-- the external name
-- the external name.
function Get_Offset_Index
(T : Interface_Tag;
Position : Positive) return Positive;
-- Given a pointer to a secondary dispatch table (T) and a position of an
-- operation in the DT, retrieve the corresponding operation's position in
-- the primary dispatch table from the Offset Specific Data table of T.
function Get_Prim_Op_Address
(T : Tag;
Position : Positive) return System.Address;
-- Given a pointer to a dispatch table (T) and a position in the DT
-- this function returns the address of the virtual function stored
-- in it (used for dispatching calls)
-- in it (used for dispatching calls).
function Get_Prim_Op_Kind
(T : Tag;
......@@ -182,10 +204,7 @@ private
function Get_Remotely_Callable (T : Tag) return Boolean;
-- Return the value previously set by Set_Remotely_Callable
procedure Inherit_DT
(Old_T : Tag;
New_T : Tag;
Entry_Count : Natural);
procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural);
-- Entry point used to initialize the DT of a type knowing the tag
-- of the direct ancestor and the number of primitive ops that are
-- inherited (Entry_Count).
......@@ -193,21 +212,23 @@ private
procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag);
-- Initialize the TSD of a type knowing the tag of the direct ancestor
function OSD (T : Interface_Tag) return Object_Specific_Data_Ptr;
-- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
-- retrieve the address of the record containing the Objet Specific
-- Data table.
function Parent_Size
(Obj : System.Address;
T : Tag) return SSE.Storage_Count;
-- Computes the size the ancestor part of a tagged extension object
-- whose address is 'obj' by calling the indirectly _size function of
-- the ancestor. The ancestor is the parent of the type represented by
-- tag T. This function assumes that _size is always in slot 1 of
-- the dispatch table.
-- Computes the size the ancestor part of a tagged extension object whose
-- address is 'obj' by calling indirectly the ancestor _size function. The
-- ancestor is the parent of the type represented by tag T. This function
-- assumes that _size is always in slot one of the dispatch table.
pragma Export (Ada, Parent_Size, "ada__tags__parent_size");
-- This procedure is used in s-finimp and is thus exported manually
procedure Register_Interface_Tag
(T : Tag;
Interface_T : Tag);
procedure Register_Interface_Tag (T : Tag; Interface_T : Tag);
-- Ada 2005 (AI-251): Used to initialize the table of interfaces
-- implemented by a type. Required to give support to IW_Membership.
......@@ -215,13 +236,21 @@ private
-- Insert the Tag and its associated external_tag in a table for the
-- sake of Internal_Tag
procedure Set_Entry_Index
(T : Tag;
Position : Positive;
Value : Positive);
procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive);
-- Set the entry index of a primitive operation in T's TSD table indexed
-- by Position.
procedure Set_Num_Prim_Ops (T : Tag; Value : Natural);
-- Set the number of primitive operations in the dispatch table of T. This
-- is used for debugging purposes.
procedure Set_Offset_Index
(T : Interface_Tag;
Position : Positive;
Value : Positive);
-- Set the offset value of a primitive operation in a secondary dispatch
-- table denoted by T, indexed by Position.
procedure Set_Offset_To_Top
(T : Tag;
Value : System.Storage_Elements.Storage_Offset);
......@@ -230,6 +259,10 @@ private
-- is always 0; in secondary dispatch tables this is the offset to the base
-- of the enclosing type.
procedure Set_OSD (T : Interface_Tag; Value : System.Address);
-- Given a pointer T to a secondary dispatch table, store the pointer to
-- the record containing the Object Specific Data generated by GNAT.
procedure Set_Prim_Op_Address
(T : Tag;
Position : Positive;
......@@ -245,6 +278,10 @@ private
-- Set the kind of a primitive operation in T's TSD table indexed by
-- Position.
procedure Set_SSD (T : Tag; Value : System.Address);
-- Given a pointer T to a dispatch Table, stores the pointer to the record
-- containing the Select Specific Data generated by GNAT.
procedure Set_TSD (T : Tag; Value : System.Address);
-- Given a pointer T to a dispatch Table, stores the address of the record
-- containing the Type Specific Data generated by GNAT.
......@@ -269,15 +306,24 @@ private
-- Set to true if the type has been declared in a context described
-- in E.4 (18).
function SSD (T : Tag) return Select_Specific_Data_Ptr;
-- Given a pointer T to a dispatch Table, retrieves the address of the
-- record containing the Select Specific Data in T's TSD.
function TSD (T : Tag) return Type_Specific_Data_Ptr;
-- Given a pointer T to a dispatch Table, retreives the address of the
-- record containing the Type Specific Data generated by GNAT
-- Given a pointer T to a dispatch Table, retrieves the address of the
-- record containing the Type Specific Data generated by GNAT.
DT_Prologue_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(2 * (Standard'Address_Size / System.Storage_Unit));
(3 * (Standard'Address_Size / System.Storage_Unit));
-- Size of the first part of the dispatch table
DT_Signature_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(Standard'Address_Size / System.Storage_Unit);
-- Size of the Signature field of the dispatch table
DT_Offset_To_Top_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(Standard'Address_Size / System.Storage_Unit);
......@@ -295,7 +341,7 @@ private
TSD_Prologue_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(8 * (Standard'Address_Size / System.Storage_Unit));
(10 * (Standard'Address_Size / System.Storage_Unit));
-- Size of the first part of the type specific data
TSD_Entry_Size : constant SSE.Storage_Count :=
......@@ -308,22 +354,57 @@ private
-- of this type are declared with a dummy size of 1, the actual size
-- depending on the number of primitive operations.
-- Unchecked Conversions for Tag and TSD
type Signature_Kind is
(Unknown,
Valid_Signature,
Primary_DT,
Secondary_DT,
Abstract_Interface);
for Signature_Kind'Size use 8;
-- Kind of signature found in the header of the dispatch table. These
-- signatures are generated by the frontend and are used by the Check_XXX
-- routines to ensure that the kind of dispatch table managed by each of
-- the routines in this package is correct. This additional check is only
-- performed with this run-time package is compiled with assertions enabled
-- The signature is a sequence of two bytes. The first byte must have the
-- value Valid_Signature, and the second byte must have a value in the
-- range Primary_DT .. Abstract_Interface. The Unknown value is used by
-- the Check_XXX routines to indicate that the signature is wrong.
-- Unchecked Conversions
type Addr_Ptr is access System.Address;
type Tag_Ptr is access Tag;
type Signature_Values is
array (1 .. DT_Signature_Size) of Signature_Kind;
-- Type used to see the signature as a sequence of Signature_Kind values
function To_Addr_Ptr is
new Unchecked_Conversion (System.Address, Addr_Ptr);
function To_Type_Specific_Data_Ptr is
new Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
function To_Address is
new Unchecked_Conversion (Type_Specific_Data_Ptr, System.Address);
new Unchecked_Conversion (Interface_Tag, System.Address);
function To_Address is
new Unchecked_Conversion (Tag, System.Address);
type Addr_Ptr is access System.Address;
type Tag_Ptr is access Tag;
function To_Address is
new Unchecked_Conversion (Type_Specific_Data_Ptr, System.Address);
function To_Addr_Ptr is
new Unchecked_Conversion (System.Address, Addr_Ptr);
function To_Object_Specific_Data_Ptr is
new Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr);
function To_Select_Specific_Data_Ptr is
new Unchecked_Conversion (System.Address, Select_Specific_Data_Ptr);
function To_Signature_Values is
new Unchecked_Conversion (System.Storage_Elements.Storage_Offset,
Signature_Values);
function To_Tag_Ptr is
new Unchecked_Conversion (System.Address, Tag_Ptr);
......@@ -334,21 +415,32 @@ private
pragma Inline_Always (CW_Membership);
pragma Inline_Always (IW_Membership);
pragma Inline_Always (Get_Access_Level);
pragma Inline_Always (Get_Entry_Index);
pragma Inline_Always (Get_Offset_Index);
pragma Inline_Always (Get_Prim_Op_Address);
pragma Inline_Always (Get_Prim_Op_Kind);
pragma Inline_Always (Get_RC_Offset);
pragma Inline_Always (Get_Remotely_Callable);
pragma Inline_Always (Inherit_DT);
pragma Inline_Always (Inherit_TSD);
pragma Inline_Always (OSD);
pragma Inline_Always (Register_Interface_Tag);
pragma Inline_Always (Register_Tag);
pragma Inline_Always (Set_Access_Level);
pragma Inline_Always (Set_Entry_Index);
pragma Inline_Always (Set_Expanded_Name);
pragma Inline_Always (Set_External_Tag);
pragma Inline_Always (Set_Num_Prim_Ops);
pragma Inline_Always (Set_Offset_Index);
pragma Inline_Always (Set_Offset_To_Top);
pragma Inline_Always (Set_Prim_Op_Address);
pragma Inline_Always (Set_Prim_Op_Kind);
pragma Inline_Always (Set_RC_Offset);
pragma Inline_Always (Set_Remotely_Callable);
pragma Inline_Always (Set_OSD);
pragma Inline_Always (Set_SSD);
pragma Inline_Always (Set_TSD);
pragma Inline_Always (SSD);
pragma Inline_Always (TSD);
end Ada.Tags;
gcc/ada/einfo.adb
......@@ -214,8 +214,10 @@ package body Einfo is
-- Abstract_Interfaces Elist24
-- Abstract_Interface_Alias Node25
-- Current_Use_Clause Node25
-- Overridden_Operation Node26
-- Package_Instantiation Node26
-- Wrapped_Entity Node27
......@@ -388,7 +390,7 @@ package body Einfo is
-- Has_Recursive_Call Flag143
-- Is_Unsigned_Type Flag144
-- Strict_Alignment Flag145
-- Elaborate_All_Desirable Flag146
-- (unused) Flag146
-- Needs_Debug_Info Flag147
-- Suppress_Elaboration_Warnings Flag148
-- Is_Compilation_Unit Flag149
......@@ -444,12 +446,13 @@ package body Einfo is
-- Is_Local_Anonymous_Access Flag194
-- Is_Primitive_Wrapper Flag195
-- Was_Hidden Flag196
-- Is_Limited_Interface Flag197
-- Is_Protected_Interface Flag198
-- Is_Synchronized_Interface Flag199
-- Is_Task_Interface Flag200
-- Has_Anon_Block_Suffix Flag201
-- (unused) Flag197
-- (unused) Flag198
-- (unused) Flag199
-- (unused) Flag200
-- (unused) Flag201
-- (unused) Flag202
-- (unused) Flag203
-- (unused) Flag204
......@@ -698,6 +701,12 @@ package body Einfo is
return Node22 (Id);
end Corresponding_Remote_Type;
function Current_Use_Clause (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Package);
return Node25 (Id);
end Current_Use_Clause;
function Current_Value (Id : E) return N is
begin
pragma Assert (Ekind (Id) in Object_Kind);
......@@ -839,11 +848,6 @@ package body Einfo is
return Node16 (Id);
end DTC_Entity;
function Elaborate_All_Desirable (Id : E) return B is
begin
return Flag146 (Id);
end Elaborate_All_Desirable;
function Elaboration_Entity (Id : E) return E is
begin
pragma Assert
......@@ -1073,6 +1077,11 @@ package body Einfo is
return Flag79 (Id);
end Has_All_Calls_Remote;
function Has_Anon_Block_Suffix (Id : E) return B is
begin
return Flag201 (Id);
end Has_Anon_Block_Suffix;
function Has_Atomic_Components (Id : E) return B is
begin
return Flag86 (Implementation_Base_Type (Id));
......@@ -1667,6 +1676,12 @@ package body Einfo is
return Flag106 (Id);
end Is_Limited_Composite;
function Is_Limited_Interface (Id : E) return B is
begin
pragma Assert (Is_Interface (Id));
return Flag197 (Id);
end Is_Limited_Interface;
function Is_Limited_Record (Id : E) return B is
begin
return Flag25 (Id);
......@@ -1750,6 +1765,12 @@ package body Einfo is
return Flag53 (Id);
end Is_Private_Descendant;
function Is_Protected_Interface (Id : E) return B is
begin
pragma Assert (Is_Interface (Id));
return Flag198 (Id);
end Is_Protected_Interface;
function Is_Public (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
......@@ -1792,6 +1813,12 @@ package body Einfo is
return Flag28 (Id);
end Is_Statically_Allocated;
function Is_Synchronized_Interface (Id : E) return B is
begin
pragma Assert (Is_Interface (Id));
return Flag199 (Id);
end Is_Synchronized_Interface;
function Is_Tag (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
......@@ -1803,6 +1830,12 @@ package body Einfo is
return Flag55 (Id);
end Is_Tagged_Type;
function Is_Task_Interface (Id : E) return B is
begin
pragma Assert (Is_Interface (Id));
return Flag200 (Id);
end Is_Task_Interface;
function Is_Thread_Body (Id : E) return B is
begin
return Flag77 (Id);
......@@ -2016,7 +2049,8 @@ package body Einfo is
function Obsolescent_Warning (Id : E) return N is
begin
pragma Assert (Is_Subprogram (Id));
pragma Assert
(Is_Subprogram (Id) or else Is_Package_Or_Generic_Package (Id));
return Node24 (Id);
end Obsolescent_Warning;
......@@ -2048,6 +2082,15 @@ package body Einfo is
return Node26 (Id);
end Overridden_Operation;
function Package_Instantiation (Id : E) return N is
begin
pragma Assert
(False
or else Ekind (Id) = E_Generic_Package
or else Ekind (Id) = E_Package);
return Node26 (Id);
end Package_Instantiation;
function Packed_Array_Type (Id : E) return E is
begin
pragma Assert (Is_Array_Type (Id));
......@@ -2744,7 +2787,13 @@ package body Einfo is
Set_Node22 (Id, V);
end Set_Corresponding_Remote_Type;
procedure Set_Current_Value (Id : E; V : E) is
procedure Set_Current_Use_Clause (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Package);
Set_Node25 (Id, V);
end Set_Current_Use_Clause;
procedure Set_Current_Value (Id : E; V : N) is
begin
pragma Assert (Ekind (Id) in Object_Kind or else Ekind (Id) = E_Void);
Set_Node9 (Id, V);
......@@ -2888,11 +2937,6 @@ package body Einfo is
Set_Node16 (Id, V);
end Set_DTC_Entity;
procedure Set_Elaborate_All_Desirable (Id : E; V : B := True) is
begin
Set_Flag146 (Id, V);
end Set_Elaborate_All_Desirable;
procedure Set_Elaboration_Entity (Id : E; V : E) is
begin
pragma Assert
......@@ -3126,6 +3170,11 @@ package body Einfo is
Set_Flag79 (Id, V);
end Set_Has_All_Calls_Remote;
procedure Set_Has_Anon_Block_Suffix (Id : E; V : B := True) is
begin
Set_Flag201 (Id, V);
end Set_Has_Anon_Block_Suffix;
procedure Set_Has_Atomic_Components (Id : E; V : B := True) is
begin
pragma Assert (not Is_Type (Id) or else Base_Type (Id) = Id);
......@@ -3754,6 +3803,12 @@ package body Einfo is
Set_Flag106 (Id, V);
end Set_Is_Limited_Composite;
procedure Set_Is_Limited_Interface (Id : E; V : B := True) is
begin
pragma Assert (Is_Interface (Id));
Set_Flag197 (Id, V);
end Set_Is_Limited_Interface;
procedure Set_Is_Limited_Record (Id : E; V : B := True) is
begin
Set_Flag25 (Id, V);
......@@ -3838,6 +3893,12 @@ package body Einfo is
Set_Flag53 (Id, V);
end Set_Is_Private_Descendant;
procedure Set_Is_Protected_Interface (Id : E; V : B := True) is
begin
pragma Assert (Is_Interface (Id));
Set_Flag198 (Id, V);
end Set_Is_Protected_Interface;
procedure Set_Is_Public (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
......@@ -3886,6 +3947,12 @@ package body Einfo is
Set_Flag28 (Id, V);
end Set_Is_Statically_Allocated;
procedure Set_Is_Synchronized_Interface (Id : E; V : B := True) is
begin
pragma Assert (Is_Interface (Id));
Set_Flag199 (Id, V);
end Set_Is_Synchronized_Interface;
procedure Set_Is_Tag (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
......@@ -3902,6 +3969,12 @@ package body Einfo is
Set_Flag77 (Id, V);
end Set_Is_Thread_Body;
procedure Set_Is_Task_Interface (Id : E; V : B := True) is
begin
pragma Assert (Is_Interface (Id));
Set_Flag200 (Id, V);
end Set_Is_Task_Interface;
procedure Set_Is_True_Constant (Id : E; V : B := True) is
begin
Set_Flag163 (Id, V);
......@@ -4108,7 +4181,8 @@ package body Einfo is
procedure Set_Obsolescent_Warning (Id : E; V : N) is
begin
pragma Assert (Is_Subprogram (Id));
pragma Assert
(Is_Subprogram (Id) or else Is_Package_Or_Generic_Package (Id));
Set_Node24 (Id, V);
end Set_Obsolescent_Warning;
......@@ -4140,6 +4214,15 @@ package body Einfo is
Set_Node26 (Id, V);
end Set_Overridden_Operation;
procedure Set_Package_Instantiation (Id : E; V : N) is
begin
pragma Assert
(Ekind (Id) = E_Void
or else Ekind (Id) = E_Generic_Package
or else Ekind (Id) = E_Package);
Set_Node26 (Id, V);
end Set_Package_Instantiation;
procedure Set_Packed_Array_Type (Id : E; V : E) is
begin
pragma Assert (Is_Array_Type (Id));
......@@ -5693,17 +5776,17 @@ package body Einfo is
end if;
end Is_Limited_Type;
----------------
-- Is_Package --
----------------
-----------------------------------
-- Is_Package_Or_Generic_Package --
-----------------------------------
function Is_Package (Id : E) return B is
function Is_Package_Or_Generic_Package (Id : E) return B is
begin
return
Ekind (Id) = E_Package
or else
Ekind (Id) = E_Generic_Package;
end Is_Package;
end Is_Package_Or_Generic_Package;
--------------------------
-- Is_Protected_Private --
......@@ -6466,7 +6549,6 @@ package body Einfo is
W ("Delay_Subprogram_Descriptors", Flag50 (Id));
W ("Depends_On_Private", Flag14 (Id));
W ("Discard_Names", Flag88 (Id));
W ("Elaborate_All_Desirable", Flag146 (Id));
W ("Elaboration_Entity_Required", Flag174 (Id));
W ("Entry_Accepted", Flag152 (Id));
W ("Finalize_Storage_Only", Flag158 (Id));
......@@ -6475,6 +6557,7 @@ package body Einfo is
W ("Has_Aliased_Components", Flag135 (Id));
W ("Has_Alignment_Clause", Flag46 (Id));
W ("Has_All_Calls_Remote", Flag79 (Id));
W ("Has_Anon_Block_Suffix", Flag201 (Id));
W ("Has_Atomic_Components", Flag86 (Id));
W ("Has_Biased_Representation", Flag139 (Id));
W ("Has_Completion", Flag26 (Id));
......@@ -6580,6 +6663,7 @@ package body Einfo is
W ("Is_Known_Valid", Flag37 (Id));
W ("Is_Known_Valid", Flag170 (Id));
W ("Is_Limited_Composite", Flag106 (Id));
W ("Is_Limited_Interface", Flag197 (Id));
W ("Is_Limited_Record", Flag25 (Id));
W ("Is_Machine_Code_Subprogram", Flag137 (Id));
W ("Is_Non_Static_Subtype", Flag109 (Id));
......@@ -6595,6 +6679,7 @@ package body Einfo is
W ("Is_Primitive_Wrapper", Flag195 (Id));
W ("Is_Private_Composite", Flag107 (Id));
W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Protected_Interface", Flag198 (Id));
W ("Is_Public", Flag10 (Id));
W ("Is_Pure", Flag44 (Id));
W ("Is_Pure_Unit_Access_Type", Flag189 (Id));
......@@ -6602,9 +6687,11 @@ package body Einfo is
W ("Is_Remote_Types", Flag61 (Id));
W ("Is_Renaming_Of_Object", Flag112 (Id));
W ("Is_Shared_Passive", Flag60 (Id));
W ("Is_Synchronized_Interface", Flag199 (Id));
W ("Is_Statically_Allocated", Flag28 (Id));
W ("Is_Tag", Flag78 (Id));
W ("Is_Tagged_Type", Flag55 (Id));
W ("Is_Task_Interface", Flag200 (Id));
W ("Is_Thread_Body", Flag77 (Id));
W ("Is_True_Constant", Flag163 (Id));
W ("Is_Unchecked_Union", Flag117 (Id));
......@@ -7526,7 +7613,9 @@ package body Einfo is
E_Record_Subtype_With_Private =>
Write_Str ("Abstract_Interfaces");
when Subprogram_Kind =>
when Subprogram_Kind |
E_Package |
E_Generic_Package =>
Write_Str ("Obsolescent_Warning");
when Task_Kind =>
......@@ -7548,6 +7637,9 @@ package body Einfo is
E_Function =>
Write_Str ("Abstract_Interface_Alias");
when E_Package =>
Write_Str ("Current_Use_Clause");
when others =>
Write_Str ("Field25??");
end case;
......@@ -7560,6 +7652,10 @@ package body Einfo is
procedure Write_Field26_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when E_Generic_Package |
E_Package =>
Write_Str ("Package_Instantiation");
when E_Procedure |
E_Function =>
Write_Str ("Overridden_Operation");
......
gcc/ada/einfo.ads
......@@ -594,6 +594,11 @@ package Einfo is
-- created at the same time as the discriminal, and used to replace
-- occurrences of the discriminant within the type declaration.
-- Current_Use_Clause (Node25)
-- Present in packages. Indicates the use clause currently in scope
-- that makes the package use_visible. Used to detect redundant use
-- clauses for the same package.
-- Current_Value (Node9)
-- Present in E_Variable, E_Out_Parameter and E_In_Out_Parameter
-- entities. Set non-Empty if the (constant) current value of the
......@@ -801,13 +806,6 @@ package Einfo is
-- Present in all entities. Contains a value of the enumeration type
-- Entity_Kind declared in a subsequent section in this spec.
-- Elaborate_All_Desirable (Flag146)
-- Present in package and subprogram entities, and in generic package
-- and subprogram entities. Set if internal analysis of a client that
-- with's this unit determines that Elaborate_All is desirable, i.e.
-- that there is a possibility that Program_Error may be raised if
-- Elaborate_All conditions cannot be met.
-- Elaboration_Entity (Node13)
-- Present in generic and non-generic package and subprogram
-- entities. This is a boolean entity associated with the unit that
......@@ -1230,6 +1228,11 @@ package Einfo is
-- be RCI entities, so the flag Is_Remote_Call_Interface will always
-- be set if this flag is set.
-- Has_Anon_Block_Suffix (Flag201)
-- Present in all entities. Set if the entity is nested within one or
-- more anonymous blocks and the Chars field contains a name with an
-- anonymous block suffix (see Exp_Dbug for furthert details).
-- Has_Atomic_Components (Flag86) [implementation base type only]
-- Present in all types and objects. Set only for an array type or
-- an array object if a valid pragma Atomic_Components applies to the
......@@ -2106,6 +2109,10 @@ package Einfo is
-- do not become visible until the immediate scope of the composite
-- type itself (RM 7.3.1 (5)).
-- Is_Limited_Interface (Flag197)
-- Present in types that are interfaces. True if interface is declared
-- limited, or is derived from limited interfaces.
-- Is_Limited_Record (Flag25)
-- Present in all entities. Set to true for record (sub)types if the
-- record is declared to be limited. Note that this flag is not set
......@@ -2159,8 +2166,8 @@ package Einfo is
-- including generic formal parameters.
-- Is_Obsolescent (Flag153)
-- Present in all entities. Set only for subprograms when a valid pragma
-- Obsolescent applies to the subprogram.
-- Present in all entities. Set only for packages and subprograms to
-- which a valid pragma Obsolescent applies.
-- Is_Optional_Parameter (Flag134)
-- Present in parameter entities. Set if the parameter is specified as
......@@ -2175,7 +2182,7 @@ package Einfo is
-- Present in subprograms. Set if the subprogram is a primitive
-- operation of a derived type, that overrides an inherited operation.
-- Is_Package (synthesized)
-- Is_Package_Or_Generic_Package (synthesized)
-- Applies to all entities. True for packages and generic packages.
-- False for all other entities.
......@@ -2264,6 +2271,10 @@ package Einfo is
-- Applies to all entities, true for private types and subtypes,
-- as well as for record with private types as subtypes
-- Is_Protected_Interface (Flag198)
-- Present in types that are interfaces. True if interface is declared
-- protected, or is derived from protected interfaces.
-- Is_Protected_Type (synthesized)
-- Applies to all entities, true for protected types and subtypes
......@@ -2358,6 +2369,10 @@ package Einfo is
-- or a string slice type, or an array type with one dimension and a
-- component type that is a character type.
-- Is_Synchronized_Interface (Flag199)
-- Present_types that are interfaces. True is interface is declared
-- synchronized, or is derived from synchronized interfaces.
-- Is_Tag (Flag78)
-- Present in E_Component. For regular tagged type this flag is set on
-- the tag component (whose name is Name_uTag) and for CPP_Class tagged
......@@ -2367,6 +2382,10 @@ package Einfo is
-- Is_Tagged_Type (Flag55)
-- Present in all entities, true for an entity for a tagged type.
-- Is_Task_Interface (Flag200)
-- Present in types that are interfaces. True is interface is declared
-- as such, or if it is derived from task interfaces.
-- Is_Task_Record_Type (synthesized)
-- Applies to all entities, true if Is_Concurrent_Record_Type
-- Corresponding_Concurrent_Type is a task type.
......@@ -2732,8 +2751,8 @@ package Einfo is
-- formals as a value of type Pos.
-- Obsolescent_Warning (Node24)
-- Present in subprogram entities. Set non-empty only if the pragma
-- Obsolescent had a string argument, in which case it records the
-- Present in package and subprogram entities. Set non-empty only if the
-- pragma Obsolescent had a string argument, in which case it records the
-- contents of the corresponding string literal node.
-- Original_Access_Type (Node21)
......@@ -2778,6 +2797,18 @@ package Einfo is
-- Present in subprograms. For overriding operations, points to the
-- user-defined parent subprogram that is being overridden.
-- Package_Instantiation (Node26)
-- Present in packages and generic packages. When present, this field
-- references an N_Package_Instantiation node associated with an
-- instantiated package. In the case where the referenced node has
-- been rewritten to an N_Package_Specification, the instantiation
-- node is available from the Original_Node field of the package spec
-- node. This is currently not guaranteed to be set in all cases, but
-- when set, the field is used in Get_Package_Instantiation_Node as
-- one of the means of obtaining the instantiation node. Eventually
-- it should be set in all cases, including package entities associated
-- with formal packages. ???
-- Packed_Array_Type (Node23)
-- Present in array types and subtypes, including the string literal
-- subtype case, if the corresponding type is packed (either bit packed
......@@ -4009,6 +4040,7 @@ package Einfo is
-- Can_Never_Be_Null (Flag38)
-- Checks_May_Be_Suppressed (Flag31)
-- Debug_Info_Off (Flag166)
-- Has_Anon_Block_Suffix (Flag201)
-- Has_Controlled_Component (Flag43) (base type only)
-- Has_Convention_Pragma (Flag119)
-- Has_Delayed_Freeze (Flag18)
......@@ -4123,6 +4155,10 @@ package Einfo is
-- Is_Frozen (Flag4)
-- Is_Generic_Actual_Type (Flag94)
-- Is_Generic_Type (Flag13)
-- Is_Limited_Interface (Flag197)
-- Is_Protected_Interface (Flag198)
-- Is_Synchronized_Interface (Flag199)
-- Is_Task_Interface (Flag200)
-- Is_Non_Static_Subtype (Flag109)
-- Is_Packed (Flag51) (base type only)
-- Is_Private_Composite (Flag107)
......@@ -4428,7 +4464,6 @@ package Einfo is
-- Delay_Cleanups (Flag114)
-- Delay_Subprogram_Descriptors (Flag50)
-- Discard_Names (Flag88)
-- Elaborate_All_Desirable (Flag146)
-- Has_Completion (Flag26)
-- Has_Controlling_Result (Flag98)
-- Has_Master_Entity (Flag21)
......@@ -4596,10 +4631,12 @@ package Einfo is
-- Generic_Renamings (Elist23) (for an instance)
-- Inner_Instances (Elist23) (generic case only)
-- Limited_View (Node23) (non-generic, not instance)
-- Obsolescent_Warning (Node24)
-- Current_Use_Clause (Node25)
-- Package_Instantiation (Node26)
-- Delay_Subprogram_Descriptors (Flag50)
-- Body_Needed_For_SAL (Flag40)
-- Discard_Names (Flag88)
-- Elaborate_All_Desirable (Flag146)
-- Elaboration_Entity_Required (Flag174)
-- From_With_Type (Flag159)
-- Has_All_Calls_Remote (Flag79)
......@@ -4678,7 +4715,6 @@ package Einfo is
-- Delay_Cleanups (Flag114)
-- Delay_Subprogram_Descriptors (Flag50)
-- Discard_Names (Flag88)
-- Elaborate_All_Desirable (Flag146)
-- Has_Completion (Flag26)
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
......@@ -5145,6 +5181,7 @@ package Einfo is
function Corresponding_Equality (Id : E) return E;
function Corresponding_Record_Type (Id : E) return E;
function Corresponding_Remote_Type (Id : E) return E;
function Current_Use_Clause (Id : E) return E;
function Current_Value (Id : E) return N;
function Debug_Info_Off (Id : E) return B;
function Debug_Renaming_Link (Id : E) return E;
......@@ -5168,7 +5205,6 @@ package Einfo is
function Discriminant_Constraint (Id : E) return L;
function Discriminant_Default_Value (Id : E) return N;
function Discriminant_Number (Id : E) return U;
function Elaborate_All_Desirable (Id : E) return B;
function Elaboration_Entity (Id : E) return E;
function Elaboration_Entity_Required (Id : E) return B;
function Enclosing_Scope (Id : E) return E;
......@@ -5208,6 +5244,7 @@ package Einfo is
function Has_Aliased_Components (Id : E) return B;
function Has_Alignment_Clause (Id : E) return B;
function Has_All_Calls_Remote (Id : E) return B;
function Has_Anon_Block_Suffix (Id : E) return B;
function Has_Atomic_Components (Id : E) return B;
function Has_Biased_Representation (Id : E) return B;
function Has_Completion (Id : E) return B;
......@@ -5314,6 +5351,7 @@ package Einfo is
function Is_Known_Non_Null (Id : E) return B;
function Is_Known_Valid (Id : E) return B;
function Is_Limited_Composite (Id : E) return B;
function Is_Limited_Interface (Id : E) return B;
function Is_Machine_Code_Subprogram (Id : E) return B;
function Is_Non_Static_Subtype (Id : E) return B;
function Is_Null_Init_Proc (Id : E) return B;
......@@ -5328,6 +5366,7 @@ package Einfo is
function Is_Private_Composite (Id : E) return B;
function Is_Private_Descendant (Id : E) return B;
function Is_Protected_Interface (Id : E) return B;
function Is_Public (Id : E) return B;
function Is_Pure (Id : E) return B;
function Is_Pure_Unit_Access_Type (Id : E) return B;
......@@ -5336,8 +5375,10 @@ package Einfo is
function Is_Renaming_Of_Object (Id : E) return B;
function Is_Shared_Passive (Id : E) return B;
function Is_Statically_Allocated (Id : E) return B;
function Is_Synchronized_Interface (Id : E) return B;
function Is_Tag (Id : E) return B;
function Is_Tagged_Type (Id : E) return B;
function Is_Task_Interface (Id : E) return B;
function Is_Thread_Body (Id : E) return B;
function Is_True_Constant (Id : E) return B;
function Is_Unchecked_Union (Id : E) return B;
......@@ -5379,6 +5420,7 @@ package Einfo is
function Original_Array_Type (Id : E) return E;
function Original_Record_Component (Id : E) return E;
function Overridden_Operation (Id : E) return E;
function Package_Instantiation (Id : E) return N;
function Packed_Array_Type (Id : E) return E;
function Parent_Subtype (Id : E) return E;
function Primitive_Operations (Id : E) return L;
......@@ -5519,7 +5561,7 @@ package Einfo is
function Is_Dynamic_Scope (Id : E) return B;
function Is_Indefinite_Subtype (Id : E) return B;
function Is_Limited_Type (Id : E) return B;
function Is_Package (Id : E) return B;
function Is_Package_Or_Generic_Package (Id : E) return B;
function Is_Protected_Private (Id : E) return B;
function Is_Protected_Record_Type (Id : E) return B;
function Is_Return_By_Reference_Type (Id : E) return B;
......@@ -5638,6 +5680,7 @@ package Einfo is
procedure Set_Corresponding_Equality (Id : E; V : E);
procedure Set_Corresponding_Record_Type (Id : E; V : E);
procedure Set_Corresponding_Remote_Type (Id : E; V : E);
procedure Set_Current_Use_Clause (Id : E; V : E);
procedure Set_Current_Value (Id : E; V : N);
procedure Set_Debug_Info_Off (Id : E; V : B := True);
procedure Set_Debug_Renaming_Link (Id : E; V : E);
......@@ -5661,7 +5704,6 @@ package Einfo is
procedure Set_Discriminant_Constraint (Id : E; V : L);
procedure Set_Discriminant_Default_Value (Id : E; V : N);
procedure Set_Discriminant_Number (Id : E; V : U);
procedure Set_Elaborate_All_Desirable (Id : E; V : B := True);
procedure Set_Elaboration_Entity (Id : E; V : E);
procedure Set_Elaboration_Entity_Required (Id : E; V : B := True);
procedure Set_Enclosing_Scope (Id : E; V : E);
......@@ -5700,6 +5742,7 @@ package Einfo is
procedure Set_Has_Aliased_Components (Id : E; V : B := True);
procedure Set_Has_Alignment_Clause (Id : E; V : B := True);
procedure Set_Has_All_Calls_Remote (Id : E; V : B := True);
procedure Set_Has_Anon_Block_Suffix (Id : E; V : B := True);
procedure Set_Has_Atomic_Components (Id : E; V : B := True);
procedure Set_Has_Biased_Representation (Id : E; V : B := True);
procedure Set_Has_Completion (Id : E; V : B := True);
......@@ -5810,6 +5853,7 @@ package Einfo is
procedure Set_Is_Known_Non_Null (Id : E; V : B := True);
procedure Set_Is_Known_Valid (Id : E; V : B := True);
procedure Set_Is_Limited_Composite (Id : E; V : B := True);
procedure Set_Is_Limited_Interface (Id : E; V : B := True);
procedure Set_Is_Limited_Record (Id : E; V : B := True);
procedure Set_Is_Machine_Code_Subprogram (Id : E; V : B := True);
procedure Set_Is_Non_Static_Subtype (Id : E; V : B := True);
......@@ -5823,9 +5867,9 @@ package Einfo is
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True);
procedure Set_Is_Preelaborated (Id : E; V : B := True);
procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True);
procedure Set_Is_Private_Composite (Id : E; V : B := True);
procedure Set_Is_Private_Descendant (Id : E; V : B := True);
procedure Set_Is_Protected_Interface (Id : E; V : B := True);
procedure Set_Is_Public (Id : E; V : B := True);
procedure Set_Is_Pure (Id : E; V : B := True);
procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True);
......@@ -5834,8 +5878,10 @@ package Einfo is
procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True);
procedure Set_Is_Shared_Passive (Id : E; V : B := True);
procedure Set_Is_Statically_Allocated (Id : E; V : B := True);
procedure Set_Is_Synchronized_Interface (Id : E; V : B := True);
procedure Set_Is_Tag (Id : E; V : B := True);
procedure Set_Is_Tagged_Type (Id : E; V : B := True);
procedure Set_Is_Task_Interface (Id : E; V : B := True);
procedure Set_Is_Thread_Body (Id : E; V : B := True);
procedure Set_Is_True_Constant (Id : E; V : B := True);
procedure Set_Is_Unchecked_Union (Id : E; V : B := True);
......@@ -5876,6 +5922,7 @@ package Einfo is
procedure Set_Original_Array_Type (Id : E; V : E);
procedure Set_Original_Record_Component (Id : E; V : E);
procedure Set_Overridden_Operation (Id : E; V : E);
procedure Set_Package_Instantiation (Id : E; V : N);
procedure Set_Packed_Array_Type (Id : E; V : E);
procedure Set_Parent_Subtype (Id : E; V : E);
procedure Set_Primitive_Operations (Id : E; V : L);
......@@ -6185,6 +6232,7 @@ package Einfo is
pragma Inline (Corresponding_Equality);
pragma Inline (Corresponding_Record_Type);
pragma Inline (Corresponding_Remote_Type);
pragma Inline (Current_Use_Clause);
pragma Inline (Current_Value);
pragma Inline (Debug_Info_Off);
pragma Inline (Debug_Renaming_Link);
......@@ -6208,7 +6256,6 @@ package Einfo is
pragma Inline (Discriminant_Constraint);
pragma Inline (Discriminant_Default_Value);
pragma Inline (Discriminant_Number);
pragma Inline (Elaborate_All_Desirable);
pragma Inline (Elaboration_Entity);
pragma Inline (Elaboration_Entity_Required);
pragma Inline (Enclosing_Scope);
......@@ -6247,6 +6294,7 @@ package Einfo is
pragma Inline (Has_Aliased_Components);
pragma Inline (Has_Alignment_Clause);
pragma Inline (Has_All_Calls_Remote);
pragma Inline (Has_Anon_Block_Suffix);
pragma Inline (Has_Atomic_Components);
pragma Inline (Has_Biased_Representation);
pragma Inline (Has_Completion);
......@@ -6377,6 +6425,7 @@ package Einfo is
pragma Inline (Is_Known_Non_Null);
pragma Inline (Is_Known_Valid);
pragma Inline (Is_Limited_Composite);
pragma Inline (Is_Limited_Interface);
pragma Inline (Is_Limited_Record);
pragma Inline (Is_Machine_Code_Subprogram);
pragma Inline (Is_Modular_Integer_Type);
......@@ -6400,6 +6449,7 @@ package Einfo is
pragma Inline (Is_Private_Composite);
pragma Inline (Is_Private_Descendant);
pragma Inline (Is_Private_Type);
pragma Inline (Is_Protected_Interface);
pragma Inline (Is_Protected_Type);
pragma Inline (Is_Public);
pragma Inline (Is_Pure);
......@@ -6414,8 +6464,10 @@ package Einfo is
pragma Inline (Is_Signed_Integer_Type);
pragma Inline (Is_Statically_Allocated);
pragma Inline (Is_Subprogram);
pragma Inline (Is_Synchronized_Interface);
pragma Inline (Is_Tag);
pragma Inline (Is_Tagged_Type);
pragma Inline (Is_Task_Interface);
pragma Inline (Is_Thread_Body);
pragma Inline (Is_True_Constant);
pragma Inline (Is_Task_Type);
......@@ -6459,6 +6511,7 @@ package Einfo is
pragma Inline (Original_Array_Type);
pragma Inline (Original_Record_Component);
pragma Inline (Overridden_Operation);
pragma Inline (Package_Instantiation);
pragma Inline (Packed_Array_Type);
pragma Inline (Parameter_Mode);
pragma Inline (Parent_Subtype);
......@@ -6552,6 +6605,7 @@ package Einfo is
pragma Inline (Set_Corresponding_Equality);
pragma Inline (Set_Corresponding_Record_Type);
pragma Inline (Set_Corresponding_Remote_Type);
pragma Inline (Set_Current_Use_Clause);
pragma Inline (Set_Current_Value);
pragma Inline (Set_Debug_Info_Off);
pragma Inline (Set_Debug_Renaming_Link);
......@@ -6574,7 +6628,6 @@ package Einfo is
pragma Inline (Set_Discriminant_Constraint);
pragma Inline (Set_Discriminant_Default_Value);
pragma Inline (Set_Discriminant_Number);
pragma Inline (Set_Elaborate_All_Desirable);
pragma Inline (Set_Elaboration_Entity);
pragma Inline (Set_Elaboration_Entity_Required);
pragma Inline (Set_Enclosing_Scope);
......@@ -6611,6 +6664,7 @@ package Einfo is
pragma Inline (Set_Has_Aliased_Components);
pragma Inline (Set_Has_Alignment_Clause);
pragma Inline (Set_Has_All_Calls_Remote);
pragma Inline (Set_Has_Anon_Block_Suffix);
pragma Inline (Set_Has_Atomic_Components);
pragma Inline (Set_Has_Biased_Representation);
pragma Inline (Set_Has_Completion);
......@@ -6720,6 +6774,7 @@ package Einfo is
pragma Inline (Set_Is_Known_Non_Null);
pragma Inline (Set_Is_Known_Valid);
pragma Inline (Set_Is_Limited_Composite);
pragma Inline (Set_Is_Limited_Interface);
pragma Inline (Set_Is_Limited_Record);
pragma Inline (Set_Is_Machine_Code_Subprogram);
pragma Inline (Set_Is_Non_Static_Subtype);
......@@ -6736,6 +6791,7 @@ package Einfo is
pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Protected_Interface);
pragma Inline (Set_Is_Public);
pragma Inline (Set_Is_Pure);
pragma Inline (Set_Is_Pure_Unit_Access_Type);
......@@ -6744,8 +6800,10 @@ package Einfo is
pragma Inline (Set_Is_Renaming_Of_Object);
pragma Inline (Set_Is_Shared_Passive);
pragma Inline (Set_Is_Statically_Allocated);
pragma Inline (Set_Is_Synchronized_Interface);
pragma Inline (Set_Is_Tag);
pragma Inline (Set_Is_Tagged_Type);
pragma Inline (Set_Is_Task_Interface);
pragma Inline (Set_Is_Thread_Body);
pragma Inline (Set_Is_True_Constant);
pragma Inline (Set_Is_Unchecked_Union);
......@@ -6786,6 +6844,7 @@ package Einfo is
pragma Inline (Set_Original_Array_Type);
pragma Inline (Set_Original_Record_Component);
pragma Inline (Set_Overridden_Operation);
pragma Inline (Set_Package_Instantiation);
pragma Inline (Set_Packed_Array_Type);
pragma Inline (Set_Parent_Subtype);
pragma Inline (Set_Primitive_Operations);
......@@ -6849,7 +6908,7 @@ package Einfo is
-- things here which are small, but not of the canonical attribute
-- access/set format that can be handled by xeinfo.
pragma Inline (Is_Package);
pragma Inline (Is_Package_Or_Generic_Package);
pragma Inline (Is_Wrapper_Package);
pragma Inline (Known_RM_Size);
pragma Inline (Known_Static_Component_Bit_Offset);
......
gcc/ada/exp_ch3.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -79,13 +79,6 @@ package body Exp_Ch3 is
-- used for attachment of any actions required in its construction.
-- It also supplies the source location used for the procedure.
procedure Build_Class_Wide_Master (T : Entity_Id);
-- for access to class-wide limited types we must build a task master
-- because some subsequent extension may add a task component. To avoid
-- bringing in the tasking run-time whenever an access-to-class-wide
-- limited type is used, we use the soft-link mechanism and add a level
-- of indirection to calls to routines that manipulate Master_Ids.
function Build_Discriminant_Formals
(Rec_Id : Entity_Id;
Use_Dl : Boolean) return List_Id;
......@@ -651,6 +644,7 @@ package body Exp_Ch3 is
M_Id : Entity_Id;
Decl : Node_Id;
P : Node_Id;
Par : Node_Id;
begin
-- Nothing to do if there is no task hierarchy
......@@ -659,6 +653,16 @@ package body Exp_Ch3 is
return;
end if;
-- Find declaration that created the access type: either a
-- type declaration, or an object declaration with an
-- access definition, in which case the type is anonymous.
if Is_Itype (T) then
P := Associated_Node_For_Itype (T);
else
P := Parent (T);
end if;
-- Nothing to do if we already built a master entity for this scope
if not Has_Master_Entity (Scope (T)) then
......@@ -677,24 +681,24 @@ package body Exp_Ch3 is
Make_Explicit_Dereference (Loc,
New_Reference_To (RTE (RE_Current_Master), Loc)));
P := Parent (T);
Insert_Before (P, Decl);
Analyze (Decl);
Set_Has_Master_Entity (Scope (T));
-- Now mark the containing scope as a task master
while Nkind (P) /= N_Compilation_Unit loop
P := Parent (P);
Par := P;
while Nkind (Par) /= N_Compilation_Unit loop
Par := Parent (Par);
-- If we fall off the top, we are at the outer level, and the
-- environment task is our effective master, so nothing to mark.
if Nkind (P) = N_Task_Body
or else Nkind (P) = N_Block_Statement
or else Nkind (P) = N_Subprogram_Body
if Nkind (Par) = N_Task_Body
or else Nkind (Par) = N_Block_Statement
or else Nkind (Par) = N_Subprogram_Body
then
Set_Is_Task_Master (P, True);
Set_Is_Task_Master (Par, True);
exit;
end if;
end loop;
......@@ -711,7 +715,7 @@ package body Exp_Ch3 is
Defining_Identifier => M_Id,
Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
Name => Make_Identifier (Loc, Name_uMaster));
Insert_Before (Parent (T), Decl);
Insert_Before (P, Decl);
Analyze (Decl);
Set_Master_Id (T, M_Id);
......@@ -1758,10 +1762,18 @@ package body Exp_Ch3 is
Aux_N : Node_Id;
begin
if not Is_Interface (Typ)
and then Etype (Typ) /= Typ
then
Init_Secondary_Tags_Internal (Etype (Typ));
if not Is_Interface (Typ) then
-- Climb to the ancestor (if any) handling private types
if Present (Full_View (Etype (Typ))) then
if Full_View (Etype (Typ)) /= Typ then
Init_Secondary_Tags_Internal (Full_View (Etype (Typ)));
end if;
elsif Etype (Typ) /= Typ then
Init_Secondary_Tags_Internal (Etype (Typ));
end if;
end if;
if Present (Abstract_Interfaces (Typ))
......@@ -1824,7 +1836,14 @@ package body Exp_Ch3 is
-- interfaces.
ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
Init_Secondary_Tags_Internal (Typ);
-- Handle private types
if Present (Full_View (Typ)) then
Init_Secondary_Tags_Internal (Full_View (Typ));
else
Init_Secondary_Tags_Internal (Typ);
end if;
end Init_Secondary_Tags;
-- Start of processing for Build_Init_Procedure
......@@ -2478,6 +2497,13 @@ package body Exp_Ch3 is
return False;
end if;
-- If it is a type derived from a type with unknown discriminants,
-- we cannot build an initialization procedure for it.
if Has_Unknown_Discriminants (Rec_Id) then
return False;
end if;
-- Otherwise we need to generate an initialization procedure if
-- Is_CPP_Class is False and at least one of the following applies:
......@@ -4547,34 +4573,52 @@ package body Exp_Ch3 is
ADT : Elist_Id := Access_Disp_Table (Def_Id);
procedure Add_Secondary_Tables (Typ : Entity_Id);
-- Comment required ???
-- Internal subprogram, recursively climb to the ancestors
--------------------------
-- Add_Secondary_Tables --
--------------------------
procedure Add_Secondary_Tables (Typ : Entity_Id) is
E : Entity_Id;
Result : List_Id;
E : Entity_Id;
Iface : Elmt_Id;
Result : List_Id;
Suffix_Index : Int;
begin
if Etype (Typ) /= Typ then
-- Climb to the ancestor (if any) handling private types
if Present (Full_View (Etype (Typ))) then
if Full_View (Etype (Typ)) /= Typ then
Add_Secondary_Tables (Full_View (Etype (Typ)));
end if;
elsif Etype (Typ) /= Typ then
Add_Secondary_Tables (Etype (Typ));
end if;
if Present (Abstract_Interfaces (Typ))
and then not Is_Empty_Elmt_List
(Abstract_Interfaces (Typ))
and then
not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
then
Iface := First_Elmt (Abstract_Interfaces (Typ));
Suffix_Index := 0;
E := First_Entity (Typ);
while Present (E) loop
if Is_Tag (E) and then Chars (E) /= Name_uTag then
Make_Abstract_Interface_DT
(AI_Tag => E,
Make_Secondary_DT
(Typ => Def_Id,
Ancestor_Typ => Typ,
Suffix_Index => Suffix_Index,
Iface => Node (Iface),
AI_Tag => E,
Acc_Disp_Tables => ADT,
Result => Result);
Append_Freeze_Actions (Def_Id, Result);
Suffix_Index := Suffix_Index + 1;
Next_Elmt (Iface);
end if;
Next_Entity (E);
......@@ -4585,7 +4629,14 @@ package body Exp_Ch3 is
-- Start of processing to build secondary dispatch tables
begin
Add_Secondary_Tables (Def_Id);
-- Handle private types
if Present (Full_View (Def_Id)) then
Add_Secondary_Tables (Full_View (Def_Id));
else
Add_Secondary_Tables (Def_Id);
end if;
Set_Access_Disp_Table (Def_Id, ADT);
Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
end;
......@@ -4699,9 +4750,14 @@ package body Exp_Ch3 is
and then not Is_Interface (Def_Id)
and then not Is_Abstract (Def_Id)
and then not Is_Controlled (Def_Id)
and then Implements_Limited_Interface (Def_Id)
and then
Implements_Interface
(Typ => Def_Id,
Kind => Any_Limited_Interface,
Check_Parent => True)
then
Append_Freeze_Actions (Def_Id, Make_Disp_Select_Tables (Def_Id));
Append_Freeze_Actions (Def_Id,
Make_Select_Specific_Data_Table (Def_Id));
end if;
end if;
end Freeze_Record_Type;
......@@ -5897,6 +5953,7 @@ package body Exp_Ch3 is
-- disp_asynchronous_select
-- disp_conditional_select
-- disp_get_prim_op_kind
-- disp_get_task_id
-- disp_timed_select
-- for limited interfaces and tagged types that implement a limited
-- interface.
......@@ -5908,50 +5965,36 @@ package body Exp_Ch3 is
or else
(not Is_Abstract (Tag_Typ)
and then not Is_Controlled (Tag_Typ)
and then Implements_Limited_Interface (Tag_Typ)))
and then
Implements_Interface
(Typ => Tag_Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)))
then
if Is_Interface (Tag_Typ) then
Append_To (Res,
Make_Abstract_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
Append_To (Res,
Make_Abstract_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Conditional_Select_Spec (Tag_Typ)));
Append_To (Res,
Make_Abstract_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
Append_To (Res,
Make_Abstract_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Timed_Select_Spec (Tag_Typ)));
Append_To (Res,
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
else
Append_To (Res,
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
Append_To (Res,
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Conditional_Select_Spec (Tag_Typ)));
Append_To (Res,
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Conditional_Select_Spec (Tag_Typ)));
Append_To (Res,
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
Append_To (Res,
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
Append_To (Res,
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
Append_To (Res,
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Timed_Select_Spec (Tag_Typ)));
end if;
Append_To (Res,
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Timed_Select_Spec (Tag_Typ)));
end if;
-- Specs for finalization actions that may be required in case a
......@@ -6310,26 +6353,33 @@ package body Exp_Ch3 is
end if;
-- Generate the bodies for the following primitive operations:
-- disp_asynchronous_select
-- disp_conditional_select
-- disp_get_prim_op_kind
-- disp_get_task_id
-- disp_timed_select
-- for tagged types that implement a limited interface.
-- for limited interfaces and tagged types that implement a limited
-- interface. The interface versions will have null bodies.
if Ada_Version >= Ada_05
and then not Is_Interface (Tag_Typ)
and then not Is_Abstract (Tag_Typ)
and then not Is_Controlled (Tag_Typ)
and then Implements_Limited_Interface (Tag_Typ)
and then
((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ))
or else
(not Is_Abstract (Tag_Typ)
and then not Is_Controlled (Tag_Typ)
and then
Implements_Interface
(Typ => Tag_Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)))
then
Append_To (Res,
Make_Disp_Asynchronous_Select_Body (Tag_Typ));
Append_To (Res,
Make_Disp_Conditional_Select_Body (Tag_Typ));
Append_To (Res,
Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ));
Append_To (Res,
Make_Disp_Timed_Select_Body (Tag_Typ));
Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));
Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ));
Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ));
Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ));
end if;
if not Is_Limited_Type (Tag_Typ) then
......@@ -6337,23 +6387,23 @@ package body Exp_Ch3 is
-- Body for equality
if Eq_Needed then
Decl :=
Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Eq_Name,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_X),
Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
Decl := Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Eq_Name,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_X),
Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Y),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Y),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
Ret_Type => Standard_Boolean,
For_Body => True);
Ret_Type => Standard_Boolean,
For_Body => True);
declare
Def : constant Node_Id := Parent (Tag_Typ);
......@@ -6403,19 +6453,20 @@ package body Exp_Ch3 is
-- Body for dispatching assignment
Decl := Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Name_uAssign,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
Out_Present => True,
Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
For_Body => True);
Decl :=
Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Name_uAssign,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
Out_Present => True,
Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
For_Body => True);
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc, New_List (
......@@ -6541,6 +6592,7 @@ package body Exp_Ch3 is
return
not (Is_Limited_Type (Typ)
and then not Has_Inheritable_Stream_Attribute)
and then not Has_Unknown_Discriminants (Typ)
and then RTE_Available (RE_Tag)
and then RTE_Available (RE_Root_Stream_Type)
and then not Restriction_Active (No_Dispatch)
......
gcc/ada/exp_ch3.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -40,12 +40,21 @@ package Exp_Ch3 is
procedure Expand_Previous_Access_Type (Def_Id : Entity_Id);
-- For a full type declaration that contains tasks, or that is a task,
-- check whether there exists an access type whose designated type is an
-- incomplete declarations for the current composite type. If so, build
-- the master for that access type, now that it is known to denote an
-- object with tasks.
-- incomplete declarations for the current composite type. If so, build the
-- master for that access type, now that it is known to denote an object
-- with tasks.
procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id);
-- Add a field _parent in the extension part of the record.
-- Add a field _parent in the extension part of the record
procedure Build_Class_Wide_Master (T : Entity_Id);
-- For access to class-wide limited types we must build a task master
-- because some subsequent extension may add a task component. To avoid
-- bringing in the tasking run-time whenever an access-to-class-wide
-- limited type is used, we use the soft-link mechanism and add a level of
-- indirection to calls to routines that manipulate Master_Ids. This must
-- also be used for anonymous access types whose designated type is a task
-- or synchronized interface.
procedure Build_Discr_Checking_Funcs (N : Node_Id);
-- Builds function which checks whether the component name is consistent
......@@ -66,10 +75,10 @@ package Exp_Ch3 is
-- constructed tree, and Typ is the type of the entity (the initialization
-- procedure of the base type is the procedure that actually gets called).
-- In_Init_Proc has to be set to True when the call is itself in an init
-- proc in order to enable the use of discriminals. Enclos_type is the
-- type of the init proc and it is used for various expansion cases
-- including the case where Typ is a task type which is a array component,
-- the indices of the enclosing type are used to build the string that
-- proc in order to enable the use of discriminals. Enclos_type is the type
-- of the init proc and it is used for various expansion cases including
-- the case where Typ is a task type which is a array component, the
-- indices of the enclosing type are used to build the string that
-- identifies each task at runtime.
--
-- Discr_Map is used to replace discriminants by their discriminals in
......@@ -84,33 +93,32 @@ package Exp_Ch3 is
function Freeze_Type (N : Node_Id) return Boolean;
-- This function executes the freezing actions associated with the given
-- freeze type node N and returns True if the node is to be deleted.
-- We delete the node if it is present just for front end purpose and
-- we don't want Gigi to see the node. This function can't delete the
-- node itself since it would confuse any remaining processing of the
-- freeze node.
-- freeze type node N and returns True if the node is to be deleted. We
-- delete the node if it is present just for front end purpose and we don't
-- want Gigi to see the node. This function can't delete the node itself
-- since it would confuse any remaining processing of the freeze node.
function Needs_Simple_Initialization (T : Entity_Id) return Boolean;
-- Certain types need initialization even though there is no specific
-- initialization routine. In this category are access types (which
-- need initializing to null), packed array types whose implementation
-- is a modular type, and all scalar types if Normalize_Scalars is set,
-- as well as private types whose underlying type is present and meets
-- any of these criteria. Finally, descendants of String and Wide_String
-- also need initialization in Initialize/Normalize_Scalars mode.
-- initialization routine. In this category are access types (which need
-- initializing to null), packed array types whose implementation is a
-- modular type, and all scalar types if Normalize_Scalars is set, as well
-- as private types whose underlying type is present and meets any of these
-- criteria. Finally, descendants of String and Wide_String also need
-- initialization in Initialize/Normalize_Scalars mode.
function Get_Simple_Init_Val
(T : Entity_Id;
Loc : Source_Ptr;
Size : Uint := No_Uint) return Node_Id;
-- For a type which Needs_Simple_Initialization (see above), prepares
-- the tree for an expression representing the required initial value.
-- Loc is the source location used in constructing this tree which is
-- returned as the result of the call. The Size parameter indicates the
-- target size of the object if it is known (indicated by a value that
-- is not No_Uint and is greater than zero). If Size is not given (Size
-- set to No_Uint, or non-positive), then the Esize of T is used as an
-- estimate of the Size. The object size is needed to prepare a known
-- invalid value for use by Normalize_Scalars.
-- For a type which Needs_Simple_Initialization (see above), prepares the
-- tree for an expression representing the required initial value. Loc is
-- the source location used in constructing this tree which is returned as
-- the result of the call. The Size parameter indicates the target size of
-- the object if it is known (indicated by a value that is not No_Uint and
-- is greater than zero). If Size is not given (Size set to No_Uint, or
-- non-positive), then the Esize of T is used as an estimate of the Size.
-- The object size is needed to prepare a known invalid value for use by
-- Normalize_Scalars.
end Exp_Ch3;
gcc/ada/exp_ch6.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -99,10 +99,11 @@ package body Exp_Ch6 is
-- we have an infinite recursion.
procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id);
-- For each actual of an in-out parameter which is a numeric conversion
-- of the form T(A), where A denotes a variable, we insert the declaration:
-- For each actual of an in-out or out parameter which is a numeric
-- (view) conversion of the form T (A), where A denotes a variable,
-- we insert the declaration:
--
-- Temp : T := T (A);
-- Temp : T[ := T (A)];
--
-- prior to the call. Then we replace the actual with a reference to Temp,
-- and append the assignment:
......@@ -1464,6 +1465,48 @@ package body Exp_Ch6 is
end if;
end if;
-- Ada 2005 (AI-345): We have a procedure call as a triggering
-- alternative in an asynchronous select or as an entry call in
-- a conditional or timed select. Check whether the procedure call
-- is a renaming of an entry and rewrite it as an entry call.
if Ada_Version >= Ada_05
and then Nkind (N) = N_Procedure_Call_Statement
and then
((Nkind (Parent (N)) = N_Triggering_Alternative
and then Triggering_Statement (Parent (N)) = N)
or else
(Nkind (Parent (N)) = N_Entry_Call_Alternative
and then Entry_Call_Statement (Parent (N)) = N))
then
declare
Ren_Decl : Node_Id;
Ren_Root : Entity_Id := Subp;
begin
-- This may be a chain of renamings, find the root
if Present (Alias (Ren_Root)) then
Ren_Root := Alias (Ren_Root);
end if;
if Present (Original_Node (Parent (Parent (Ren_Root)))) then
Ren_Decl := Original_Node (Parent (Parent (Ren_Root)));
if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then
Rewrite (N,
Make_Entry_Call_Statement (Loc,
Name =>
New_Copy_Tree (Name (Ren_Decl)),
Parameter_Associations =>
New_Copy_List_Tree (Parameter_Associations (N))));
return;
end if;
end if;
end;
end if;
-- First step, compute extra actuals, corresponding to any
-- Extra_Formals present. Note that we do not access Extra_Formals
-- directly, instead we simply note the presence of the extra
......@@ -1558,13 +1601,29 @@ package body Exp_Ch6 is
Act_Prev := Expression (Act_Prev);
end loop;
Add_Extra_Actual (
Make_Attribute_Reference (Sloc (Prev),
Prefix =>
Duplicate_Subexpr_No_Checks
(Act_Prev, Name_Req => True),
Attribute_Name => Name_Constrained),
Extra_Constrained (Formal));
-- If the expression is a conversion of a dereference,
-- this is internally generated code that manipulates
-- addresses, e.g. when building interface tables. No
-- check should occur in this case, and the discriminated
-- object is not directly a hand.
if not Comes_From_Source (Actual)
and then Nkind (Actual) = N_Unchecked_Type_Conversion
and then Nkind (Act_Prev) = N_Explicit_Dereference
then
Add_Extra_Actual
(New_Occurrence_Of (Standard_False, Loc),
Extra_Constrained (Formal));
else
Add_Extra_Actual
(Make_Attribute_Reference (Sloc (Prev),
Prefix =>
Duplicate_Subexpr_No_Checks
(Act_Prev, Name_Req => True),
Attribute_Name => Name_Constrained),
Extra_Constrained (Formal));
end if;
end;
end if;
end if;
......@@ -1591,10 +1650,10 @@ package body Exp_Ch6 is
pragma Assert (Present (Parm_Ent));
if Present (Extra_Accessibility (Parm_Ent)) then
Add_Extra_Actual (
New_Occurrence_Of
(Extra_Accessibility (Parm_Ent), Loc),
Extra_Accessibility (Formal));
Add_Extra_Actual
(New_Occurrence_Of
(Extra_Accessibility (Parm_Ent), Loc),
Extra_Accessibility (Formal));
-- If the actual access parameter does not have an
-- associated extra formal providing its scope level,
......@@ -1602,10 +1661,10 @@ package body Exp_Ch6 is
-- accessibility.
else
Add_Extra_Actual (
Make_Integer_Literal (Loc,
Intval => Scope_Depth (Standard_Standard)),
Extra_Accessibility (Formal));
Add_Extra_Actual
(Make_Integer_Literal (Loc,
Intval => Scope_Depth (Standard_Standard)),
Extra_Accessibility (Formal));
end if;
end;
......@@ -1613,10 +1672,10 @@ package body Exp_Ch6 is
-- level of the actual's access type.
else
Add_Extra_Actual (
Make_Integer_Literal (Loc,
Intval => Type_Access_Level (Etype (Prev_Orig))),
Extra_Accessibility (Formal));
Add_Extra_Actual
(Make_Integer_Literal (Loc,
Intval => Type_Access_Level (Etype (Prev_Orig))),
Extra_Accessibility (Formal));
end if;
else
......@@ -3092,6 +3151,12 @@ package body Exp_Ch6 is
-- If the call is the right side of an assignment or the expression in
-- an object declaration, we don't need to create a temp as the left
-- side will already trigger stack checking if necessary.
--
-- If the call is a component in an extension aggregate, it will be
-- expanded into assignments as well, so no temporary is needed. This
-- also solves the problem of functions returning types with unknown
-- discriminants, where it is not possible to declare an object of the
-- type altogether.
---------------------------
-- Returned_By_Reference --
......@@ -3143,6 +3208,9 @@ package body Exp_Ch6 is
and then Expression (Parent (N)) = N
and then Nkind (Parent (Parent (N))) = N_Aggregate
and then Rhs_Of_Assign_Or_Decl (Parent (Parent (N))))
or else
(Nkind (Parent (N)) = N_Extension_Aggregate
and then Is_Private_Type (Etype (Typ)))
then
return True;
else
......@@ -4052,8 +4120,8 @@ package body Exp_Ch6 is
-----------------------
procedure Freeze_Subprogram (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
E : constant Entity_Id := Entity (N);
Loc : constant Source_Ptr := Sloc (N);
E : constant Entity_Id := Entity (N);
procedure Check_Overriding_Inherited_Interfaces (E : Entity_Id);
-- (Ada 2005): Check if the primitive E covers some interface already
......@@ -4068,6 +4136,10 @@ package body Exp_Ch6 is
-- immediate ancestor associated with the interface; otherwise Prim and
-- Ancestor_Iface_Prim have the same info.
procedure Register_Predefined_DT_Entry (Prim : Entity_Id);
-- (Ada 2005): Register a predefined primitive in all the secondary
-- dispatch tables of its primitive type.
-------------------------------------------
-- Check_Overriding_Inherited_Interfaces --
-------------------------------------------
......@@ -4090,11 +4162,18 @@ package body Exp_Ch6 is
-- Get the entity associated with this primitive operation
Typ := Scope (DTC_Entity (E));
while Etype (Typ) /= Typ loop
loop
exit when Etype (Typ) = Typ
or else (Present (Full_View (Etype (Typ)))
and then Full_View (Etype (Typ)) = Typ);
-- Climb to the immediate ancestor
-- Climb to the immediate ancestor handling private types
Typ := Etype (Typ);
if Present (Full_View (Etype (Typ))) then
Typ := Full_View (Etype (Typ));
else
Typ := Etype (Typ);
end if;
if Present (Abstract_Interfaces (Typ)) then
......@@ -4192,35 +4271,40 @@ package body Exp_Ch6 is
if not Present (Ancestor_Iface_Prim) then
Prim_Typ := Scope (DTC_Entity (Alias (Prim)));
Iface_Typ := Scope (DTC_Entity (Abstract_Interface_Alias (Prim)));
Iface_Tag := Find_Interface_Tag
(T => Prim_Typ,
Iface => Iface_Typ);
-- Generate the code of the thunk only when this primitive
-- operation is associated with a secondary dispatch table.
if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then
Thunk_Id := Make_Defining_Identifier (Loc,
New_Internal_Name ('T'));
New_Thunk :=
Expand_Interface_Thunk
(N => Prim,
Thunk_Alias => Alias (Prim),
Thunk_Id => Thunk_Id,
Thunk_Tag => Iface_Tag);
Insert_After (N, New_Thunk);
Iface_DT_Ptr :=
Find_Interface_ADT
(T => Prim_Typ,
Iface => Iface_Typ);
Insert_After (New_Thunk,
Fill_Secondary_DT_Entry (Sloc (Prim),
Prim => Prim,
Iface_DT_Ptr => Iface_DT_Ptr,
Thunk_Id => Thunk_Id));
if Is_Interface (Iface_Typ) then
Iface_Tag := Find_Interface_Tag
(T => Prim_Typ,
Iface => Iface_Typ);
if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then
Thunk_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('T'));
New_Thunk :=
Expand_Interface_Thunk
(N => Prim,
Thunk_Alias => Alias (Prim),
Thunk_Id => Thunk_Id,
Thunk_Tag => Iface_Tag);
Insert_After (N, New_Thunk);
Iface_DT_Ptr :=
Find_Interface_ADT
(T => Prim_Typ,
Iface => Iface_Typ);
Insert_After (New_Thunk,
Fill_Secondary_DT_Entry (Sloc (Prim),
Prim => Prim,
Iface_DT_Ptr => Iface_DT_Ptr,
Thunk_Id => Thunk_Id));
end if;
end if;
else
......@@ -4243,8 +4327,9 @@ package body Exp_Ch6 is
-- type T is new I with ...
if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then
Thunk_Id := Make_Defining_Identifier (Loc,
New_Internal_Name ('T'));
Thunk_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('T'));
if Present (Alias (Prim)) then
Prim_Op := Alias (Prim);
......@@ -4275,6 +4360,70 @@ package body Exp_Ch6 is
end if;
end Register_Interface_DT_Entry;
----------------------------------
-- Register_Predefined_DT_Entry --
----------------------------------
procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is
Iface_DT_Ptr : Elmt_Id;
Iface_Tag : Entity_Id;
Iface_Typ : Elmt_Id;
New_Thunk : Entity_Id;
Prim_Typ : Entity_Id;
Thunk_Id : Entity_Id;
begin
Prim_Typ := Scope (DTC_Entity (Prim));
if not Present (Access_Disp_Table (Prim_Typ))
or else not Present (Abstract_Interfaces (Prim_Typ))
then
return;
end if;
-- Skip the first acces-to-dispatch-table pointer since it leads
-- to the primary dispatch table. We are only concerned with the
-- secondary dispatch table pointers. Note that the access-to-
-- dispatch-table pointer corresponds to the first implemented
-- interface retrieved below.
Iface_DT_Ptr := Next_Elmt (First_Elmt (Access_Disp_Table (Prim_Typ)));
Iface_Typ := First_Elmt (Abstract_Interfaces (Prim_Typ));
while Present (Iface_DT_Ptr) and then Present (Iface_Typ) loop
Iface_Tag := Find_Interface_Tag (Prim_Typ, Node (Iface_Typ));
pragma Assert (Present (Iface_Tag));
if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then
Thunk_Id := Make_Defining_Identifier (Loc,
New_Internal_Name ('T'));
New_Thunk :=
Expand_Interface_Thunk
(N => Prim,
Thunk_Alias => Prim,
Thunk_Id => Thunk_Id,
Thunk_Tag => Iface_Tag);
Insert_After (N, New_Thunk);
Insert_After (New_Thunk,
Make_DT_Access_Action (Node (Iface_Typ),
Action => Set_Prim_Op_Address,
Args => New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Node (Iface_DT_Ptr), Loc)),
Make_Integer_Literal (Loc, DT_Position (Prim)),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Address))));
end if;
Next_Elmt (Iface_DT_Ptr);
Next_Elmt (Iface_Typ);
end loop;
end Register_Predefined_DT_Entry;
-- Start of processing for Freeze_Subprogram
begin
......@@ -4297,19 +4446,38 @@ package body Exp_Ch6 is
Fill_DT_Entry (Sloc (N), Prim => E));
else
-- Ada 2005 (AI-251): Check if this entry corresponds with
-- a subprogram that covers an abstract interface type.
declare
Typ : constant Entity_Id := Scope (DTC_Entity (E));
if Present (Abstract_Interface_Alias (E)) then
Register_Interface_DT_Entry (E);
begin
-- There is no dispatch table associated with abstract
-- interface types; each type implementing interfaces
-- will fill the associated secondary DT entries.
-- Common case: Primitive subprogram
if not Is_Interface (Typ)
or else Present (Alias (E))
then
-- Ada 2005 (AI-251): Check if this entry corresponds with
-- a subprogram that covers an abstract interface type.
else
Insert_After (N,
Fill_DT_Entry (Sloc (N), Prim => E));
Check_Overriding_Inherited_Interfaces (E);
end if;
if Present (Abstract_Interface_Alias (E)) then
Register_Interface_DT_Entry (E);
-- Common case: Primitive subprogram
else
-- Generate thunks for all the predefined operations
if Is_Predefined_Dispatching_Operation (E) then
Register_Predefined_DT_Entry (E);
end if;
Insert_After (N,
Fill_DT_Entry (Sloc (N), Prim => E));
Check_Overriding_Inherited_Interfaces (E);
end if;
end if;
end;
end if;
end if;
......
gcc/ada/exp_ch7.adb
......@@ -1793,6 +1793,13 @@ package body Exp_Ch7 is
return The_Parent;
end if;
-- A raise statement can be wrapped. This will arise when the
-- expression in a raise_with_expression uses the secondary
-- stack, for example.
when N_Raise_Statement =>
return The_Parent;
-- If the expression is within the iteration scheme of a loop,
-- we must create a declaration for it, followed by an assignment
-- in order to have a usable statement to wrap.
......@@ -2728,13 +2735,27 @@ package body Exp_Ch7 is
Utyp := Underlying_Type (Base_Type (Utyp));
Set_Assignment_OK (Cref);
-- Deal with non-tagged derivation of private views
-- Deal with non-tagged derivation of private views. If the parent is
-- now known to be protected, the finalization routine is the one
-- defined on the corresponding record of the ancestor (corresponding
-- records do not automatically inherit operations, but maybe they
-- should???)
if Is_Untagged_Derivation (Typ) then
Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
if Is_Protected_Type (Typ) then
Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
else
Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
end if;
Cref := Unchecked_Convert_To (Utyp, Cref);
-- We need to set Assignment_OK to prevent problems with unchecked
-- conversions, where we do not want them to be converted back in the
-- case of untagged record derivation (see code in Make_*_Call
-- procedures for similar situations).
Set_Assignment_OK (Cref);
-- To prevent problems with UC see 1.156 RH ???
end if;
-- If the underlying_type is a subtype, we are dealing with
......
gcc/ada/exp_ch9.adb
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/exp_ch9.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -311,13 +311,21 @@ package Exp_Ch9 is
-- protected type.
procedure Set_Privals
(Dec : Node_Id;
Op : Node_Id;
Loc : Source_Ptr);
(Dec : Node_Id;
Op : Node_Id;
Loc : Source_Ptr;
After_Barrier : Boolean := False);
-- Associates a new set of privals (placeholders for later access to
-- private components of protected objects) with the private object
-- declarations of a protected object. These will be used to expand
-- the references to private objects in the next protected
-- subprogram or entry body to be expanded.
--
-- The flag After_Barrier indicates whether this is called after building
-- the barrier function for an entry body. This flag determines whether
-- the privals should have source names (which simplifies debugging) or
-- internally generated names. Entry barriers contain no debuggable code,
-- and there may be visibility conflicts between an entry index and a
-- a prival, so privals for barrier function have internal names.
end Exp_Ch9;
gcc/ada/exp_dbug.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1996-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -134,7 +134,7 @@ package body Exp_Dbug is
-- used to determine whether encoding is required for a discrete type.
procedure Output_Homonym_Numbers_Suffix;
-- If homonym numbers are stored, then output them into Name_Buffer.
-- If homonym numbers are stored, then output them into Name_Buffer
procedure Prepend_String_To_Buffer (S : String);
-- Prepend given string to the contents of the string buffer, updating
......@@ -250,9 +250,9 @@ package body Exp_Dbug is
then
return True;
-- Here we check if the static bounds match the natural size, which
-- is the size passed through with the debugging information. This
-- is the Esize rounded up to 8, 16, 32 or 64 as appropriate.
-- Here we check if the static bounds match the natural size, which is
-- the size passed through with the debugging information. This is the
-- Esize rounded up to 8, 16, 32 or 64 as appropriate.
else
declare
......@@ -305,12 +305,12 @@ package body Exp_Dbug is
Def : Entity_Id;
function Output_Subscript (N : Node_Id; S : String) return Boolean;
-- Outputs a single subscript value as ?nnn (subscript is compile
-- time known value with value nnn) or as ?e (subscript is local
-- constant with name e), where S supplies the proper string to
-- use for ?. Returns False if the subscript is not of an appropriate
-- type to output in one of these two forms. The result is prepended
-- to the name stored in Name_Buffer.
-- Outputs a single subscript value as ?nnn (subscript is compile time
-- known value with value nnn) or as ?e (subscript is local constant
-- with name e), where S supplies the proper string to use for ?.
-- Returns False if the subscript is not of an appropriate type to
-- output in one of these two forms. The result is prepended to the
-- name stored in Name_Buffer.
----------------------
-- Output_Subscript --
......@@ -358,9 +358,9 @@ package body Exp_Dbug is
when N_Package_Renaming_Declaration =>
Add_Str_To_Name_Buffer ("___XRP");
-- If it is a child unit create a fully qualified name,
-- to disambiguate multiple child units with the same
-- name and different parents.
-- If it is a child unit create a fully qualified name, to
-- disambiguate multiple child units with the same name and
-- different parents.
if Is_Child_Unit (Ent) then
Prepend_String_To_Buffer ("__");
......@@ -386,8 +386,8 @@ package body Exp_Dbug is
when N_Expanded_Name =>
-- The entity field for an N_Expanded_Name is on the
-- expanded name node itself, so we are done here too.
-- The entity field for an N_Expanded_Name is on the expanded
-- name node itself, so we are done here too.
exit;
......@@ -713,6 +713,7 @@ package body Exp_Dbug is
-- If this is a library level subprogram (i.e. a subprogram that is a
-- compilation unit other than a subunit), then we prepend _ada_ to
-- ensure distinctions required as described in the spec.
-- Check explicitly for child units, because those are not flagged
-- as Compilation_Units by lib. Should they be ???
......@@ -880,6 +881,39 @@ package body Exp_Dbug is
end if;
end Get_Variant_Encoding;
------------------------------------
-- Get_Secondary_DT_External_Name --
------------------------------------
procedure Get_Secondary_DT_External_Name
(Typ : Entity_Id;
Ancestor_Typ : Entity_Id;
Suffix_Index : Int) is
begin
Get_External_Name (Typ, Has_Suffix => False);
if Ancestor_Typ /= Typ then
declare
Len : constant Natural := Name_Len;
Save_Str : constant String (1 .. Name_Len)
:= Name_Buffer (1 .. Name_Len);
begin
Get_External_Name (Ancestor_Typ, Has_Suffix => False);
-- Append the extended name of the ancestor to the
-- extended name of Typ
Name_Buffer (Len + 2 .. Len + Name_Len + 1) :=
Name_Buffer (1 .. Name_Len);
Name_Buffer (1 .. Len) := Save_Str;
Name_Buffer (Len + 1) := '_';
Name_Len := Len + Name_Len + 1;
end;
end if;
Add_Nat_To_Name_Buffer (Suffix_Index);
end Get_Secondary_DT_External_Name;
---------------------------------
-- Make_Packed_Array_Type_Name --
---------------------------------
......@@ -1166,7 +1200,6 @@ package body Exp_Dbug is
else
Add_Char_To_Name_Buffer ('X');
end if;
end Set_BNPE_Suffix;
---------------------
......@@ -1338,7 +1371,6 @@ package body Exp_Dbug is
exit;
end if;
end loop;
end Strip_Suffixes;
end Exp_Dbug;
gcc/ada/exp_dbug.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1996-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1996-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -360,7 +360,7 @@ package Exp_Dbug is
-- Operations generated for protected entries follow the same encoding.
-- Each entry results in two suprograms: a procedure that holds the
-- entry body, and a function that holds the evaluation of the barrier.
-- The names of these subprograms include the prefix 'E' or 'B' res-
-- The names of these subprograms include the prefix '_E' or '_B' res-
-- pectively. The names also include a numeric suffix to render them
-- unique in the presence of overloaded entries.
......@@ -382,8 +382,8 @@ package Exp_Dbug is
-- lock_setN
-- lock_setP
-- lock_update1sE
-- lock_udpate2sB
-- lock_update_E1s
-- lock_udpate_B2s
-- If the protected type implements at least one interface, the
-- following additional operations are created:
......@@ -538,6 +538,12 @@ package Exp_Dbug is
-- field, and neither the outer structure name, nor the field name
-- should appear when the value is printed.
-- When the debugger sees a record named REP being a field inside
-- another record, it should treat the fields inside REP as being
-- part of the outer record (this REP field is only present for
-- code generation purposes). The REP record should not appear in
-- the values printed by the debugger.
-----------------------
-- Fixed-Point Types --
-----------------------
......@@ -1432,6 +1438,66 @@ package Exp_Dbug is
-- the second enumeration literal would be named QU43 and the
-- value assigned to it would be 1.
-----------------------------------------------
-- Secondary Dispatch tables of tagged types --
-----------------------------------------------
procedure Get_Secondary_DT_External_Name
(Typ : Entity_Id;
Ancestor_Typ : Entity_Id;
Suffix_Index : Int);
-- Set Name_Buffer and Name_Len to the external name of one secondary
-- dispatch table of Typ. If the interface has been inherited from some
-- ancestor then Ancestor_Typ is such node (in this case the secondary
-- DT is needed to handle overriden primitives); if there is no such
-- ancestor then Ancestor_Typ is equal to Typ.
--
-- Internal rule followed for the generation of the external name:
--
-- Case 1. If the secondary dispatch has not been inherited from some
-- ancestor of Typ then the external name is composed as
-- follows:
-- External_Name (Typ) + Suffix_Number + 'P'
--
-- Case 2. if the secondary dispatch table has been inherited from some
-- ancestor then the external name is composed as follows:
-- External_Name (Typ) + '_' + External_Name (Ancestor_Typ)
-- + Suffix_Number + 'P'
--
-- Note: We have to use the external names (instead of simply their
-- names) to protect the frontend against programs that give the same
-- name to all the interfaces and use the expanded name to reference
-- them. The Suffix_Number is used to differentiate all the secondary
-- dispatch tables of a given type.
--
-- Examples:
--
-- package Pkg1 is | package Pkg2 is | package Pkg3 is
-- type Typ is | type Typ is | type Typ is
-- interface; | interface; | interface;
-- end Pkg1; | end Pkg; | end Pkg3;
--
-- with Pkg1, Pkg2, Pkg3;
-- package Case_1 is
-- type Typ is new Pkg1.Typ and Pkg2.Typ and Pkg3.Typ with ...
-- end Case_1;
--
-- with Case_1;
-- package Case_2 is
-- type Typ is new Case_1.Typ with ...
-- end Case_2;
--
-- These are the external names generated for Case_1.Typ (note that
-- Pkg1.Typ is associated with the Primary Dispatch Table, because it
-- is the the parent of this type, and hence no external name is
-- generated for it).
-- case_1__typ0P (associated with Pkg2.Typ)
-- case_1__typ1P (associated with Pkg3.Typ)
--
-- These are the external names generated for Case_2.Typ:
-- case_2__typ_case_1__typ0P
-- case_2__typ_case_1__typ1P
----------------------------
-- Effect of Optimization --
----------------------------
......
gcc/ada/exp_disp.adb
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/exp_disp.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -28,8 +28,144 @@
-- dispatching expansion.
with Types; use Types;
package Exp_Disp is
-------------------------------------
-- Predefined primitive operations --
-------------------------------------
-- The predefined primitive operations (PPOs) are subprograms generated
-- by GNAT for a particular tagged type. Their role is to provide support
-- for different Ada language features such as the attribute 'Size or
-- handling of dispatching triggers in select statements. PPOs are created
-- when a tagged type is expanded or frozen. These subprograms are later
-- collected and inserted into the dispatch table of a tagged type at
-- fixed positions. Some of the PPOs that manipulate data in tagged objects
-- require the generation of thunks.
-- List of predefined primitive operations
-- Leading underscores designate reserved names. Bracketed numerical
-- values represent dispatch table slot numbers.
-- _Size (1) - implementation of the attribute 'Size for any tagged
-- type. Constructs of the form Prefix'Size are converted into
-- Prefix._Size.
-- _Alignment (2) - implementation of the attribute 'Alignment for
-- any tagged type. Constructs of the form Prefix'Alignment are
-- converted into Prefix._Alignment.
-- TSS_Stream_Read (3) - implementation of the stream attribute Read
-- for any tagged type.
-- TSS_Stream_Write (4) - implementation of the stream attribute Write
-- for any tagged type.
-- TSS_Stream_Input (5) - implementation of the stream attribute Input
-- for any tagged type.
-- TSS_Stream_Output (6) - implementation of the stream attribute
-- Output for any tagged type.
-- Op_Eq (7) - implementation of the equality operator for any non-
-- limited tagged type.
-- _Assign (8) - implementation of the assignment operator for any
-- non-limited tagged type.
-- TSS_Deep_Adjust (9) - implementation of the finalization operation
-- Adjust for any non-limited tagged type.
-- TSS_Deep_Finalize (10) - implementation of the finalization
-- operation Finalize for any non-limited tagged type.
-- _Disp_Asynchronous_Select (11) - used in the expansion of ATC with
-- dispatching triggers. Null implementation for limited interfaces,
-- full body generation for types that implement limited interfaces,
-- not generated for the rest of the cases. See Expand_N_Asynchronous_
-- Select in Exp_Ch9 for more information.
-- _Disp_Conditional_Select (12) - used in the expansion of conditional
-- selects with dispatching triggers. Null implementation for limited
-- interfaces, full body generation for types that implement limited
-- interfaces, not generated for the rest of the cases. See Expand_N_
-- Conditional_Entry_Call in Exp_Ch9 for more information.
-- _Disp_Get_Prim_Op_Kind (13) - helper routine used in the expansion
-- of ATC with dispatching triggers. Null implementation for limited
-- interfaces, full body generation for types that implement limited
-- interfaces, not generated for the rest of the cases.
-- _Disp_Get_Task_Id (14) - helper routine used in the expansion of
-- Abort, attributes 'Callable and 'Terminated for task interface
-- class-wide types. Full body generation for task types, null
-- implementation for limited interfaces, not generated for the rest
-- of the cases. See Expand_N_Attribute_Reference in Exp_Attr and
-- Expand_N_Abort_Statement in Exp_Ch9 for more information.
-- _Disp_Timed_Select (15) - used in the expansion of timed selects
-- with dispatching triggers. Null implementation for limited
-- interfaces, full body generation for types that implement limited
-- interfaces, not generated for the rest of the cases. See Expand_N_
-- Timed_Entry_Call for more information.
-- Lifecycle of predefined primitive operations
-- The specifications and bodies of the PPOs are created by
-- Make_Predefined_Primitive_Specs and Predefined_Primitive_Bodies
-- in Exp_Ch3. The generated specifications are immediately analyzed,
-- while the bodies are left as freeze actions to the tagged type for
-- which they are created.
-- PPOs are collected and added to the Primitive_Operations list of
-- a type by the regular analysis mechanism.
-- PPOs are frozen in Predefined_Primitive_Freeze in Exp_Ch3.
-- Thunks for PPOs are created in Freeze_Subprogram in Exp_Ch6, by a
-- call to Register_Predefined_DT_Entry, also in Exp_Ch6.
-- Dispatch table positions of PPOs are set in Set_All_DT_Position in
-- Exp_Disp.
-- Calls to PPOs procede as regular dispatching calls. If the PPO
-- has a thunk, a call procedes as a regular dispatching call with
-- a thunk.
-- Guidelines for addition of new predefined primitive operations
-- Update the value of constant Default_Prim_Op_Count in Exp_Disp.ads
-- to reflect the new number of PPOs.
-- Update the value of constant Default_Prim_Op_Count in A-Tags.ads
-- to reflect the new number of PPOs. This value should be the same
-- as the one in Exp_Disp.ads.
-- Introduce a new predefined name for the new PPO in Snames.ads and
-- Snames.adb.
-- Categorize the new PPO name as predefined by adding an entry in
-- Is_Predefined_Dispatching_Operation in Exp_Util.adb.
-- Reserve a dispatch table position for the new PPO by adding an entry
-- in Default_Prim_Op_Position in Exp_Disp.adb.
-- Generate the specification of the new PPO in Make_Predefined_
-- Primitive_Spec in Exp_Ch3.adb. The Is_Internal flag of the defining
-- identifier of the specification must be set to True.
-- Generate the body of the new PPO in Predefined_Primitive_Bodies in
-- Exp_Ch3.adb. The Is_Internal flag of the defining identifier of the
-- specification must be set to True.
-- If the new PPO requires a thunk, add an entry in Freeze_Subprogram
-- in Exp_Ch6.adb.
-- When generating calls to a PPO, use Find_Prim_Op from Exp_Util.ads
-- to retrieve the entity of the operation directly.
-- Number of predefined primitive operations added by the Expander
-- for a tagged type. If more predefined primitive operations are
-- added, the following items must be changed:
......@@ -38,7 +174,7 @@ package Exp_Disp is
-- Exp_Disp.Default_Prim_Op_Position - indirect use
-- Exp_Disp.Set_All_DT_Position - direct use
Default_Prim_Op_Count : constant Int := 14;
Default_Prim_Op_Count : constant Int := 15;
type DT_Access_Action is
(CW_Membership,
......@@ -48,6 +184,7 @@ package Exp_Disp is
Get_Access_Level,
Get_Entry_Index,
Get_External_Tag,
Get_Offset_Index,
Get_Prim_Op_Address,
Get_Prim_Op_Kind,
Get_RC_Offset,
......@@ -60,10 +197,13 @@ package Exp_Disp is
Set_Entry_Index,
Set_Expanded_Name,
Set_External_Tag,
Set_Offset_Index,
Set_OSD,
Set_Prim_Op_Address,
Set_Prim_Op_Kind,
Set_RC_Offset,
Set_Remotely_Callable,
Set_SSD,
Set_TSD,
TSD_Entry_Size,
TSD_Prologue_Size);
......@@ -117,16 +257,6 @@ package Exp_Disp is
-- Ada 2005 (AI-251): Initialize the entries associated with predefined
-- primitives in all the secondary dispatch tables of Typ.
procedure Make_Abstract_Interface_DT
(AI_Tag : Entity_Id;
Acc_Disp_Tables : in out Elist_Id;
Result : out List_Id);
-- Ada 2005 (AI-251): Expand the declarations for the secondary Dispatch
-- Tables corresponding with an abstract interface. The reference to the
-- dispatch table is appended at the end of Acc_Disp_Tables; it will be
-- are later used to generate the corresponding initialization statement
-- (see Exp_Ch3.Build_Init_Procedure).
function Make_DT_Access_Action
(Typ : Entity_Id;
Action : DT_Access_Action;
......@@ -141,7 +271,8 @@ package Exp_Disp is
function Make_Disp_Asynchronous_Select_Body
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the body of the primitive operation of type
-- Typ used for dispatching in asynchronous selects.
-- Typ used for dispatching in asynchronous selects. Generate a null body
-- if Typ is an interface type.
function Make_Disp_Asynchronous_Select_Spec
(Typ : Entity_Id) return Node_Id;
......@@ -151,7 +282,8 @@ package Exp_Disp is
function Make_Disp_Conditional_Select_Body
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the body of the primitive operation of type
-- Typ used for dispatching in conditional selects.
-- Typ used for dispatching in conditional selects. Generate a null body
-- if Typ is an interface type.
function Make_Disp_Conditional_Select_Spec
(Typ : Entity_Id) return Node_Id;
......@@ -162,7 +294,7 @@ package Exp_Disp is
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the body of the primitive operation of type
-- Typ used for retrieving the callable entity kind during dispatching in
-- asynchronous selects.
-- asynchronous selects. Generate a null body if Typ is an interface type.
function Make_Disp_Get_Prim_Op_Kind_Spec
(Typ : Entity_Id) return Node_Id;
......@@ -170,23 +302,52 @@ package Exp_Disp is
-- of the type Typ use for retrieving the callable entity kind during
-- dispatching in asynchronous selects.
function Make_Disp_Select_Tables
(Typ : Entity_Id) return List_Id;
-- Ada 2005 (AI-345): Populate the two auxiliary tables in the TSD of Typ
-- used for dispatching in asynchronous, conditional and timed selects.
-- Generate code to set the primitive operation kinds and entry indices
-- of primitive operations and primitive wrappers.
function Make_Disp_Get_Task_Id_Body
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the body of the primitive operation of type
-- Typ used for retrieving the _task_id field of a task interface class-
-- wide type. Generate a null body if Typ is an interface or a non-task
-- type.
function Make_Disp_Get_Task_Id_Spec
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the specification of the primitive operation
-- of type Typ used for retrieving the _task_id field of a task interface
-- class-wide type.
function Make_Disp_Timed_Select_Body
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the body of the primitive operation of type
-- Typ used for dispatching in timed selects.
-- Typ used for dispatching in timed selects. Generate a null body if Nul
-- is an interface type.
function Make_Disp_Timed_Select_Spec
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the specification of the primitive operation
-- of type Typ used for dispatching in timed selects.
function Make_Select_Specific_Data_Table
(Typ : Entity_Id) return List_Id;
-- Ada 2005 (AI-345): Create and populate the auxiliary table in the TSD
-- of Typ used for dispatching in asynchronous, conditional and timed
-- selects. Generate code to set the primitive operation kinds and entry
-- indices of primitive operations and primitive wrappers.
procedure Make_Secondary_DT
(Typ : Entity_Id;
Ancestor_Typ : Entity_Id;
Suffix_Index : Int;
Iface : Entity_Id;
AI_Tag : Entity_Id;
Acc_Disp_Tables : in out Elist_Id;
Result : out List_Id);
-- Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch
-- Table of Typ associated with Iface (each abstract interface implemented
-- by Typ has a secondary dispatch table). The arguments Typ, Ancestor_Typ
-- and Suffix_Index are used to generate an unique external name which
-- is added at the end of Acc_Disp_Tables; this external name will be
-- used later by the subprogram Exp_Ch3.Build_Init_Procedure.
procedure Set_All_DT_Position (Typ : Entity_Id);
-- Set the DT_Position field for each primitive operation. In the CPP
-- Class case check that no pragma CPP_Virtual is missing and that the
......
gcc/ada/exp_util.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -1275,6 +1275,16 @@ package body Exp_Util is
then
null;
-- Nothing to be done for derived types with unknown discriminants if
-- the parent type also has unknown discriminants.
elsif Is_Record_Type (Unc_Type)
and then not Is_Class_Wide_Type (Unc_Type)
and then Has_Unknown_Discriminants (Unc_Type)
and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
then
null;
-- Nothing to be done if the type of the expression is limited, because
-- in this case the expression cannot be copied, and its use can only
-- be by reference and there is no need for the actual subtype.
......@@ -1289,8 +1299,147 @@ package body Exp_Util is
end if;
end Expand_Subtype_From_Expr;
--------------------------------
-- Find_Implemented_Interface --
--------------------------------
-- Given the following code (XXX denotes irrelevant value):
-- type Limd_Iface is limited interface;
-- type Prot_Iface is protected interface;
-- type Sync_Iface is synchronized interface;
-- type Parent_Subtype is new Limd_Iface and Sync_Iface with ...
-- type Child_Subtype is new Parent_Subtype and Prot_Iface with ...
-- The following calls will return the following values:
-- Find_Implemented_Interface
-- (Child_Subtype, Synchronized_Interface, False) -> Empty
-- Find_Implemented_Interface
-- (Child_Subtype, Synchronized_Interface, True) -> Sync_Iface
-- Find_Implemented_Interface
-- (Child_Subtype, Any_Synchronized_Interface, XXX) -> Prot_Iface
-- Find_Implemented_Interface
-- (Child_Subtype, Any_Limited_Interface, XXX) -> Prot_Iface
function Find_Implemented_Interface
(Typ : Entity_Id;
Kind : Interface_Kind;
Check_Parent : Boolean := False) return Entity_Id
is
Iface_Elmt : Elmt_Id;
function Interface_In_Kind
(I : Entity_Id;
Kind : Interface_Kind) return Boolean;
-- Determine whether an interface falls into a specified kind
-----------------------
-- Interface_In_Kind --
-----------------------
function Interface_In_Kind
(I : Entity_Id;
Kind : Interface_Kind) return Boolean is
begin
if Is_Limited_Interface (I)
and then (Kind = Any_Interface
or else Kind = Any_Limited_Interface
or else Kind = Limited_Interface)
then
return True;
elsif Is_Protected_Interface (I)
and then (Kind = Any_Interface
or else Kind = Any_Limited_Interface
or else Kind = Any_Synchronized_Interface
or else Kind = Protected_Interface)
then
return True;
elsif Is_Synchronized_Interface (I)
and then (Kind = Any_Interface
or else Kind = Any_Limited_Interface
or else Kind = Synchronized_Interface)
then
return True;
elsif Is_Task_Interface (I)
and then (Kind = Any_Interface
or else Kind = Any_Limited_Interface
or else Kind = Any_Synchronized_Interface
or else Kind = Task_Interface)
then
return True;
-- Regular interface. This should be the last kind to check since
-- all of the previous cases have their Is_Interface flags set.
elsif Is_Interface (I)
and then (Kind = Any_Interface
or else Kind = Iface)
then
return True;
else
return False;
end if;
end Interface_In_Kind;
-- Start of processing for Find_Implemented_Interface
begin
if not Is_Tagged_Type (Typ) then
return Empty;
end if;
-- Implementations of the form:
-- Typ is new Interface ...
if Is_Interface (Etype (Typ))
and then Interface_In_Kind (Etype (Typ), Kind)
then
return Etype (Typ);
end if;
-- Implementations of the form:
-- Typ is new Typ_Parent and Interface ...
if Present (Abstract_Interfaces (Typ)) then
Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ));
while Present (Iface_Elmt) loop
if Interface_In_Kind (Node (Iface_Elmt), Kind) then
return Node (Iface_Elmt);
end if;
Iface_Elmt := Next_Elmt (Iface_Elmt);
end loop;
end if;
-- Typ is a derived type and may implement a limited interface
-- through its parent subtype. Check the parent subtype as well
-- as any interfaces explicitly implemented at this level.
if Check_Parent
and then Ekind (Typ) = E_Record_Type
and then Present (Parent_Subtype (Typ))
then
return Find_Implemented_Interface (
Parent_Subtype (Typ), Kind, Check_Parent);
end if;
-- Typ does not implement a limited interface either at this level or
-- in any of its parent subtypes.
return Empty;
end Find_Implemented_Interface;
------------------------
-- Find_Interface_Tag --
-- Find_Interface_ADT --
------------------------
function Find_Interface_ADT
......@@ -1302,7 +1451,7 @@ package body Exp_Util is
Typ : Entity_Id := T;
procedure Find_Secondary_Table (Typ : Entity_Id);
-- Comment required ???
-- Internal subprogram used to recursively climb to the ancestors
--------------------------
-- Find_Secondary_Table --
......@@ -1313,10 +1462,23 @@ package body Exp_Util is
AI : Node_Id;
begin
if Etype (Typ) /= Typ then
-- Climb to the ancestor (if any) handling private types
if Present (Full_View (Etype (Typ))) then
if Full_View (Etype (Typ)) /= Typ then
Find_Secondary_Table (Full_View (Etype (Typ)));
end if;
elsif Etype (Typ) /= Typ then
Find_Secondary_Table (Etype (Typ));
end if;
-- If we already found it there is nothing else to do
if Found then
return;
end if;
if Present (Abstract_Interfaces (Typ))
and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
then
......@@ -1401,9 +1563,14 @@ package body Exp_Util is
return;
end if;
-- Climb to the root type
-- Climb to the root type handling private types
if Present (Full_View (Etype (Typ))) then
if Full_View (Etype (Typ)) /= Typ then
Find_Tag (Full_View (Etype (Typ)));
end if;
if Etype (Typ) /= Typ then
elsif Etype (Typ) /= Typ then
Find_Tag (Etype (Typ));
end if;
......@@ -1437,6 +1604,8 @@ package body Exp_Util is
-- Start of processing for Find_Interface_Tag
begin
pragma Assert (Is_Interface (Iface));
-- Handle private types
if Has_Private_Declaration (Typ)
......@@ -1742,67 +1911,17 @@ package body Exp_Util is
return Count;
end Homonym_Number;
----------------------------------
-- Implements_Limited_Interface --
----------------------------------
function Implements_Limited_Interface (Typ : Entity_Id) return Boolean is
function Contains_Limited_Interface
(Ifaces : Elist_Id) return Boolean;
-- Given a list of interfaces, determine whether one of them is limited
--------------------------------
-- Contains_Limited_Interface --
--------------------------------
function Contains_Limited_Interface
(Ifaces : Elist_Id) return Boolean
is
Iface_Elmt : Elmt_Id;
begin
if not Present (Ifaces) then
return False;
end if;
Iface_Elmt := First_Elmt (Ifaces);
while Present (Iface_Elmt) loop
if Is_Limited_Record (Node (Iface_Elmt)) then
return True;
end if;
Iface_Elmt := Next_Elmt (Iface_Elmt);
end loop;
return False;
end Contains_Limited_Interface;
-- Start of processing for Implements_Limited_Interface
--------------------------
-- Implements_Interface --
--------------------------
function Implements_Interface
(Typ : Entity_Id;
Kind : Interface_Kind;
Check_Parent : Boolean := False) return Boolean is
begin
-- Typ is a derived type and may implement a limited interface
-- through its parent subtype. Check the parent subtype as well
-- as any interfaces explicitly implemented at this level.
if Ekind (Typ) = E_Record_Type
and then Present (Parent_Subtype (Typ))
then
return Contains_Limited_Interface (Abstract_Interfaces (Typ))
or else Implements_Limited_Interface (Parent_Subtype (Typ));
-- Typ is an abstract type derived from some interface
elsif Is_Abstract (Typ) then
return Is_Interface (Etype (Typ))
and then Is_Limited_Record (Etype (Typ));
-- Typ may directly implement some interface
else
return Contains_Limited_Interface (Abstract_Interfaces (Typ));
end if;
end Implements_Limited_Interface;
return Find_Implemented_Interface (Typ, Kind, Check_Parent) /= Empty;
end Implements_Interface;
------------------------------
-- In_Unconditional_Context --
......@@ -2436,7 +2555,6 @@ package body Exp_Util is
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Insert_Actions (Assoc_Node, Ins_Actions);
......@@ -2446,7 +2564,6 @@ package body Exp_Util is
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
begin
Scope_Suppress (Suppress) := True;
Insert_Actions (Assoc_Node, Ins_Actions);
......@@ -2557,12 +2674,12 @@ package body Exp_Util is
return True;
end Is_All_Null_Statements;
------------------------
-- Is_Default_Prim_Op --
------------------------
-----------------------------------------
-- Is_Predefined_Dispatching_Operation --
-----------------------------------------
function Is_Predefined_Dispatching_Operation
(Subp : Entity_Id) return Boolean
(Subp : Entity_Id) return Boolean
is
TSS_Name : TSS_Name_Type;
E : Entity_Id := Subp;
......@@ -2590,10 +2707,12 @@ package body Exp_Util is
or else Chars (E) = Name_uAssign
or else TSS_Name = TSS_Deep_Adjust
or else TSS_Name = TSS_Deep_Finalize
or else Chars (E) = Name_uDisp_Asynchronous_Select
or else Chars (E) = Name_uDisp_Conditional_Select
or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind
or else Chars (E) = Name_uDisp_Timed_Select
or else (Ada_Version >= Ada_05
and then (Chars (E) = Name_uDisp_Asynchronous_Select
or else Chars (E) = Name_uDisp_Conditional_Select
or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind
or else Chars (E) = Name_uDisp_Get_Task_Id
or else Chars (E) = Name_uDisp_Timed_Select))
then
return True;
end if;
......@@ -3466,7 +3585,7 @@ package body Exp_Util is
return New_Occurrence_Of (CW_Subtype, Loc);
end;
-- Comment needed (what case is this ???)
-- Indefinite record type with discriminants.
else
D := First_Discriminant (Unc_Typ);
......
gcc/ada/exp_util.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -33,6 +33,21 @@ with Types; use Types;
package Exp_Util is
-- An enumeration type used to capture all the possible interface
-- kinds and their hierarchical relation. These values are used in
-- Find_Implemented_Interface and Implements_Interface.
type Interface_Kind is (
Any_Interface, -- Any interface
Any_Limited_Interface, -- Only limited interfaces
Any_Synchronized_Interface, -- Only synchronized interfaces
Iface, -- Individual kinds
Limited_Interface,
Protected_Interface,
Synchronized_Interface,
Task_Interface);
-----------------------------------------------
-- Handling of Actions Associated with Nodes --
-----------------------------------------------
......@@ -325,17 +340,27 @@ package Exp_Util is
-- class-wide).
function Find_Interface_ADT
(T : Entity_Id;
Iface : Entity_Id) return Entity_Id;
(T : Entity_Id;
Iface : Entity_Id) return Entity_Id;
-- Ada 2005 (AI-251): Given a type T implementing the interface Iface,
-- return the Access_Disp_Table value of the interface.
function Find_Interface_Tag
(T : Entity_Id;
Iface : Entity_Id) return Entity_Id;
(T : Entity_Id;
Iface : Entity_Id) return Entity_Id;
-- Ada 2005 (AI-251): Given a type T implementing the interface Iface,
-- return the record component containing the tag of Iface.
function Find_Implemented_Interface
(Typ : Entity_Id;
Kind : Interface_Kind;
Check_Parent : Boolean := False) return Entity_Id;
-- Ada 2005 (AI-345): Find a designated kind of interface implemented by
-- Typ or any parent subtype. Return the first encountered interface that
-- correspond to the selected class. Return Empty if no such interface is
-- found. Use Check_Parent to climb a potential derivation chain and
-- examine the parent subtypes for any implementation.
function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id;
-- Find the first primitive operation of type T whose name is 'Name'.
-- This function allows the use of a primitive operation which is not
......@@ -410,11 +435,13 @@ package Exp_Util is
-- chain, counting only entries in the curren scope. If an entity is not
-- overloaded, the returned number will be one.
function Implements_Limited_Interface (Typ : Entity_Id) return Boolean;
-- Ada 2005 (AI-345): Determine whether Typ implements some limited
-- interface. The interface may be of limited, protected, synchronized
-- or taks kind. Typ may also be derived from a type that implements a
-- limited interface.
function Implements_Interface
(Typ : Entity_Id;
Kind : Interface_Kind;
Check_Parent : Boolean := False) return Boolean;
-- Ada 2005 (AI-345): Determine whether Typ implements a designated kind
-- of interface. Use Check_Parent to climb a potential derivation chain
-- and examine the parent subtypes for any implementation.
function Inside_Init_Proc return Boolean;
-- Returns True if current scope is within an init proc
......
gcc/ada/rtsfind.ads
......@@ -209,9 +209,14 @@ package Rtsfind is
System_Exp_Mod,
System_Exp_Uns,
System_Fat_Flt,
System_Fat_IEEE_Long_Float,
System_Fat_IEEE_Short_Float,
System_Fat_LFlt,
System_Fat_LLF,
System_Fat_SFlt,
System_Fat_VAX_D_Float,
System_Fat_VAX_F_Float,
System_Fat_VAX_G_Float,
System_Finalization_Implementation,
System_Finalization_Root,
System_Fore,
......@@ -493,6 +498,7 @@ package Rtsfind is
RE_Get_Access_Level, -- Ada.Tags
RE_Get_Entry_Index, -- Ada.Tags
RE_Get_External_Tag, -- Ada.Tags
RE_Get_Offset_Index, -- Ada.Tags
RE_Get_Prim_Op_Address, -- Ada.Tags
RE_Get_Prim_Op_Kind, -- Ada.Tags
RE_Get_RC_Offset, -- Ada.Tags
......@@ -501,25 +507,32 @@ package Rtsfind is
RE_Inherit_TSD, -- Ada.Tags
RE_Internal_Tag, -- Ada.Tags
RE_Is_Descendant_At_Same_Level, -- Ada.Tags
RE_Object_Specific_Data, -- Ada.Tags
RE_POK_Function, -- Ada.Tags
RE_POK_Procedure, -- Ada.Tags
RE_POK_Protected_Entry, -- Ada.Tags
RE_POK_Protected_Function, -- Ada.Tags
RE_POK_Protected_Procedure, -- Ada.Tags
RE_POK_Task_Entry, -- Ada.Tags
RE_POK_Task_Function, -- Ada.Tags
RE_POK_Task_Procedure, -- Ada.Tags
RE_Prim_Op_Kind, -- Ada.Tags
RE_Register_Interface_Tag, -- Ada.Tags
RE_Register_Tag, -- Ada.Tags
RE_Select_Specific_Data, -- Ada.Tags
RE_Set_Access_Level, -- Ada.Tags
RE_Set_Entry_Index, -- Ada.Tags
RE_Set_Expanded_Name, -- Ada.Tags
RE_Set_External_Tag, -- Ada.Tags
RE_Set_Num_Prim_Ops, -- Ada.Tags
RE_Set_Offset_Index, -- Ada.Tags
RE_Set_Offset_To_Top, -- Ada.Tags
RE_Set_OSD, -- Ada.Tags
RE_Set_Prim_Op_Address, -- Ada.Tags
RE_Set_Prim_Op_Kind, -- Ada.Tags
RE_Set_RC_Offset, -- Ada.Tags
RE_Set_Remotely_Callable, -- Ada.Tags
RE_Set_SSD, -- Ada.Tags
RE_Set_TSD, -- Ada.Tags
RE_Tag_Error, -- Ada.Tags
RE_TSD_Entry_Size, -- Ada.Tags
......@@ -527,6 +540,10 @@ package Rtsfind is
RE_Interface_Tag, -- Ada.Tags
RE_Tag, -- Ada.Tags
RE_Address_Array, -- Ada.Tags
RE_Valid_Signature, -- Ada.Tags
RE_Primary_DT, -- Ada.Tags
RE_Secondary_DT, -- Ada.Tags
RE_Abstract_Interface, -- Ada.Tags
RE_Abort_Task, -- Ada.Task_Identification
RE_Current_Task, -- Ada.Task_Identification
......@@ -666,13 +683,28 @@ package Rtsfind is
RE_Exp_Unsigned, -- System.Exp_Uns
RE_Fat_Float, -- System.Fat_Flt
RE_Attr_Float, -- System.Fat_Flt
RE_Fat_Long_Float, -- System.Fat_LFlt
RE_Attr_IEEE_Long, -- System.Fat_IEEE_Long_Float
RE_Fat_IEEE_Long, -- System.Fat_IEEE_Long_Float
RE_Fat_Long_Long_Float, -- System.Fat_LLF
RE_Attr_IEEE_Short, -- System.Fat_IEEE_Short_Float
RE_Fat_IEEE_Short, -- System.Fat_IEEE_Short_Float
RE_Fat_Short_Float, -- System.Fat_SFlt
RE_Attr_Long_Float, -- System.Fat_LFlt
RE_Attr_Long_Long_Float, -- System.Fat_LLF
RE_Attr_Short_Float, -- System.Fat_SFlt
RE_Attr_VAX_D_Float, -- System.Fat_VAX_D_Float
RE_Fat_VAX_D, -- System.Fat_VAX_D_Float
RE_Attr_VAX_F_Float, -- System.Fat_VAX_F_Float
RE_Fat_VAX_F, -- System.Fat_VAX_F_Float
RE_Attr_VAX_G_Float, -- System.Fat_VAX_G_Float
RE_Fat_VAX_G, -- System.Fat_VAX_G_Float
RE_Attach_To_Final_List, -- System.Finalization_Implementation
RE_Finalize_List, -- System.Finalization_Implementation
......@@ -1151,6 +1183,7 @@ package Rtsfind is
RE_TC_Alias, -- System.PolyORB_Interface
RE_TC_Build, -- System.PolyORB_Interface
RE_Get_TC, -- System.PolyORB_Interface
RE_Set_TC, -- System.PolyORB_Interface
RE_TC_Any, -- System.PolyORB_Interface
RE_TC_AD, -- System.PolyORB_Interface
......@@ -1219,6 +1252,7 @@ package Rtsfind is
RE_Integer_Address, -- System.Storage_Elements
RE_Storage_Offset, -- System.Storage_Elements
RE_Storage_Array, -- System.Storage_Elements
RE_Storage_Element, -- System.Storage_Elements
RE_To_Address, -- System.Storage_Elements
RE_Root_Storage_Pool, -- System.Storage_Pools
......@@ -1291,6 +1325,7 @@ package Rtsfind is
RE_Task_Procedure_Access, -- System.Tasking
RO_ST_Task_Id, -- System.Tasking
RO_ST_Null_Task, -- System.Tasking
RE_Call_Modes, -- System.Tasking
RE_Simple_Call, -- System.Tasking
......@@ -1417,6 +1452,8 @@ package Rtsfind is
RE_Le_G, -- System.Vax_Float_Operations
RE_Lt_F, -- System.Vax_Float_Operations
RE_Lt_G, -- System.Vax_Float_Operations
RE_Ne_F, -- System.Vax_Float_Operations
RE_Ne_G, -- System.Vax_Float_Operations
RE_Valid_D, -- System.Vax_Float_Operations
RE_Valid_F, -- System.Vax_Float_Operations
......@@ -1602,6 +1639,7 @@ package Rtsfind is
RE_Get_Access_Level => Ada_Tags,
RE_Get_Entry_Index => Ada_Tags,
RE_Get_External_Tag => Ada_Tags,
RE_Get_Offset_Index => Ada_Tags,
RE_Get_Prim_Op_Address => Ada_Tags,
RE_Get_Prim_Op_Kind => Ada_Tags,
RE_Get_RC_Offset => Ada_Tags,
......@@ -1610,25 +1648,32 @@ package Rtsfind is
RE_Inherit_TSD => Ada_Tags,
RE_Internal_Tag => Ada_Tags,
RE_Is_Descendant_At_Same_Level => Ada_Tags,
RE_Object_Specific_Data => Ada_Tags,
RE_POK_Function => Ada_Tags,
RE_POK_Procedure => Ada_Tags,
RE_POK_Protected_Entry => Ada_Tags,
RE_POK_Protected_Function => Ada_Tags,
RE_POK_Protected_Procedure => Ada_Tags,
RE_POK_Task_Entry => Ada_Tags,
RE_POK_Task_Function => Ada_Tags,
RE_POK_Task_Procedure => Ada_Tags,
RE_Prim_Op_Kind => Ada_Tags,
RE_Register_Interface_Tag => Ada_Tags,
RE_Register_Tag => Ada_Tags,
RE_Select_Specific_Data => Ada_Tags,
RE_Set_Access_Level => Ada_Tags,
RE_Set_Entry_Index => Ada_Tags,
RE_Set_Expanded_Name => Ada_Tags,
RE_Set_External_Tag => Ada_Tags,
RE_Set_Num_Prim_Ops => Ada_Tags,
RE_Set_Offset_Index => Ada_Tags,
RE_Set_Offset_To_Top => Ada_Tags,
RE_Set_OSD => Ada_Tags,
RE_Set_Prim_Op_Address => Ada_Tags,
RE_Set_Prim_Op_Kind => Ada_Tags,
RE_Set_RC_Offset => Ada_Tags,
RE_Set_Remotely_Callable => Ada_Tags,
RE_Set_SSD => Ada_Tags,
RE_Set_TSD => Ada_Tags,
RE_Tag_Error => Ada_Tags,
RE_TSD_Entry_Size => Ada_Tags,
......@@ -1636,6 +1681,10 @@ package Rtsfind is
RE_Interface_Tag => Ada_Tags,
RE_Tag => Ada_Tags,
RE_Address_Array => Ada_Tags,
RE_Valid_Signature => Ada_Tags,
RE_Primary_DT => Ada_Tags,
RE_Secondary_DT => Ada_Tags,
RE_Abstract_Interface => Ada_Tags,
RE_Abort_Task => Ada_Task_Identification,
RE_Current_Task => Ada_Task_Identification,
......@@ -1773,13 +1822,28 @@ package Rtsfind is
RE_Exp_Unsigned => System_Exp_Uns,
RE_Fat_Float => System_Fat_Flt,
RE_Attr_Float => System_Fat_Flt,
RE_Attr_IEEE_Long => System_Fat_IEEE_Long_Float,
RE_Fat_IEEE_Long => System_Fat_IEEE_Long_Float,
RE_Attr_IEEE_Short => System_Fat_IEEE_Short_Float,
RE_Fat_IEEE_Short => System_Fat_IEEE_Short_Float,
RE_Attr_Long_Float => System_Fat_LFlt,
RE_Attr_Long_Long_Float => System_Fat_LLF,
RE_Attr_Short_Float => System_Fat_SFlt,
RE_Fat_Long_Float => System_Fat_LFlt,
RE_Attr_VAX_D_Float => System_Fat_VAX_D_Float,
RE_Fat_VAX_D => System_Fat_VAX_D_Float,
RE_Fat_Long_Long_Float => System_Fat_LLF,
RE_Attr_VAX_F_Float => System_Fat_VAX_F_Float,
RE_Fat_VAX_F => System_Fat_VAX_F_Float,
RE_Fat_Short_Float => System_Fat_SFlt,
RE_Attr_VAX_G_Float => System_Fat_VAX_G_Float,
RE_Fat_VAX_G => System_Fat_VAX_G_Float,
RE_Attach_To_Final_List => System_Finalization_Implementation,
RE_Finalize_List => System_Finalization_Implementation,
......@@ -2249,6 +2313,7 @@ package Rtsfind is
RE_TC_Alias => System_PolyORB_Interface,
RE_TC_Build => System_PolyORB_Interface,
RE_Get_TC => System_PolyORB_Interface,
RE_Set_TC => System_PolyORB_Interface,
RE_TC_Any => System_PolyORB_Interface,
RE_TC_AD => System_PolyORB_Interface,
......@@ -2326,6 +2391,7 @@ package Rtsfind is
RE_Integer_Address => System_Storage_Elements,
RE_Storage_Offset => System_Storage_Elements,
RE_Storage_Array => System_Storage_Elements,
RE_Storage_Element => System_Storage_Elements,
RE_To_Address => System_Storage_Elements,
RE_Root_Storage_Pool => System_Storage_Pools,
......@@ -2397,6 +2463,7 @@ package Rtsfind is
RE_Task_Procedure_Access => System_Tasking,
RO_ST_Task_Id => System_Tasking,
RO_ST_Null_Task => System_Tasking,
RE_Call_Modes => System_Tasking,
RE_Simple_Call => System_Tasking,
......@@ -2523,6 +2590,8 @@ package Rtsfind is
RE_Le_G => System_Vax_Float_Operations,
RE_Lt_F => System_Vax_Float_Operations,
RE_Lt_G => System_Vax_Float_Operations,
RE_Ne_F => System_Vax_Float_Operations,
RE_Ne_G => System_Vax_Float_Operations,
RE_Valid_D => System_Vax_Float_Operations,
RE_Valid_F => System_Vax_Float_Operations,
......
gcc/ada/sem_ch9.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -28,7 +28,7 @@ with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Ch9;
with Exp_Ch9; use Exp_Ch9;
with Elists; use Elists;
with Freeze; use Freeze;
with Itypes; use Itypes;
......@@ -94,11 +94,22 @@ package body Sem_Ch9 is
while Present (T_Name) loop
Analyze (T_Name);
if not Is_Task_Type (Etype (T_Name)) then
Error_Msg_N ("expect task name for ABORT", T_Name);
return;
else
if Is_Task_Type (Etype (T_Name))
or else (Ada_Version >= Ada_05
and then Ekind (Etype (T_Name)) = E_Class_Wide_Type
and then Is_Interface (Etype (T_Name))
and then Is_Task_Interface (Etype (T_Name)))
then
Resolve (T_Name);
else
if Ada_Version >= Ada_05 then
Error_Msg_N ("expect task name or task interface class-wide "
& "object for ABORT", T_Name);
else
Error_Msg_N ("expect task name for ABORT", T_Name);
end if;
return;
end if;
Next (T_Name);
......@@ -298,9 +309,7 @@ package body Sem_Ch9 is
begin
E1 := First_Entity (Current_Scope);
while Present (E1) loop
if Ekind (E1) = E_Procedure
and then Chars (E1) = Chars (Entry_Nam)
and then Type_Conformant (E1, Entry_Nam)
......@@ -368,7 +377,6 @@ package body Sem_Ch9 is
begin
Decl := First (Declarations (N));
while Present (Decl) loop
Analyze (Decl);
......@@ -390,6 +398,7 @@ package body Sem_Ch9 is
-- In the case of a select alternative of a selective accept,
-- the expander references the address declaration even if there
-- is no statement list.
-- We also need to create the renaming declarations for the local
-- variables that will replace references to the formals within
-- the accept.
......@@ -440,14 +449,49 @@ package body Sem_Ch9 is
---------------------------------
procedure Analyze_Asynchronous_Select (N : Node_Id) is
Param : Node_Id;
Trigger : Node_Id;
begin
Tasking_Used := True;
Check_Restriction (Max_Asynchronous_Select_Nesting, N);
Check_Restriction (No_Select_Statements, N);
-- Analyze the statements. We analyze statements in the abortable part
-- first, because this is the section that is executed first, and that
-- way our remembering of saved values and checks is accurate.
if Ada_Version >= Ada_05 then
Trigger := Triggering_Statement (Triggering_Alternative (N));
Analyze (Trigger);
-- The trigger is a dispatching procedure. Postpone the analysis
-- of the triggering and abortable statements until the expansion
-- of this asynchronous select in Expand_N_Asynchronous_Select.
-- This action is required since the code replication in Expand-
-- _N_Asynchronous_Select of an already analyzed statement list
-- causes Gigi aborts.
if Expander_Active
and then Nkind (Trigger) = N_Procedure_Call_Statement
and then Present (Parameter_Associations (Trigger))
then
Param := First (Parameter_Associations (Trigger));
if Is_Controlling_Actual (Param)
and then Is_Interface (Etype (Param))
then
if Is_Limited_Record (Etype (Param)) then
return;
else
Error_Msg_N
("dispatching operation of limited or synchronized " &
"interface required ('R'M 9.7.2(3))!", N);
end if;
end if;
end if;
end if;
-- Analyze the statements. We analyze statements in the abortable part,
-- because this is the section that is executed first, and that way our
-- remembering of saved values and checks is accurate.
Analyze_Statements (Statements (Abortable_Part (N)));
Analyze (Triggering_Alternative (N));
......@@ -462,6 +506,16 @@ package body Sem_Ch9 is
Check_Restriction (No_Select_Statements, N);
Tasking_Used := True;
Analyze (Entry_Call_Alternative (N));
if List_Length (Else_Statements (N)) = 1
and then Nkind (First (Else_Statements (N))) in N_Delay_Statement
then
Error_Msg_N
("suspicious form of conditional entry call?", N);
Error_Msg_N
("\`SELECT OR` may be intended rather than `SELECT ELSE`", N);
end if;
Analyze_Statements (Else_Statements (N));
end Analyze_Conditional_Entry_Call;
......@@ -491,19 +545,19 @@ package body Sem_Ch9 is
if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
Pre_Analyze_And_Resolve (Expr, Standard_Duration);
else
Pre_Analyze_And_Resolve (Expr);
end if;
if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement and then
not Is_RTE (Base_Type (Etype (Expr)), RO_CA_Time) and then
not Is_RTE (Base_Type (Etype (Expr)), RO_RT_Time)
if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement
and then not Is_RTE (Base_Type (Etype (Expr)), RO_CA_Time)
and then not Is_RTE (Base_Type (Etype (Expr)), RO_RT_Time)
then
Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr);
end if;
Check_Restriction (No_Fixed_Point, Expr);
else
Analyze (Delay_Statement (N));
end if;
......@@ -632,7 +686,13 @@ package body Sem_Ch9 is
then
Set_Etype (Def, Empty);
Set_Analyzed (Def, False);
Set_Discrete_Subtype_Definition (Index_Spec, Def);
-- Keep the original subtree to ensure tree is
-- properly formed (e.g. for ASIS use)
Rewrite
(Discrete_Subtype_Definition (Index_Spec), Def);
Set_Analyzed (Low_Bound (Def), False);
Set_Analyzed (High_Bound (Def), False);
......@@ -683,12 +743,16 @@ package body Sem_Ch9 is
-- The entity for the protected subprogram corresponding to the entry
-- has been created. We retain the name of this entity in the entry
-- body, for use when the corresponding subprogram body is created.
-- Note that entry bodies have to corresponding_spec, and there is no
-- Note that entry bodies have no corresponding_spec, and there is no
-- easy link back in the tree between the entry body and the entity for
-- the entry itself.
-- the entry itself, which is why we must propagate some attributes
-- explicitly from spec to body.
Set_Protected_Body_Subprogram (Id,
Protected_Body_Subprogram (Entry_Name));
Set_Protected_Body_Subprogram
(Id, Protected_Body_Subprogram (Entry_Name));
Set_Entry_Parameters_Type
(Id, Entry_Parameters_Type (Entry_Name));
if Present (Decls) then
Analyze_Declarations (Decls);
......@@ -707,6 +771,9 @@ package body Sem_Ch9 is
-- At the same time, we set the flags on the spec entities to suppress
-- any warnings on the spec formals, since we also scan the spec.
-- Finally, we propagate the Entry_Component attribute to the body
-- formals, for use in the renaming declarations created later for the
-- formals (see exp_ch9.Add_Formal_Renamings).
declare
E1 : Entity_Id;
......@@ -736,6 +803,7 @@ package body Sem_Ch9 is
Set_Referenced (E2, Referenced (E1));
Set_Referenced (E1);
Set_Entry_Component (E2, Entry_Component (E1));
<<Continue>>
Next_Entity (E1);
......@@ -1011,9 +1079,7 @@ package body Sem_Ch9 is
end if;
E := First_Entity (Current_Scope);
while Present (E) loop
if Ekind (E) = E_Function
or else Ekind (E) = E_Procedure
then
......@@ -1072,8 +1138,9 @@ package body Sem_Ch9 is
-- Ada 2005 (AI-345)
if Present (Interface_List (N)) then
Iface := First (Interface_List (N));
Set_Is_Tagged_Type (T);
Iface := First (Interface_List (N));
while Present (Iface) loop
Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
Iface_Def := Type_Definition (Parent (Iface_Typ));
......@@ -1147,7 +1214,6 @@ package body Sem_Ch9 is
-- illegal uses. Now it can be set correctly.
E := First_Entity (Current_Scope);
while Present (E) loop
if Ekind (E) = E_Void then
Set_Ekind (E, E_Component);
......@@ -1254,14 +1320,13 @@ package body Sem_Ch9 is
-- Overloaded case, find right interpretation
if Is_Overloaded (Entry_Name) then
Get_First_Interp (Entry_Name, I, It);
Entry_Id := Empty;
Get_First_Interp (Entry_Name, I, It);
while Present (It.Nam) loop
if No (First_Formal (It.Nam))
or else Subtype_Conformant (Enclosing, It.Nam)
then
-- Ada 2005 (AI-345): Since protected and task types have
-- primitive entry wrappers, we only consider source entries.
......@@ -1348,9 +1413,10 @@ package body Sem_Ch9 is
-- Processing for parameters accessed by the requeue
declare
Ent : Entity_Id := First_Formal (Enclosing);
Ent : Entity_Id;
begin
Ent := First_Formal (Enclosing);
while Present (Ent) loop
-- For OUT or IN OUT parameter, the effect of the requeue
......@@ -1399,6 +1465,8 @@ package body Sem_Ch9 is
Check_Restriction (No_Select_Statements, N);
Tasking_Used := True;
-- Loop to analyze alternatives
Alt := First (Alts);
while Present (Alt) loop
Alt_Count := Alt_Count + 1;
......@@ -1716,7 +1784,6 @@ package body Sem_Ch9 is
begin
Ent := First_Entity (Spec_Id);
while Present (Ent) loop
if Is_Entry (Ent)
and then not Entry_Accepted (Ent)
......@@ -1799,6 +1866,8 @@ package body Sem_Ch9 is
-- Ada 2005 (AI-345)
if Present (Interface_List (N)) then
Set_Is_Tagged_Type (T);
Iface := First (Interface_List (N));
while Present (Iface) loop
Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
......@@ -1919,21 +1988,20 @@ package body Sem_Ch9 is
end if;
Analyze (Trigger);
if Comes_From_Source (Trigger)
and then Nkind (Trigger) /= N_Delay_Until_Statement
and then Nkind (Trigger) /= N_Delay_Relative_Statement
and then Nkind (Trigger) not in N_Delay_Statement
and then Nkind (Trigger) /= N_Entry_Call_Statement
then
if Ada_Version < Ada_05 then
Error_Msg_N
("triggering statement must be delay or entry call", Trigger);
-- Ada 2005 (AI-345): If a procedure_call_statement is used
-- for a procedure_or_entry_call, the procedure_name or pro-
-- cedure_prefix of the procedure_call_statement shall denote
-- an entry renamed by a procedure, or (a view of) a primitive
-- subprogram of a limited interface whose first parameter is
-- a controlling parameter.
-- Ada 2005 (AI-345): If a procedure_call_statement is used for a
-- procedure_or_entry_call, the procedure_name or pro- cedure_prefix
-- of the procedure_call_statement shall denote an entry renamed by a
-- procedure, or (a view of) a primitive subprogram of a limited
-- interface whose first parameter is a controlling parameter.
elsif Nkind (Trigger) = N_Procedure_Call_Statement
and then not Is_Renamed_Entry (Entity (Name (Trigger)))
......@@ -2089,7 +2157,6 @@ package body Sem_Ch9 is
begin
Ent := First (Ifaces);
while Present (Ent) loop
if Etype (Ent) = Iface then
return True;
......@@ -2119,14 +2186,13 @@ package body Sem_Ch9 is
Entry_Param := First (Entry_Params);
Proc_Param := Next (Proc_Param);
while Present (Entry_Param)
and then Present (Proc_Param)
loop
while Present (Entry_Param) and then Present (Proc_Param) loop
-- The two parameters must be mode conformant and have the exact
-- same types.
if In_Present (Entry_Param) /= In_Present (Proc_Param)
or else Out_Present (Entry_Param) /= Out_Present (Proc_Param)
if Ekind (Defining_Identifier (Entry_Param)) /=
Ekind (Defining_Identifier (Proc_Param))
or else Etype (Parameter_Type (Entry_Param)) /=
Etype (Parameter_Type (Proc_Param))
then
......@@ -2177,7 +2243,6 @@ package body Sem_Ch9 is
Null_Present (Parent (Hom)))
then
Aliased_Hom := Hom;
while Present (Alias (Aliased_Hom)) loop
Aliased_Hom := Alias (Aliased_Hom);
end loop;
......@@ -2274,7 +2339,6 @@ package body Sem_Ch9 is
else
Decl := First (Vis_Decls);
while Present (Decl) loop
if Nkind (Decl) = N_Entry_Declaration
and then Must_Override (Decl)
......@@ -2322,7 +2386,6 @@ package body Sem_Ch9 is
begin
E := First_Entity (Spec);
while Present (E) loop
Prev := Current_Entity (E);
Set_Current_Entity (E);
......
gcc/ada/snames.adb
......@@ -93,6 +93,7 @@ package body Snames is
"_disp_conditional_select#" &
"_disp_get_prim_op_kind#" &
"_disp_timed_select#" &
"_disp_get_task_id#" &
"initialize#" &
"adjust#" &
"finalize#" &
......@@ -458,6 +459,7 @@ package body Snames is
"machine_mantissa#" &
"machine_overflows#" &
"machine_radix#" &
"machine_rounding#" &
"machine_rounds#" &
"machine_size#" &
"mantissa#" &
......@@ -639,6 +641,7 @@ package body Snames is
"unchecked_conversion#" &
"unchecked_deallocation#" &
"to_pointer#" &
"free#" &
"abstract#" &
"aliased#" &
"protected#" &
......@@ -674,6 +677,7 @@ package body Snames is
"include_option#" &
"language_processing#" &
"languages#" &
"library_ali_dir#" &
"library_dir#" &
"library_auto_init#" &
"library_gcc#" &
......
gcc/ada/snames.ads
This source diff could not be displayed because it is too large. You can view the blob instead.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment