------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . T A G S --
-- --
with Ada.Exceptions;
with System.HTable;
+with System.Storage_Elements; use System.Storage_Elements;
pragma Elaborate_All (System.HTable);
-- +-------------------+
-- | Rec Ctrler offset |
-- +-------------------+
+-- | Num_Interfaces |
+-- +-------------------+
-- | table of |
-- : ancestor :
-- | tags |
+-- +-------------------+
+-- | table of |
+-- | interface |
+-- | tags |
-- +-------------------+
subtype Cstring is String (Positive);
-- We suppress index checks because the declared size in the record below
-- is a dummy size of one (see below).
- type Wide_Boolean is new Boolean;
- -- This name should probably be changed sometime ??? and indeed probably
- -- this field could simply be of type Standard.Boolean.
-
type Type_Specific_Data is record
- Idepth : Natural;
- Expanded_Name : Cstring_Ptr;
- External_Tag : Cstring_Ptr;
- HT_Link : Tag;
- Remotely_Callable : Wide_Boolean;
- RC_Offset : SSE.Storage_Offset;
- Ancestor_Tags : Tag_Table (0 .. 1);
+ Idepth : Natural;
+ Access_Level : Natural;
+ Expanded_Name : Cstring_Ptr;
+ External_Tag : Cstring_Ptr;
+ HT_Link : Tag;
+ Remotely_Callable : Boolean;
+ RC_Offset : SSE.Storage_Offset;
+ Num_Interfaces : Natural;
+ Tags_Table : Tag_Table (Natural);
+
+ -- The size of the Tags_Table array actually depends on the tagged type
+ -- to which it applies. The compiler ensures that has enough space to
+ -- store all the entries of the two tables phisically stored there: the
+ -- "table of ancestor tags" and the "table of interface tags". For this
+ -- purpose we are using the same mechanism as for the Prims_Ptr array in
+ -- the Dispatch_Table record. See comments below for more details.
+
end record;
- -- The size of the Ancestor_Tags array actually depends on the tagged type
- -- to which it applies. We are using the same mechanism as for the
- -- Prims_Ptr array in the Dispatch_Table record. See comments below for
- -- more details.
type Dispatch_Table is record
- -- Offset_To_Top : Integer := 0;
+ -- Offset_To_Top : Natural;
-- Typeinfo_Ptr : System.Address; -- Currently TSD is also here???
- Prims_Ptr : Address_Array (Positive);
+ Prims_Ptr : Address_Array (Positive);
end record;
-- Note on the commented out fields of the Dispatch_Table
- -- ------------------------------------------------------
+ --
-- According to the C++ ABI the components Offset_To_Top and Typeinfo_Ptr
-- are stored just "before" the dispatch table (that is, the Prims_Ptr
-- table), and they are referenced with negative offsets referring to the
-- expander generates a Prims_Ptr table that has enough space for these
-- additional components, and generates code that displaces the _Tag to
-- point after these components.
- -- -----------------------------------------------------------------------
-- 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
-- Unchecked Conversions for String Fields --
---------------------------------------------
- function To_Cstring_Ptr is
- new Unchecked_Conversion (System.Address, Cstring_Ptr);
-
function To_Address is
new Unchecked_Conversion (Cstring_Ptr, System.Address);
- -----------------------------------------------------------
- -- Unchecked Conversions for the component offset_to_top --
- -----------------------------------------------------------
+ function To_Cstring_Ptr is
+ new Unchecked_Conversion (System.Address, Cstring_Ptr);
+
+ ------------------------------------------------
+ -- Unchecked Conversions for other components --
+ ------------------------------------------------
- type Int_Ptr is access Integer;
+ type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset;
- function To_Int_Ptr is
- new Unchecked_Conversion (System.Address, Int_Ptr);
+ function To_Storage_Offset_Ptr is
+ new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
-----------------------
-- Local Subprograms --
-- Length of string represented by the given pointer (treating the string
-- as a C-style string, which is Nul terminated).
- function Offset_To_Top (T : Tag) return Integer;
+ function Offset_To_Top
+ (T : Tag) return System.Storage_Elements.Storage_Offset;
-- Returns the current value of the offset_to_top component available in
-- the prologue of the dispatch table.
-- Returns the current value of the typeinfo_ptr component available in
-- the prologue of the dispatch table.
- pragma Unreferenced (Offset_To_Top);
pragma Unreferenced (Typeinfo_Ptr);
-- These functions will be used for full compatibility with the C++ ABI
-- Obj in Typ'Class
- -- Each dispatch table contains a reference to a table of ancestors
- -- (Ancestor_Tags) and a count of the level of inheritance "Idepth" .
+ -- Each dispatch table contains a reference to a table of ancestors (stored
+ -- in the first part of the Tags_Table) and a count of the level of
+ -- inheritance "Idepth".
-- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
-- contained in the dispatch table referenced by Obj'Tag . Knowing the
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
Pos : constant Integer := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
begin
- return Pos >= 0 and then TSD (Obj_Tag).Ancestor_Tags (Pos) = Typ_Tag;
+ return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag;
end CW_Membership;
+ -------------------
+ -- IW_Membership --
+ -------------------
+
+ -- Canonical implementation of Classwide Membership corresponding to:
+
+ -- Obj in Iface'Class
+
+ -- Each dispatch table contains a table with the tags of all the
+ -- implemented interfaces.
+
+ -- 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;
+ Iface_Tag : Tag) return Boolean
+ is
+ T : constant Tag := To_Tag_Ptr (This).all;
+ Obj_Base : constant System.Address := This - Offset_To_Top (T);
+ T_Base : constant Tag := To_Tag_Ptr (Obj_Base).all;
+
+ Obj_TSD : constant Type_Specific_Data_Ptr := TSD (T_Base);
+ Last_Id : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces;
+ Id : Natural;
+
+ begin
+ if Obj_TSD.Num_Interfaces > 0 then
+ Id := Obj_TSD.Idepth + 1;
+ loop
+ if Obj_TSD.Tags_Table (Id) = Iface_Tag then
+ return True;
+ end if;
+
+ Id := Id + 1;
+ exit when Id > Last_Id;
+ end loop;
+ end if;
+
+ return False;
+ end IW_Membership;
+
+ --------------------
+ -- Descendant_Tag --
+ --------------------
+
+ function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
+ Int_Tag : constant Tag := Internal_Tag (External);
+
+ begin
+ if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
+ raise Tag_Error;
+ end if;
+
+ return Int_Tag;
+ end Descendant_Tag;
+
-------------------
-- Expanded_Name --
-------------------
function Expanded_Name (T : Tag) return String is
- Result : constant Cstring_Ptr := TSD (T).Expanded_Name;
+ Result : Cstring_Ptr;
+
begin
+ if T = No_Tag then
+ raise Tag_Error;
+ end if;
+
+ Result := TSD (T).Expanded_Name;
return Result (1 .. Length (Result));
end Expanded_Name;
------------------
function External_Tag (T : Tag) return String is
- Result : constant Cstring_Ptr := TSD (T).External_Tag;
+ Result : Cstring_Ptr;
begin
+ if T = No_Tag then
+ raise Tag_Error;
+ end if;
+
+ Result := TSD (T).External_Tag;
+
return Result (1 .. Length (Result));
end External_Tag;
+ ----------------------
+ -- Get_Access_Level --
+ ----------------------
+
+ function Get_Access_Level (T : Tag) return Natural is
+ begin
+ return TSD (T).Access_Level;
+ end Get_Access_Level;
+
----------------------
-- Get_External_Tag --
----------------------
function Get_Prim_Op_Address
(T : Tag;
- Position : Positive) return System.Address
- is
+ Position : Positive) return System.Address is
begin
return T.Prims_Ptr (Position);
end Get_Prim_Op_Address;
function Get_Remotely_Callable (T : Tag) return Boolean is
begin
- return TSD (T).Remotely_Callable = True;
+ return TSD (T).Remotely_Callable;
end Get_Remotely_Callable;
----------------
begin
if Old_Tag /= null then
- Old_TSD_Ptr := TSD (Old_Tag);
+ Old_TSD_Ptr := TSD (Old_Tag);
New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
- New_TSD_Ptr.Ancestor_Tags (1 .. New_TSD_Ptr.Idepth) :=
- Old_TSD_Ptr.Ancestor_Tags (0 .. Old_TSD_Ptr.Idepth);
+ New_TSD_Ptr.Num_Interfaces := Old_TSD_Ptr.Num_Interfaces;
+
+ -- Copy the "table of ancestor tags" plus the "table of interfaces"
+ -- of the parent
+
+ New_TSD_Ptr.Tags_Table
+ (1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces)
+ := Old_TSD_Ptr.Tags_Table
+ (0 .. Old_TSD_Ptr.Idepth + Old_TSD_Ptr.Num_Interfaces);
else
- New_TSD_Ptr.Idepth := 0;
+ New_TSD_Ptr.Idepth := 0;
+ New_TSD_Ptr.Num_Interfaces := 0;
end if;
- New_TSD_Ptr.Ancestor_Tags (0) := New_Tag;
+ New_TSD_Ptr.Tags_Table (0) := New_Tag;
end Inherit_TSD;
------------------
return Res;
end Internal_Tag;
+ ---------------------------------
+ -- Is_Descendant_At_Same_Level --
+ ---------------------------------
+
+ function Is_Descendant_At_Same_Level
+ (Descendant : Tag;
+ Ancestor : Tag) return Boolean
+ is
+ begin
+ return CW_Membership (Descendant, Ancestor)
+ and then TSD (Descendant).Access_Level = TSD (Ancestor).Access_Level;
+ end Is_Descendant_At_Same_Level;
+
------------
-- Length --
------------
return Len - 1;
end Length;
+ -------------------
+ -- Offset_To_Top --
+ -------------------
+
+ function Offset_To_Top
+ (T : Tag) return System.Storage_Elements.Storage_Offset
+ is
+ Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
+ 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;
+
-----------------
-- Parent_Size --
-----------------
(Obj : System.Address;
T : Tag) return SSE.Storage_Count
is
- Parent_Tag : constant Tag := TSD (T).Ancestor_Tags (1);
+ Parent_Tag : constant Tag := TSD (T).Tags_Table (1);
-- The tag of the parent type through the dispatch table
F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
-- Access to the _size primitive of the parent. We assume that
- -- it is always in the first slot of the distatch table
+ -- it is always in the first slot of the dispatch table
begin
-- Here we compute the size of the _parent field of the object
function Parent_Tag (T : Tag) return Tag is
begin
- return TSD (T).Ancestor_Tags (1);
+ if T = No_Tag then
+ raise Tag_Error;
+ end if;
+
+ -- 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
+ -- this case.
+
+ if TSD (T).Idepth = 0 then
+ return No_Tag;
+ else
+ return TSD (T).Tags_Table (1);
+ end if;
end Parent_Tag;
+ ----------------------------
+ -- Register_Interface_Tag --
+ ----------------------------
+
+ procedure Register_Interface_Tag
+ (T : Tag;
+ Interface_T : Tag)
+ is
+ New_T_TSD : constant Type_Specific_Data_Ptr := TSD (T);
+ Index : Natural;
+ begin
+ -- 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
+ + New_T_TSD.Num_Interfaces;
+ begin
+ loop
+ if New_T_TSD.Tags_Table (Id) = Interface_T then
+ return;
+ end if;
+
+ Id := Id + 1;
+ exit when Id > Last_Id;
+ end loop;
+ end;
+ end if;
+
+ New_T_TSD.Num_Interfaces := New_T_TSD.Num_Interfaces + 1;
+ Index := New_T_TSD.Idepth + New_T_TSD.Num_Interfaces;
+ New_T_TSD.Tags_Table (Index) := Interface_T;
+ end Register_Interface_Tag;
+
------------------
-- Register_Tag --
------------------
External_Tag_HTable.Set (T);
end Register_Tag;
+ ----------------------
+ -- Set_Access_Level --
+ ----------------------
+
+ procedure Set_Access_Level (T : Tag; Value : Natural) is
+ begin
+ TSD (T).Access_Level := Value;
+ end Set_Access_Level;
+
-----------------------
-- Set_Expanded_Name --
-----------------------
TSD (T).External_Tag := To_Cstring_Ptr (Value);
end Set_External_Tag;
+ -----------------------
+ -- Set_Offset_To_Top --
+ -----------------------
+
+ procedure Set_Offset_To_Top
+ (T : Tag;
+ Value : System.Storage_Elements.Storage_Offset)
+ is
+ Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
+ To_Storage_Offset_Ptr (To_Address (T)
+ - DT_Typeinfo_Ptr_Size
+ - DT_Offset_To_Top_Size);
+ begin
+ Offset_To_Top_Ptr.all := Value;
+ end Set_Offset_To_Top;
+
-------------------------
-- Set_Prim_Op_Address --
-------------------------
procedure Set_Prim_Op_Address
(T : Tag;
Position : Positive;
- Value : System.Address)
- is
+ Value : System.Address) is
begin
T.Prims_Ptr (Position) := Value;
end Set_Prim_Op_Address;
procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
begin
- if Value then
- TSD (T).Remotely_Callable := True;
- else
- TSD (T).Remotely_Callable := False;
- end if;
+ TSD (T).Remotely_Callable := Value;
end Set_Remotely_Callable;
-------------
-------------
procedure Set_TSD (T : Tag; Value : System.Address) is
- use type System.Storage_Elements.Storage_Offset;
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
begin
TSD_Ptr.all := Value;
end Set_TSD;
- -------------------
- -- Offset_To_Top --
- -------------------
-
- function Offset_To_Top (T : Tag) return Integer is
- use type System.Storage_Elements.Storage_Offset;
- TSD_Ptr : constant Int_Ptr :=
- To_Int_Ptr (To_Address (T) - DT_Prologue_Size);
- begin
- return TSD_Ptr.all;
- end Offset_To_Top;
-
------------------
-- Typeinfo_Ptr --
------------------
function Typeinfo_Ptr (T : Tag) return System.Address is
- use type System.Storage_Elements.Storage_Offset;
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
begin
---------
function TSD (T : Tag) return Type_Specific_Data_Ptr is
- use type System.Storage_Elements.Storage_Offset;
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
begin
with Unchecked_Conversion;
package Ada.Tags is
+pragma Preelaborate_05 (Tags);
+-- In accordance with Ada 2005 AI-362
pragma Elaborate_Body;
+ -- We need a dummy body to solve bootstrap path issues (why ???)
type Tag is private;
+ No_Tag : constant Tag;
+
function Expanded_Name (T : Tag) return String;
function External_Tag (T : Tag) return String;
function Internal_Tag (External : String) return Tag;
+ function Descendant_Tag (External : String; Ancestor : Tag) return Tag;
+
+ function Is_Descendant_At_Same_Level
+ (Descendant : Tag;
+ Ancestor : Tag) return Boolean;
+
+ function Parent_Tag (T : Tag) return Tag;
+
Tag_Error : exception;
private
type Dispatch_Table;
type Tag is access all Dispatch_Table;
+ type Interface_Tag is access all Dispatch_Table;
+
+ No_Tag : constant Tag := null;
type Type_Specific_Data;
type Type_Specific_Data_Ptr is access all Type_Specific_Data;
-- 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;
+ Iface_Tag : Tag) return Boolean;
+ -- Ada 2005 (AI-251): Given the tag of an object and the tag associated
+ -- with an interface, return true if Obj is in Iface'Class.
+
+ function Get_Access_Level (T : Tag) return Natural;
+ -- Given the tag associated with a type, returns the accessibility level
+ -- of the type.
+
function Get_External_Tag (T : Tag) return System.Address;
-- Retrieve the address of a null terminated string containing
-- the external name
-- Return the value previously set by Set_Remotely_Callable
procedure Inherit_DT
- (Old_T : Tag;
- New_T : Tag;
+ (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
pragma Export (Ada, Parent_Size, "ada__tags__parent_size");
-- This procedure is used in s-finimp and is thus exported manually
- function Parent_Tag (T : Tag) return Tag;
- -- Obj is the address of a tagged object. Parent_Tag fetch the tag of the
- -- immediate ancestor (parent) of the type associated with Obj.
-
- pragma Export (Ada, Parent_Tag, "ada__tags__parent_tag");
- -- This procedure is used in s-finimp and is thus exported manually
+ 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.
procedure Register_Tag (T : Tag);
-- Insert the Tag and its associated external_tag in a table for the
-- sake of Internal_Tag
+ procedure Set_Offset_To_Top
+ (T : Tag;
+ Value : System.Storage_Elements.Storage_Offset);
+ -- Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of
+ -- the dispatch table. In primary dispatch tables the value of this field
+ -- is always 0; in secondary dispatch tables this is the offset to the base
+ -- of the enclosing type.
+
procedure Set_Prim_Op_Address
(T : Tag;
Position : Positive;
-- Given a pointer T to a dispatch Table, stores the address of the record
-- containing the Type Specific Data generated by GNAT
+ procedure Set_Access_Level (T : Tag; Value : Natural);
+ -- Sets the accessibility level of the tagged type associated with T
+ -- in its TSD.
+
procedure Set_Expanded_Name (T : Tag; Value : System.Address);
-- Set the address of the string containing the expanded name
-- in the Dispatch table
(2 * (Standard'Address_Size / System.Storage_Unit));
-- Size of the first part of the dispatch table
+ DT_Offset_To_Top_Size : constant SSE.Storage_Count :=
+ SSE.Storage_Count
+ (Standard'Address_Size / System.Storage_Unit);
+ -- Size of the Offset_To_Top field of the Dispatch Table
+
DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(Standard'Address_Size / System.Storage_Unit);
- -- Size of the Typeinfo_Ptr field of the Dispatch Table.
+ -- Size of the Typeinfo_Ptr field of the Dispatch Table
DT_Entry_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(1 * (Standard'Address_Size / System.Storage_Unit));
- -- Size of each primitive operation entry in the Dispatch Table.
+ -- Size of each primitive operation entry in the Dispatch Table
TSD_Prologue_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
- (6 * Standard'Address_Size / System.Storage_Unit);
+ (8 * (Standard'Address_Size / System.Storage_Unit));
-- Size of the first part of the type specific data
TSD_Entry_Size : constant SSE.Storage_Count :=
-- of this type are declared with a dummy size of 1, the actual size
-- depending on the number of primitive operations.
+ -- Unchecked Conversions for Tag and TSD
+
function To_Type_Specific_Data_Ptr is
new Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
new Unchecked_Conversion (Tag, System.Address);
type Addr_Ptr is access System.Address;
+ type Tag_Ptr is access Tag;
function To_Addr_Ptr is
new Unchecked_Conversion (System.Address, Addr_Ptr);
+ function To_Tag_Ptr is
+ new Unchecked_Conversion (System.Address, Tag_Ptr);
+
-- Primitive dispatching operations are always inlined, to facilitate
-- use in a minimal/no run-time environment for high integrity use.
pragma Inline_Always (CW_Membership);
+ pragma Inline_Always (IW_Membership);
+ pragma Inline_Always (Get_Access_Level);
pragma Inline_Always (Get_Prim_Op_Address);
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 (Register_Interface_Tag);
pragma Inline_Always (Register_Tag);
+ pragma Inline_Always (Set_Access_Level);
pragma Inline_Always (Set_Expanded_Name);
pragma Inline_Always (Set_External_Tag);
+ pragma Inline_Always (Set_Offset_To_Top);
pragma Inline_Always (Set_Prim_Op_Address);
pragma Inline_Always (Set_RC_Offset);
pragma Inline_Always (Set_Remotely_Callable);
-- dW Disable warnings on calls for IN OUT parameters
-- dX Enable Frontend ZCX even when it is not supported
-- dY Enable configurable run-time mode
- -- dZ
+ -- dZ Generate listing showing the contents of the dispatch tables
-- d.a
-- d.b
-- --
-- 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- --
Rewrite (N, Conversion);
Analyze_And_Resolve (N, Typ);
end if;
+
+ -- Ada 2005 (AI-251): If the designated type is an interface,
+ -- then rewrite the referenced object as a conversion to force
+ -- the displacement of the pointer to the secondary dispatch
+ -- table.
+
+ elsif Is_Interface (Directly_Designated_Type (Btyp)) then
+ Conversion := Convert_To (Typ, New_Copy_Tree (Ref_Object));
+ Rewrite (N, Conversion);
+ Analyze_And_Resolve (N, Typ);
end if;
end;
-- Callable --
--------------
- -- Transforms 'Callable attribute into a call to the Callable function.
+ -- Transforms 'Callable attribute into a call to the Callable function
when Attribute_Callable => Callable :
begin
when Attribute_Constrained => Constrained : declare
Formal_Ent : constant Entity_Id := Param_Entity (Pref);
+ Typ : constant Entity_Id := Etype (Pref);
begin
-- Reference to a parameter where the value is passed as an extra
-- Prefix is not an entity name. These are also cases where
-- we can always tell at compile time by looking at the form
- -- and type of the prefix.
+ -- and type of the prefix. If an explicit dereference of an
+ -- object with constrained partial view, this is unconstrained
+ -- (Ada 2005 AI-363).
else
Rewrite (N,
New_Reference_To (
Boolean_Literals (
not Is_Variable (Pref)
- or else Nkind (Pref) = N_Explicit_Dereference
- or else Is_Constrained (Etype (Pref))),
+ or else
+ (Nkind (Pref) = N_Explicit_Dereference
+ and then
+ not Has_Constrained_Partial_View (Base_Type (Typ)))
+ or else Is_Constrained (Typ)),
Loc));
end if;
-- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
- -- in Ada.Task_Identification.
+ -- in Ada.Task_Identification
when Attribute_Identity => Identity : declare
Id_Kind : Entity_Id;
-- initialize a dummy tag object:
-- Dnn : Ada.Tags.Tag
- -- := Internal_Tag (String'Input (Strm));
+ -- := Descendant_Tag (String'Input (Strm), P_Type);
-- This dummy object is used only to provide a controlling
- -- argument for the eventual _Input call.
+ -- argument for the eventual _Input call. Descendant_Tag is
+ -- called rather than Internal_Tag to ensure that we have a
+ -- tag for a type that is descended from the prefix type and
+ -- declared at the same accessibility level (the exception
+ -- Tag_Error will be raised otherwise). The level check is
+ -- required for Ada 2005 because tagged types can be
+ -- extended in nested scopes (AI-344).
Dnn :=
Make_Defining_Identifier (Loc,
Expression =>
Make_Function_Call (Loc,
Name =>
- New_Occurrence_Of (RTE (RE_Internal_Tag), Loc),
+ New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
Attribute_Name => Name_Input,
Expressions => New_List (
Relocate_Node
- (Duplicate_Subexpr (Strm)))))));
+ (Duplicate_Subexpr (Strm)))),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (P_Type, Loc),
+ Attribute_Name => Name_Tag))));
Insert_Action (N, Decl);
-- Now we need to get the entity for the call, and construct
-- a function call node, where we preset a reference to Dnn
- -- as the controlling argument (doing an unchecked
- -- conversion to the class-wide tagged type to make it
- -- look like a real tagged object).
+ -- as the controlling argument (doing an unchecked convert
+ -- to the class-wide tagged type to make it look like a real
+ -- tagged object).
Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
Cntrl := Unchecked_Convert_To (P_Type,
elsif Is_Tagged_Type (U_Type) then
Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
- -- All other record type cases, including protected records.
- -- The latter only arise for expander generated code for
- -- handling shared passive partition access.
+ -- All other record type cases, including protected records. The
+ -- latter only arise for expander generated code for handling
+ -- shared passive partition access.
else
pragma Assert
end if;
end if;
- -- If we fall through, Fname is the function to be called. The
- -- result is obtained by calling the appropriate function, then
- -- converting the result. The conversion does a subtype check.
+ -- If we fall through, Fname is the function to be called. The result
+ -- is obtained by calling the appropriate function, then converting
+ -- the result. The conversion does a subtype check.
Call :=
Make_Function_Call (Loc,
-- function Leading_Part in Fat_xxx (where xxx is the root type)
-- Note: strictly, we should have special case code to deal with
- -- absurdly large positive arguments (greater than Integer'Last),
- -- which result in returning the first argument unchanged, but it
- -- hardly seems worth the effort. We raise constraint error for
- -- absurdly negative arguments which is fine.
+ -- absurdly large positive arguments (greater than Integer'Last), which
+ -- result in returning the first argument unchanged, but it hardly seems
+ -- worth the effort. We raise constraint error for absurdly negative
+ -- arguments which is fine.
when Attribute_Leading_Part =>
Expand_Fpt_Attribute_RI (N);
-- Mantissa --
--------------
- -- The only case that can get this far is the dynamic case of the
- -- old Ada 83 Mantissa attribute for the fixed-point case. For this
- -- case, we expand:
+ -- The only case that can get this far is the dynamic case of the old
+ -- Ada 83 Mantissa attribute for the fixed-point case. For this case, we
+ -- expand:
-- typ'Mantissa
-- a) The integer value is non-negative. In this case, it is
-- returned as the result (since it is less than the modulus).
- -- b) The integer value is negative. In this case, we know that
- -- the result is modulus + value, where the value might be as
- -- small as -modulus. The trouble is what type do we use to do
- -- this subtraction. No type will do, since modulus can be as
- -- big as 2**64, and no integer type accomodates this value.
- -- Let's do a bit of algebra
+ -- b) The integer value is negative. In this case, we know that the
+ -- result is modulus + value, where the value might be as small as
+ -- -modulus. The trouble is what type do we use to do the subtract.
+ -- No type will do, since modulus can be as big as 2**64, and no
+ -- integer type accomodates this value. Let's do bit of algebra
-- modulus + value
-- = modulus - (-value)
-- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
- -- where strmwrite is the given Write function that converts
- -- an argument of type sourcetyp or a type acctyp, from which
- -- it is derived to type strmtyp. The conversion to acttyp is
- -- required for the derived case.
+ -- where strmwrite is the given Write function that converts an
+ -- argument of type sourcetyp or a type acctyp, from which it is
+ -- derived to type strmtyp. The conversion to acttyp is required
+ -- for the derived case.
Prag := Get_Stream_Convert_Pragma (P_Type);
begin
-- The code is:
- -- String'Output (Strm, External_Tag (Item'Tag))
+ -- if Get_Access_Level (Item'Tag)
+ -- /= Get_Access_Level (P_Type'Tag)
+ -- then
+ -- raise Tag_Error;
+ -- end if;
+ -- String'Output (Strm, External_Tag (Item'Tag));
+
+ -- Ada 2005 (AI-344): Check that the accessibility level
+ -- of the type of the output object is not deeper than
+ -- that of the attribute's prefix type.
+
+ if Ada_Version >= Ada_05 then
+ Insert_Action (N,
+ Make_Implicit_If_Statement (N,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To
+ (RTE (RE_Get_Access_Level), Loc),
+ Parameter_Associations =>
+ New_List (Make_Attribute_Reference (Loc,
+ Prefix =>
+ Relocate_Node (
+ Duplicate_Subexpr (Item,
+ Name_Req => True)),
+ Attribute_Name =>
+ Name_Tag))),
+ Right_Opnd =>
+ Make_Integer_Literal
+ (Loc, Type_Access_Level (P_Type))),
+ Then_Statements =>
+ New_List (Make_Raise_Statement (Loc,
+ New_Occurrence_Of (
+ RTE (RE_Tag_Error), Loc)))));
+ end if;
Insert_Action (N,
Make_Attribute_Reference (Loc,
elsif Is_Tagged_Type (U_Type) then
Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
- -- All other record type cases, including protected records.
- -- The latter only arise for expander generated code for
- -- handling shared passive partition access.
+-- -- All other record type cases, including protected records.
+-- -- The latter only arise for expander generated code for
+-- -- handling shared passive partition access.
else
pragma Assert
-- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
- -- where strmread is the given Read function that converts
- -- an argument of type strmtyp to type sourcetyp or a type
- -- from which it is derived. The conversion to sourcetyp
- -- is required in the latter case.
+ -- where strmread is the given Read function that converts an
+ -- argument of type strmtyp to type sourcetyp or a type from which
+ -- it is derived. The conversion to sourcetyp is required in the
+ -- latter case.
-- A special case arises if Item is a type conversion in which
-- case, we have to expand to:
elsif Is_Tagged_Type (U_Type) then
Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
- -- All other record type cases, including protected records.
- -- The latter only arise for expander generated code for
- -- handling shared passive partition access.
+ -- All other record type cases, including protected records. The
+ -- latter only arise for expander generated code for handling
+ -- shared passive partition access.
else
pragma Assert
-- Round --
-----------
- -- The handling of the Round attribute is quite delicate. The
- -- processing in Sem_Attr introduced a conversion to universal
- -- real, reflecting the semantics of Round, but we do not want
- -- anything to do with universal real at runtime, since this
- -- corresponds to using floating-point arithmetic.
-
- -- What we have now is that the Etype of the Round attribute
- -- correctly indicates the final result type. The operand of
- -- the Round is the conversion to universal real, described
- -- above, and the operand of this conversion is the actual
- -- operand of Round, which may be the special case of a fixed
- -- point multiplication or division (Etype = universal fixed)
-
- -- The exapander will expand first the operand of the conversion,
- -- then the conversion, and finally the round attribute itself,
- -- since we always work inside out. But we cannot simply process
- -- naively in this order. In the semantic world where universal
- -- fixed and real really exist and have infinite precision, there
- -- is no problem, but in the implementation world, where universal
- -- real is a floating-point type, we would get the wrong result.
-
- -- So the approach is as follows. First, when expanding a multiply
- -- or divide whose type is universal fixed, we do nothing at all,
- -- instead deferring the operation till later.
+ -- The handling of the Round attribute is quite delicate. The processing
+ -- in Sem_Attr introduced a conversion to universal real, reflecting the
+ -- semantics of Round, but we do not want anything to do with universal
+ -- real at runtime, since this corresponds to using floating-point
+ -- arithmetic.
+
+ -- What we have now is that the Etype of the Round attribute correctly
+ -- indicates the final result type. The operand of the Round is the
+ -- conversion to universal real, described above, and the operand of
+ -- this conversion is the actual operand of Round, which may be the
+ -- special case of a fixed point multiplication or division (Etype =
+ -- universal fixed)
+
+ -- The exapander will expand first the operand of the conversion, then
+ -- the conversion, and finally the round attribute itself, since we
+ -- always work inside out. But we cannot simply process naively in this
+ -- order. In the semantic world where universal fixed and real really
+ -- exist and have infinite precision, there is no problem, but in the
+ -- implementation world, where universal real is a floating-point type,
+ -- we would get the wrong result.
+
+ -- So the approach is as follows. First, when expanding a multiply or
+ -- divide whose type is universal fixed, we do nothing at all, instead
+ -- deferring the operation till later.
-- The actual processing is done in Expand_N_Type_Conversion which
- -- handles the special case of Round by looking at its parent to
- -- see if it is a Round attribute, and if it is, handling the
- -- conversion (or its fixed multiply/divide child) in an appropriate
- -- manner.
+ -- handles the special case of Round by looking at its parent to see if
+ -- it is a Round attribute, and if it is, handling the conversion (or
+ -- its fixed multiply/divide child) in an appropriate manner.
-- This means that by the time we get to expanding the Round attribute
-- itself, the Round is nothing more than a type conversion (and will
Rewrite (Pref, New_Occurrence_Of (Etype (Pref), Loc));
end if;
- -- For a scalar type for which no size was
- -- explicitly given, VADS_Size means Object_Size. This is the
- -- other respect in which VADS_Size differs from Size.
+ -- For a scalar type for which no size was explicitly given,
+ -- VADS_Size means Object_Size. This is the other respect in
+ -- which VADS_Size differs from Size.
if Is_Scalar_Type (Etype (Pref))
and then No (Size_Clause (Etype (Pref)))
elsif Nkind (Pref) = N_Indexed_Component then
Siz := Component_Size (Etype (Prefix (Pref)));
- -- For a record component, we can do Size in the front end
- -- if there is a component clause, or if the record is packed
- -- and the component's size is known at compile time.
+ -- For a record component, we can do Size in the front end if there
+ -- is a component clause, or if the record is packed and the
+ -- component's size is known at compile time.
elsif Nkind (Pref) = N_Selected_Component then
declare
-- Terminated --
----------------
- -- Transforms 'Terminated attribute into a call to Terminated function.
+ -- Transforms 'Terminated attribute into a call to Terminated function
when Attribute_Terminated => Terminated :
begin
Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
-- For biased representations, we will be doing an unchecked
- -- conversion without unbiasing the result. That means that
- -- the range test has to take this into account, and the
- -- proper form of the test is:
+ -- conversion without unbiasing the result. That means that the range
+ -- test has to take this into account, and the proper form of the
+ -- test is:
-- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
-- Unsigned types. Note: it is safe to consider only whether the
-- subtype is unsigned, since we will in that case be doing all
- -- unsigned comparisons based on the subtype range. Since we use
- -- the actual subtype object size, this is appropriate.
+ -- unsigned comparisons based on the subtype range. Since we use the
+ -- actual subtype object size, this is appropriate.
-- For example, if we have
-- subtype x is integer range 1 .. 200;
-- for x'Object_Size use 8;
- -- Now the base type is signed, but objects of this type are 8
- -- bits unsigned, and doing an unsigned test of the range 1 to
- -- 200 is correct, even though a value greater than 127 looks
- -- signed to a signed comparison.
+ -- Now the base type is signed, but objects of this type are bits
+ -- unsigned, and doing an unsigned test of the range 1 to 200 is
+ -- correct, even though a value greater than 127 looks signed to a
+ -- signed comparison.
elsif Is_Unsigned_Type (Ptyp) then
if Esize (Ptyp) <= 32 then
-- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
- -- where strmwrite is the given Write function that converts
- -- an argument of type sourcetyp or a type acctyp, from which
- -- it is derived to type strmtyp. The conversion to acttyp is
- -- required for the derived case.
+ -- where strmwrite is the given Write function that converts an
+ -- argument of type sourcetyp or a type acctyp, from which it is
+ -- derived to type strmtyp. The conversion to acttyp is required
+ -- for the derived case.
Prag := Get_Stream_Convert_Pragma (P_Type);
Rewrite_Stream_Proc_Call (Pname);
end Write;
- -- Component_Size is handled by Gigi, unless the component size is
- -- known at compile time, which is always true in the packed array
- -- case. It is important that the packed array case is handled in
- -- the front end (see Eval_Attribute) since Gigi would otherwise
- -- get confused by the equivalent packed array type.
+ -- Component_Size is handled by Gigi, unless the component size is known
+ -- at compile time, which is always true in the packed array case. It is
+ -- important that the packed array case is handled in the front end (see
+ -- Eval_Attribute) since Gigi would otherwise get confused by the
+ -- equivalent packed array type.
when Attribute_Component_Size =>
null;
-- The following attributes are handled by Gigi (except that static
- -- cases have already been evaluated by the semantics, but in any
- -- case Gigi should not count on that).
+ -- cases have already been evaluated by the semantics, but in any case
+ -- Gigi should not count on that).
- -- In addition Gigi handles the non-floating-point cases of Pred
- -- and Succ (including the fixed-point cases, which can just be
- -- treated as integer increment/decrement operations)
+ -- In addition Gigi handles the non-floating-point cases of Pred and
+ -- Succ (including the fixed-point cases, which can just be treated as
+ -- integer increment/decrement operations)
-- Gigi also handles the non-class-wide cases of Size
function Find_Stream_Subprogram
(Typ : Entity_Id;
- Nam : TSS_Name_Type) return Entity_Id is
+ Nam : TSS_Name_Type) return Entity_Id
+ is
+ Ent : constant Entity_Id := TSS (Typ, Nam);
begin
+ if Present (Ent) then
+ return Ent;
+ end if;
+
if Is_Tagged_Type (Typ)
and then Is_Derived_Type (Typ)
then
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Attr; use Sem_Attr;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
procedure Check_Stream_Attributes (Typ : Entity_Id);
-- Check that if a limited extension has a parent with user-defined
- -- stream attributes, any limited component of the extension also has
- -- the corresponding user-defined stream attributes.
+ -- stream attributes, and does not itself have user-definer
+ -- stream-attributes, then any limited component of the extension also
+ -- has the corresponding user-defined stream attributes.
procedure Expand_Tagged_Root (T : Entity_Id);
-- Add a field _Tag at the beginning of the record. This field carries
Rec_Type : Entity_Id;
Set_Tag : Entity_Id := Empty;
+ ADT : Elmt_Id;
+ Aux_N : Node_Id;
+ Aux_Comp : Node_Id;
+
function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id;
-- Build a assignment statement node which assigns to record
-- component its default expression if defined. The left hand side
function Component_Needs_Simple_Initialization
(T : Entity_Id) return Boolean;
- -- Determines if a component needs simple initialization, given its
- -- type T. This is the same as Needs_Simple_Initialization except
- -- for the following difference: the types Tag and Vtable_Ptr, which
- -- are access types which would normally require simple initialization
- -- to null, do not require initialization as components, since they
- -- are explicitly initialized by other means.
+ -- Determines if a component needs simple initialization, given its type
+ -- T. This is the same as Needs_Simple_Initialization except for the
+ -- following difference: the types Tag, Interface_Tag, and Vtable_Ptr
+ -- which are access types which would normally require simple
+ -- initialization to null, do not require initialization as components,
+ -- since they are explicitly initialized by other means.
procedure Constrain_Array
(SI : Node_Id;
if not Is_CPP_Class (Etype (Rec_Type)) then
Prepend_To (Body_Stmts, Init_Tag);
+ -- Ada 2005 (AI-251): Initialization of all the tags
+ -- corresponding with abstract interfaces
+
+ if Present (First_Tag_Component (Rec_Type)) then
+
+ -- Skip the first _Tag, which is the main tag of the
+ -- tagged type. Following tags correspond with abstract
+ -- interfaces.
+
+ Aux_Comp :=
+ Next_Tag_Component (First_Tag_Component (Rec_Type));
+
+ ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Rec_Type)));
+ while Present (ADT) loop
+ Aux_N := Node (ADT);
+
+ -- Initialize the pointer to the secondary DT associated
+ -- with the interface
+
+ Append_To (Body_Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name =>
+ New_Reference_To (Aux_Comp, Loc)),
+ Expression =>
+ New_Reference_To (Aux_N, Loc)));
+
+ -- Generate:
+ -- Set_Offset_To_Top (DT_Ptr, n);
+
+ Append_To (Body_Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Set_Offset_To_Top),
+ Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (Aux_N, Loc)),
+ Unchecked_Convert_To (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc,
+ Name_uInit),
+ Selector_Name => New_Reference_To
+ (Aux_Comp, Loc)),
+ Attribute_Name => Name_Position)))));
+
+ Aux_Comp := Next_Tag_Component (Aux_Comp);
+ Next_Elmt (ADT);
+ end loop;
+ end if;
+
else
declare
Nod : Node_Id := First (Body_Stmts);
return
Needs_Simple_Initialization (T)
and then not Is_RTE (T, RE_Tag)
- and then not Is_RTE (T, RE_Vtable_Ptr);
+ and then not Is_RTE (T, RE_Vtable_Ptr)
+ and then not Is_RTE (T, RE_Interface_Tag); -- Ada 2005 (AI-251)
end Component_Needs_Simple_Initialization;
---------------------
-- 6. One or more components is a type that requires simple
-- initialization (see Needs_Simple_Initialization), except
- -- that types Tag and Vtable_Ptr are excluded, since fields
+ -- that types Tag and Interface_Tag are excluded, since fields
-- of these types are initialized by other means.
-- 7. The type is the record type built for a task type (since at
procedure Check_Stream_Attributes (Typ : Entity_Id) is
Comp : Entity_Id;
- Par : constant Entity_Id := Root_Type (Base_Type (Typ));
- Par_Read : constant Boolean := Present (TSS (Par, TSS_Stream_Read));
- Par_Write : constant Boolean := Present (TSS (Par, TSS_Stream_Write));
+ Par_Read : constant Boolean :=
+ Stream_Attribute_Available (Typ, TSS_Stream_Read)
+ and then not Has_Specified_Stream_Read (Typ);
+ Par_Write : constant Boolean :=
+ Stream_Attribute_Available (Typ, TSS_Stream_Write)
+ and then not Has_Specified_Stream_Write (Typ);
procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type);
-- Check that Comp has a user-specified Nam stream attribute
+ ----------------
+ -- Check_Attr --
+ ----------------
+
procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is
begin
- if No (TSS (Base_Type (Etype (Comp)), TSS_Nam)) then
+ if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then
Error_Msg_Name_1 := Nam;
Error_Msg_N
("|component& in limited extension must have% attribute", Comp);
end if;
end Check_Attr;
+ -- Start of processing for Check_Stream_Attributes
+
begin
if Par_Read or else Par_Write then
Comp := First_Component (Typ);
-- simple initialization expression in place. This special
-- initialization is required even though No_Init_Flag is present.
- elsif Needs_Simple_Initialization (Typ) then
+ -- An internally generated temporary needs no initialization because
+ -- it will be assigned subsequently. In particular, there is no
+ -- point in applying Initialize_Scalars to such a temporary.
+
+ elsif Needs_Simple_Initialization (Typ)
+ and then not Is_Internal (Def_Id)
+ then
Set_No_Initialization (N, False);
Set_Expression (N, Get_Simple_Init_Val (Typ, Loc, Esize (Def_Id)));
Analyze_And_Resolve (Expression (N), Typ);
end if;
+ -- Generate attribute for Persistent_BSS if needed
+
+ declare
+ Prag : Node_Id;
+ begin
+ if Persistent_BSS_Mode
+ and then Comes_From_Source (N)
+ and then Is_Potentially_Persistent_Type (Typ)
+ and then Is_Library_Level_Entity (Def_Id)
+ then
+ Prag :=
+ Make_Linker_Section_Pragma
+ (Def_Id, Sloc (N), ".persistent.bss");
+ Insert_After (N, Prag);
+ Analyze (Prag);
+ end if;
+ end;
+
-- Explicit initialization present
else
-- created in the C++ side and we just use it.
if Is_Tagged_Type (Def_Id) then
+
if Is_CPP_Class (Def_Id) then
Set_All_DT_Position (Def_Id);
Set_Default_Constructor (Def_Id);
Expand_Tagged_Root (Def_Id);
end if;
+ -- Build the secondary tables
+
+ if not Java_VM
+ and then Present (Abstract_Interfaces (Def_Id))
+ and then not Is_Empty_Elmt_List (Abstract_Interfaces (Def_Id))
+ then
+ declare
+ E : Entity_Id;
+ Result : List_Id;
+ ADT : Elist_Id := Access_Disp_Table (Def_Id);
+
+ begin
+ E := First_Entity (Def_Id);
+ while Present (E) loop
+ if Is_Tag (E) and then Chars (E) /= Name_uTag then
+ Make_Abstract_Interface_DT
+ (AI_Tag => E,
+ Acc_Disp_Tables => ADT,
+ Result => Result);
+
+ Append_Freeze_Actions (Def_Id, Result);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ Set_Access_Disp_Table (Def_Id, ADT);
+ end;
+ end if;
+
-- Unfreeze momentarily the type to add the predefined primitives
-- operations. The reason we unfreeze is so that these predefined
-- operations will indeed end up as primitive operations (which
-- Full type declarations are expanded at the point at which the type is
-- frozen. The formal N is the Freeze_Node for the type. Any statements or
-- declarations generated by the freezing (e.g. the procedure generated
- -- for initialization) are chained in the Acions field list of the freeze
+ -- for initialization) are chained in the Actions field list of the freeze
-- node using Append_Freeze_Actions.
function Freeze_Type (N : Node_Id) return Boolean is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
-with Exp_Disp; use Exp_Disp;
with Exp_Fixd; use Exp_Fixd;
with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss;
Expression => Node));
end if;
+ -- Ada 2005 (AI-344):
+ -- For an allocator with a class-wide designated type, generate an
+ -- accessibility check to verify that the level of the type of the
+ -- created object is not deeper than the level of the access type.
+ -- If the type of the qualified expression is class-wide, then
+ -- always generate the check. Otherwise, only generate the check
+ -- if the level of the qualified expression type is statically deeper
+ -- than the access type. Although the static accessibility will
+ -- generally have been performed as a legality check, it won't have
+ -- been done in cases where the allocator appears in a generic body,
+ -- so the run-time check is needed in general. (Not yet doing the
+ -- optimization to suppress the check for the static level case.???)
+
+ if Ada_Version >= Ada_05
+ and then Is_Class_Wide_Type (Designated_Type (PtrT))
+ then
+ Insert_Action (N,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Get_Access_Level), Loc),
+ Parameter_Associations =>
+ New_List (Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (Temp, Loc),
+ Attribute_Name =>
+ Name_Tag))),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Type_Access_Level (PtrT))),
+ Reason => PE_Accessibility_Check_Failed));
+ end if;
+
-- Suppress the tag assignment when Java_VM because JVM tags
-- are represented implicitly in objects.
New_Reference_To (First_Tag_Component (Left_Type), Loc));
if Is_Class_Wide_Type (Right_Type) then
- return
- Make_DT_Access_Action (Left_Type,
- Action => CW_Membership,
- Args => New_List (
- Obj_Tag,
- New_Reference_To
- (Node (First_Elmt
- (Access_Disp_Table (Root_Type (Right_Type)))),
- Loc)));
+
+ -- Ada 2005 (AI-251): Class-wide applied to interfaces
+
+ if Is_Interface (Etype (Class_Wide_Type (Right_Type))) then
+ return
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Obj_Tag,
+ Attribute_Name => Name_Address),
+ New_Reference_To (
+ Node (First_Elmt
+ (Access_Disp_Table (Root_Type (Right_Type)))),
+ Loc)));
+
+ -- Ada 95: Normal case
+
+ else
+ return
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc),
+ Parameter_Associations => New_List (
+ Obj_Tag,
+ New_Reference_To (
+ Node (First_Elmt
+ (Access_Disp_Table (Root_Type (Right_Type)))),
+ Loc)));
+ end if;
+
else
return
Make_Op_Eq (Loc,
- Left_Opnd => Obj_Tag,
- Right_Opnd =>
- New_Reference_To
- (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc));
+ Left_Opnd => Obj_Tag,
+ Right_Opnd =>
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc));
end if;
end Tagged_Membership;
Rewrite (Exp, Result_Exp);
Analyze_And_Resolve (Exp, Return_Type);
end if;
+
+ -- Ada 2005 (AI-344): If the result type is class-wide, then insert
+ -- a check that the level of the return expression's underlying type
+ -- is not deeper than the level of the master enclosing the function.
+
+ elsif Ada_Version >= Ada_05
+ and then Is_Class_Wide_Type (Return_Type)
+ then
+ Insert_Action (Exp,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To
+ (RTE (RE_Get_Access_Level), Loc),
+ Parameter_Associations =>
+ New_List (Make_Attribute_Reference (Loc,
+ Prefix =>
+ Duplicate_Subexpr (Exp),
+ Attribute_Name =>
+ Name_Tag))),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
+ Reason => PE_Accessibility_Check_Failed));
end if;
-- Deal with returning variable length objects and controlled types
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
+with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
-- representation as True. We assume that .FALSE. = False = 0.
-- What about functions that return a logical type ???
+ function Is_Legal_Copy return Boolean;
+ -- Check that an actual can be copied before generating the temporary
+ -- to be used in the call. If the actual is of a by_reference type then
+ -- the program is illegal (this can only happen in the presence of
+ -- rep. clauses that force an incorrect alignment). If the formal is
+ -- a by_reference parameter imposed by a DEC pragma, emit a warning to
+ -- the effect that this might lead to unaligned arguments.
+
function Make_Var (Actual : Node_Id) return Entity_Id;
-- Returns an entity that refers to the given actual parameter,
-- Actual (not including any type conversion). If Actual is an
Crep : Boolean;
begin
+ if not Is_Legal_Copy then
+ return;
+ end if;
+
Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
-- Use formal type for temp, unless formal type is an unconstrained
-- array, in which case we don't have to worry about bounds checks,
- -- and we use the actual type, since that has appropriate bonds.
+ -- and we use the actual type, since that has appropriate bounds.
if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
Indic := New_Occurrence_Of (Etype (Actual), Loc);
procedure Add_Simple_Call_By_Copy_Code is
Temp : Entity_Id;
+ Decl : Node_Id;
Incod : Node_Id;
Outcod : Node_Id;
Lhs : Node_Id;
F_Typ : constant Entity_Id := Etype (Formal);
begin
+ if not Is_Legal_Copy then
+ return;
+ end if;
+
-- Use formal type for temp, unless formal type is an unconstrained
-- array, in which case we don't have to worry about bounds checks,
- -- and we use the actual type, since that has appropriate bonds.
+ -- and we use the actual type, since that has appropriate bounds.
if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
Indic := New_Occurrence_Of (Etype (Actual), Loc);
Outcod := New_Copy_Tree (Incod);
-- Generate declaration of temporary variable, initializing it
- -- with the input parameter unless we have an OUT variable.
+ -- with the input parameter unless we have an OUT variable or
+ -- this is an initialization call.
if Ekind (Formal) = E_Out_Parameter then
Incod := Empty;
+
+ elsif Inside_Init_Proc then
+ if Nkind (Actual) /= N_Selected_Component
+ or else
+ not Has_Discriminant_Dependent_Constraint
+ (Entity (Selector_Name (Actual)))
+ then
+ Incod := Empty;
+
+ else
+ -- We need the component in order to generate the proper
+ -- actual subtype, that depends on enclosing discriminants.
+ -- What is the comment for, given code below is null ???
+
+ null;
+ end if;
end if;
- Insert_Action (N,
+ Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => Indic,
- Expression => Incod));
+ Expression => Incod);
+
+ if Inside_Init_Proc
+ and then No (Incod)
+ then
+ -- If the call is to initialize a component of a composite type,
+ -- and the component does not depend on discriminants, use the
+ -- actual type of the component. This is required in case the
+ -- component is constrained, because in general the formal of the
+ -- initialization procedure will be unconstrained. Note that if
+ -- the component being initialized is constrained by an enclosing
+ -- discriminant, the presence of the initialization in the
+ -- declaration will generate an expression for the actual subtype.
+
+ Set_No_Initialization (Decl);
+ Set_Object_Definition (Decl,
+ New_Occurrence_Of (Etype (Actual), Loc));
+ end if;
+
+ Insert_Action (N, Decl);
-- The actual is simply a reference to the temporary
end if;
end Check_Fortran_Logical;
+ -------------------
+ -- Is_Legal_Copy --
+ -------------------
+
+ function Is_Legal_Copy return Boolean is
+ begin
+ -- An attempt to copy a value of such a type can only occur if
+ -- representation clauses give the actual a misaligned address.
+
+ if Is_By_Reference_Type (Etype (Formal)) then
+ Error_Msg_N
+ ("misaligned actual cannot be passed by reference", Actual);
+ return False;
+
+ -- For users of Starlet, we assume that the specification of by-
+ -- reference mechanism is mandatory. This may lead to unligned
+ -- objects but at least for DEC legacy code it is known to work.
+ -- The warning will alert users of this code that a problem may
+ -- be lurking.
+
+ elsif Mechanism (Formal) = By_Reference
+ and then Is_Valued_Procedure (Scope (Formal))
+ then
+ Error_Msg_N
+ ("by_reference actual may be misaligned?", Actual);
+ return False;
+
+ else
+ return True;
+ end if;
+ end Is_Legal_Copy;
+
--------------
-- Make_Var --
--------------
Extra_Actuals : List_Id := No_List;
Cond : Node_Id;
+ CW_Interface_Formals_Present : Boolean := False;
+
procedure Add_Actual_Parameter (Insert_Param : Node_Id);
-- Adds one entry to the end of the actual parameter list. Used for
-- default parameters and for extra actuals (for Extra_Formals).
Prev := Actual;
Prev_Orig := Original_Node (Prev);
- -- Create possible extra actual for constrained case. Usually,
- -- the extra actual is of the form actual'constrained, but since
- -- this attribute is only available for unconstrained records,
- -- TRUE is expanded if the type of the formal happens to be
- -- constrained (for instance when this procedure is inherited
- -- from an unconstrained record to a constrained one) or if the
- -- actual has no discriminant (its type is constrained). An
- -- exception to this is the case of a private type without
- -- discriminants. In this case we pass FALSE because the
- -- object has underlying discriminants with defaults.
+ -- Ada 2005 (AI-251): Check if any formal is a class-wide interface
+ -- to expand it in a further round
+
+ CW_Interface_Formals_Present :=
+ CW_Interface_Formals_Present
+ or else
+ (Ekind (Etype (Formal)) = E_Class_Wide_Type
+ and then Is_Interface (Etype (Etype (Formal))))
+ or else
+ (Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+ and then Is_Interface (Directly_Designated_Type
+ (Etype (Etype (Formal)))));
+
+ -- Create possible extra actual for constrained case. Usually, the
+ -- extra actual is of the form actual'constrained, but since this
+ -- attribute is only available for unconstrained records, TRUE is
+ -- expanded if the type of the formal happens to be constrained (for
+ -- instance when this procedure is inherited from an unconstrained
+ -- record to a constrained one) or if the actual has no discriminant
+ -- (its type is constrained). An exception to this is the case of a
+ -- private type without discriminants. In this case we pass FALSE
+ -- because the object has underlying discriminants with defaults.
if Present (Extra_Constrained (Formal)) then
if Ekind (Etype (Prev)) in Private_Kind
end;
end if;
+ -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand
+ -- it to point to the correct secondary virtual table
+
+ if (Nkind (N) = N_Function_Call
+ or else Nkind (N) = N_Procedure_Call_Statement)
+ and then CW_Interface_Formals_Present
+ then
+ Expand_Interface_Actuals (N);
+ end if;
+
-- Deals with Dispatch_Call if we still have a call, before expanding
-- extra actuals since this will be done on the re-analysis of the
-- dispatching call. Note that we do not try to shorten the actual
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
+ Set_Is_Internal (Temp);
Decl :=
Make_Object_Declaration (Loc,
-- protected subprogram an associated formals. For a normal protected
-- operation, this is done when expanding the protected type declaration.
+ -- If the declaration is for a null procedure, emit null body
+
procedure Expand_N_Subprogram_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Subp : constant Entity_Id := Defining_Entity (N);
Set_Protected_Body_Subprogram (Subp, Prot_Id);
Pop_Scope;
end if;
+
+ elsif Nkind (Specification (N)) = N_Procedure_Specification
+ and then Null_Present (Specification (N))
+ then
+ declare
+ Bod : constant Node_Id :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ New_Copy_Tree (Specification (N)),
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Make_Null_Statement (Loc))));
+ begin
+ Set_Body_To_Inline (N, New_Copy_Tree (Bod));
+ Insert_After (N, Bod);
+ Analyze (Bod);
+ end;
end if;
end Expand_N_Subprogram_Declaration;
-----------------------
procedure Freeze_Subprogram (N : Node_Id) is
- E : constant Entity_Id := Entity (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ E : constant Entity_Id := Entity (N);
+ Thunk_Id : Entity_Id;
+ Iface_Tag : Entity_Id;
+ New_Thunk : Node_Id;
begin
-- When a primitive is frozen, enter its name in the corresponding
and then not Java_VM
then
Check_Overriding_Operation (E);
- Insert_After (N, Fill_DT_Entry (Sloc (N), E));
+
+ -- Common case: Primitive subprogram
+
+ if not Present (Abstract_Interface_Alias (E)) then
+ Insert_After (N, Fill_DT_Entry (Sloc (N), E));
+
+ -- Ada 2005 (AI-251): Primitive subprogram that covers an interface
+
+ else
+ Iface_Tag :=
+ Find_Interface_Tag
+ (T => Scope (DTC_Entity (Alias (E))), -- Formal Type
+ Iface => Scope (DTC_Entity (Abstract_Interface_Alias (E))));
+
+ -- Generate the thunk only if the associated tag is an interface
+ -- tag. The case in which the associated tag is the primary tag
+ -- occurs when a tagged type is a direct derivation of an
+ -- interface. For example:
+
+ -- type I is interface;
+ -- ...
+ -- 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'));
+
+ New_Thunk := Expand_Interface_Thunk (N, Thunk_Id, Iface_Tag);
+
+ Insert_After (New_Thunk,
+ Fill_DT_Entry (Sloc (N),
+ Prim => E,
+ Thunk_Id => Thunk_Id));
+ end if;
+ end if;
end if;
-- Mark functions that return by reference. Note that it cannot be
with Atree; use Atree;
with Checks; use Checks;
+with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
-with Fname; use Fname;
with Itypes; use Itypes;
-with Lib; use Lib;
with Nlists; use Nlists;
with Nmake; use Nmake;
+with Namet; use Namet;
with Opt; use Opt;
+with Output; use Output;
with Rtsfind; use Rtsfind;
+with Sem; use Sem;
with Sem_Disp; use Sem_Disp;
with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
with Uintp; use Uintp;
package body Exp_Disp is
Ada_Actions : constant array (DT_Access_Action) of RE_Id :=
(CW_Membership => RE_CW_Membership,
+ IW_Membership => RE_IW_Membership,
DT_Entry_Size => RE_DT_Entry_Size,
DT_Prologue_Size => RE_DT_Prologue_Size,
+ Get_Access_Level => RE_Get_Access_Level,
Get_External_Tag => RE_Get_External_Tag,
Get_Prim_Op_Address => RE_Get_Prim_Op_Address,
Get_RC_Offset => RE_Get_RC_Offset,
Get_Remotely_Callable => RE_Get_Remotely_Callable,
Inherit_DT => RE_Inherit_DT,
Inherit_TSD => RE_Inherit_TSD,
+ Register_Interface_Tag => RE_Register_Interface_Tag,
Register_Tag => RE_Register_Tag,
+ Set_Access_Level => RE_Set_Access_Level,
Set_Expanded_Name => RE_Set_Expanded_Name,
Set_External_Tag => RE_Set_External_Tag,
Set_Prim_Op_Address => RE_Set_Prim_Op_Address,
TSD_Entry_Size => RE_TSD_Entry_Size,
TSD_Prologue_Size => RE_TSD_Prologue_Size);
- CPP_Actions : constant array (DT_Access_Action) of RE_Id :=
- (CW_Membership => RE_CPP_CW_Membership,
- DT_Entry_Size => RE_CPP_DT_Entry_Size,
- DT_Prologue_Size => RE_CPP_DT_Prologue_Size,
- Get_External_Tag => RE_CPP_Get_External_Tag,
- Get_Prim_Op_Address => RE_CPP_Get_Prim_Op_Address,
- Get_RC_Offset => RE_CPP_Get_RC_Offset,
- Get_Remotely_Callable => RE_CPP_Get_Remotely_Callable,
- Inherit_DT => RE_CPP_Inherit_DT,
- Inherit_TSD => RE_CPP_Inherit_TSD,
- Register_Tag => RE_CPP_Register_Tag,
- Set_Expanded_Name => RE_CPP_Set_Expanded_Name,
- Set_External_Tag => RE_CPP_Set_External_Tag,
- Set_Prim_Op_Address => RE_CPP_Set_Prim_Op_Address,
- Set_RC_Offset => RE_CPP_Set_RC_Offset,
- Set_Remotely_Callable => RE_CPP_Set_Remotely_Callable,
- Set_TSD => RE_CPP_Set_TSD,
- TSD_Entry_Size => RE_CPP_TSD_Entry_Size,
- TSD_Prologue_Size => RE_CPP_TSD_Prologue_Size);
-
Action_Is_Proc : constant array (DT_Access_Action) of Boolean :=
(CW_Membership => False,
+ IW_Membership => False,
DT_Entry_Size => False,
DT_Prologue_Size => False,
+ Get_Access_Level => False,
Get_External_Tag => False,
Get_Prim_Op_Address => False,
Get_Remotely_Callable => False,
Get_RC_Offset => False,
Inherit_DT => True,
Inherit_TSD => True,
+ Register_Interface_Tag => True,
Register_Tag => True,
+ Set_Access_Level => True,
Set_Expanded_Name => True,
Set_External_Tag => True,
Set_Prim_Op_Address => True,
Action_Nb_Arg : constant array (DT_Access_Action) of Int :=
(CW_Membership => 2,
+ IW_Membership => 2,
DT_Entry_Size => 0,
DT_Prologue_Size => 0,
+ Get_Access_Level => 1,
Get_External_Tag => 1,
Get_Prim_Op_Address => 2,
Get_RC_Offset => 1,
Get_Remotely_Callable => 1,
Inherit_DT => 3,
Inherit_TSD => 2,
+ Register_Interface_Tag => 2,
Register_Tag => 1,
+ Set_Access_Level => 2,
Set_Expanded_Name => 2,
Set_External_Tag => 2,
Set_Prim_Op_Address => 3,
TSD_Entry_Size => 0,
TSD_Prologue_Size => 0);
+ function Build_Anonymous_Access_Type
+ (Directly_Designated_Type : Entity_Id;
+ Related_Nod : Node_Id) return Entity_Id;
+ -- Returns a decorated entity corresponding with an anonymous access type.
+ -- Used to generate unchecked type conversion of an address.
+
+ procedure Collect_All_Interfaces (T : Entity_Id);
+ -- Ada 2005 (AI-251): Collect the whole list of interfaces that are
+ -- directly or indirectly implemented by T. Used to compute the size
+ -- of the table of interfaces.
+
+ function Default_Prim_Op_Position (Subp : Entity_Id) return Uint;
+ -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
+ -- of the default primitive operations.
+
function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
-- Check if the type has a private view or if the public view appears
-- in the visible part of a package spec.
+ ----------------------------------
+ -- Build_Anonymous_Access_Type --
+ ----------------------------------
+
+ function Build_Anonymous_Access_Type
+ (Directly_Designated_Type : Entity_Id;
+ Related_Nod : Node_Id) return Entity_Id
+ is
+ New_E : Entity_Id;
+
+ begin
+ New_E := Create_Itype (Ekind => E_Anonymous_Access_Type,
+ Related_Nod => Related_Nod,
+ Scope_Id => Current_Scope);
+
+ Set_Etype (New_E, New_E);
+ Init_Size_Align (New_E);
+ Init_Size (New_E, System_Address_Size);
+ Set_Directly_Designated_Type (New_E, Directly_Designated_Type);
+ Set_Is_First_Subtype (New_E);
+
+ return New_E;
+ end Build_Anonymous_Access_Type;
+
+ ----------------------------
+ -- Collect_All_Interfaces --
+ ----------------------------
+
+ procedure Collect_All_Interfaces (T : Entity_Id) is
+
+ procedure Add_Interface (Iface : Entity_Id);
+ -- Add the interface it if is not already in the list
+
+ procedure Collect (Typ : Entity_Id);
+ -- Subsidiary subprogram used to traverse the whole list
+ -- of directly and indirectly implemented interfaces
+
+ -------------------
+ -- Add_Interface --
+ -------------------
+
+ procedure Add_Interface (Iface : Entity_Id) is
+ Elmt : Elmt_Id := First_Elmt (Abstract_Interfaces (T));
+
+ begin
+ while Present (Elmt) and then Node (Elmt) /= Iface loop
+ Next_Elmt (Elmt);
+ end loop;
+
+ if not Present (Elmt) then
+ Append_Elmt (Iface, Abstract_Interfaces (T));
+ end if;
+ end Add_Interface;
+
+ -------------
+ -- Collect --
+ -------------
+
+ procedure Collect (Typ : Entity_Id) is
+ Nod : constant Node_Id := Type_Definition (Parent (Typ));
+ Id : Node_Id;
+ Iface : Entity_Id;
+ Ancestor : Entity_Id;
+
+ begin
+ pragma Assert (False
+ or else Nkind (Nod) = N_Derived_Type_Definition
+ or else Nkind (Nod) = N_Record_Definition);
+
+ if Nkind (Nod) = N_Record_Definition then
+ return;
+ end if;
+
+ -- Include the ancestor if we are generating the whole list
+ -- of interfaces. This is used to know the size of the table
+ -- that stores the tag of all the ancestor interfaces.
+
+ Ancestor := Etype (Typ);
+
+ if Is_Interface (Ancestor) then
+ Add_Interface (Ancestor);
+ end if;
+
+ if Ancestor /= Typ
+ and then Ekind (Ancestor) /= E_Record_Type_With_Private
+ then
+ Collect (Ancestor);
+ end if;
+
+ -- Traverse the graph of ancestor interfaces
+
+ if Is_Non_Empty_List (Interface_List (Nod)) then
+ Id := First (Interface_List (Nod));
+
+ while Present (Id) loop
+
+ Iface := Etype (Id);
+
+ if Is_Interface (Iface) then
+ Add_Interface (Iface);
+ Collect (Iface);
+ end if;
+
+ Next (Id);
+ end loop;
+ end if;
+ end Collect;
+
+ -- Start of processing for Collect_All_Interfaces
+
+ begin
+ Collect (T);
+ end Collect_All_Interfaces;
+
+ ------------------------------
+ -- Default_Prim_Op_Position --
+ ------------------------------
+
+ function Default_Prim_Op_Position (Subp : Entity_Id) return Uint is
+ TSS_Name : TSS_Name_Type;
+ E : Entity_Id := Subp;
+
+ begin
+ -- Handle overriden subprograms
+
+ while Present (Alias (E)) loop
+ E := Alias (E);
+ end loop;
+
+ Get_Name_String (Chars (E));
+ TSS_Name :=
+ TSS_Name_Type
+ (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
+
+ if Chars (E) = Name_uSize then
+ return Uint_1;
+
+ elsif Chars (E) = Name_uAlignment then
+ return Uint_2;
+
+ elsif TSS_Name = TSS_Stream_Read then
+ return Uint_3;
+
+ elsif TSS_Name = TSS_Stream_Write then
+ return Uint_4;
+
+ elsif TSS_Name = TSS_Stream_Input then
+ return Uint_5;
+
+ elsif TSS_Name = TSS_Stream_Output then
+ return Uint_6;
+
+ elsif Chars (E) = Name_Op_Eq then
+ return Uint_7;
+
+ elsif Chars (E) = Name_uAssign then
+ return Uint_8;
+
+ elsif TSS_Name = TSS_Deep_Adjust then
+ return Uint_9;
+
+ elsif TSS_Name = TSS_Deep_Finalize then
+ return Uint_10;
+
+ else
+ raise Program_Error;
+ end if;
+ end Default_Prim_Op_Position;
+
-----------------------------
-- Expand_Dispatching_Call --
-----------------------------
-- This capability of dispatching directly by tag is also needed by the
-- implementation of AI-260 (for the generic dispatching constructors).
- if Etype (Ctrl_Arg) = RTE (RE_Tag) then
+ if Etype (Ctrl_Arg) = RTE (RE_Tag)
+ or else Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)
+ then
CW_Typ := Class_Wide_Type (Controlling_Type (Subp));
elsif Is_Access_Type (Etype (Ctrl_Arg)) then
New_Params := New_List;
Param := First_Actual (Call_Node);
while Present (Param) loop
-
- -- We assume that dispatching through the main dispatch table
- -- (referenced by Tag_Component) doesn't require a displacement
- -- so the expansion below is only done when dispatching on
- -- another vtable pointer, in which case the first argument
- -- is expanded into :
-
- -- typ!(Displaced_This (Address!(Param)))
-
- if Param = Ctrl_Arg
- and then DTC_Entity (Subp) /= First_Tag_Component (Typ)
- then
- Append_To (New_Params,
-
- Unchecked_Convert_To (Etype (Param),
- Make_Function_Call (Loc,
- Name => New_Reference_To (RTE (RE_Displaced_This), Loc),
- Parameter_Associations => New_List (
-
- -- Current_This
-
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Address), Loc),
- Expression => Relocate_Node (Param)),
-
- -- Vptr
-
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Ctrl_Arg),
- Selector_Name =>
- New_Reference_To (DTC_Entity (Subp), Loc)),
-
- -- Position
-
- Make_Integer_Literal (Loc, DT_Position (Subp))))));
-
- else
- Append_To (New_Params, Relocate_Node (Param));
- end if;
-
+ Append_To (New_Params, Relocate_Node (Param));
Next_Actual (Param);
end loop;
-- use it directly. Otherwise, the tag must be extracted from
-- the controlling object.
- if Etype (Ctrl_Arg) = RTE (RE_Tag) then
+ if Etype (Ctrl_Arg) = RTE (RE_Tag)
+ or else Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)
+ then
Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
else
Make_Integer_Literal (Loc, DT_Position (Subp)))));
if Nkind (Call_Node) = N_Function_Call then
- New_Call :=
- Make_Function_Call (Loc,
- Name => New_Call_Name,
- Parameter_Associations => New_Params);
- -- If this is a dispatching "=", we must first compare the tags so
- -- we generate: x.tag = y.tag and then x = y
+ -- Ada 2005 (AI-251): A dispatching "=" with an abstract interface
+ -- just requires the comparison of the tags.
- if Subp = Eq_Prim_Op then
+ if Ekind (Etype (Ctrl_Arg)) = E_Class_Wide_Type
+ and then Is_Interface (Etype (Ctrl_Arg))
+ and then Subp = Eq_Prim_Op
+ then
Param := First_Actual (Call_Node);
- New_Call :=
- Make_And_Then (Loc,
- Left_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => New_Value (Param),
- Selector_Name =>
- New_Reference_To
- (First_Tag_Component (Typ), Loc)),
- Right_Opnd =>
- Make_Selected_Component (Loc,
- Prefix =>
- Unchecked_Convert_To (Typ,
- New_Value (Next_Actual (Param))),
- Selector_Name =>
- New_Reference_To
- (First_Tag_Component (Typ), Loc))),
+ New_Call :=
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Value (Param),
+ Selector_Name =>
+ New_Reference_To (First_Tag_Component (Typ), Loc)),
+
+ Right_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Typ,
+ New_Value (Next_Actual (Param))),
+ Selector_Name =>
+ New_Reference_To (First_Tag_Component (Typ), Loc)));
- Right_Opnd => New_Call);
+ else
+ New_Call :=
+ Make_Function_Call (Loc,
+ Name => New_Call_Name,
+ Parameter_Associations => New_Params);
+
+ -- If this is a dispatching "=", we must first compare the tags so
+ -- we generate: x.tag = y.tag and then x = y
+
+ if Subp = Eq_Prim_Op then
+ Param := First_Actual (Call_Node);
+ New_Call :=
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Value (Param),
+ Selector_Name =>
+ New_Reference_To (First_Tag_Component (Typ),
+ Loc)),
+
+ Right_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Typ,
+ New_Value (Next_Actual (Param))),
+ Selector_Name =>
+ New_Reference_To (First_Tag_Component (Typ),
+ Loc))),
+ Right_Opnd => New_Call);
+ end if;
end if;
else
Analyze_And_Resolve (Call_Node, Call_Typ);
end Expand_Dispatching_Call;
+ ---------------------------------
+ -- Expand_Interface_Conversion --
+ ---------------------------------
+
+ procedure Expand_Interface_Conversion (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Operand : constant Node_Id := Expression (N);
+ Operand_Typ : Entity_Id := Etype (Operand);
+ Target_Type : Entity_Id := Etype (N);
+ Iface_Tag : Entity_Id;
+
+ begin
+ pragma Assert (Nkind (Operand) /= N_Attribute_Reference);
+
+ -- Ada 2005 (AI-345): Set Operand_Typ and Handle task interfaces
+
+ if Ekind (Operand_Typ) = E_Task_Type
+ or else Ekind (Operand_Typ) = E_Protected_Type
+ then
+ Operand_Typ := Corresponding_Record_Type (Operand_Typ);
+ end if;
+
+ if Is_Access_Type (Target_Type) then
+ Target_Type := Etype (Directly_Designated_Type (Target_Type));
+
+ elsif Is_Class_Wide_Type (Target_Type) then
+ Target_Type := Etype (Target_Type);
+ end if;
+
+ pragma Assert (not Is_Class_Wide_Type (Target_Type)
+ and then Is_Interface (Target_Type));
+
+ Iface_Tag := Find_Interface_Tag (Operand_Typ, Target_Type);
+
+ pragma Assert (Iface_Tag /= Empty);
+
+ Rewrite (N,
+ Unchecked_Convert_To (Etype (N),
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Selected_Component (Loc,
+ Prefix => Relocate_Node (Expression (N)),
+ Selector_Name => New_Occurrence_Of (Iface_Tag, Loc)),
+ Attribute_Name => Name_Address)));
+
+ Analyze (N);
+ end Expand_Interface_Conversion;
+
+ ------------------------------
+ -- Expand_Interface_Actuals --
+ ------------------------------
+
+ procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Call_Node);
+ Actual : Node_Id;
+ Actual_Typ : Entity_Id;
+ Conversion : Node_Id;
+ Formal : Entity_Id;
+ Formal_Typ : Entity_Id;
+ Subp : Entity_Id;
+ Nam : Name_Id;
+
+ begin
+ -- This subprogram is called directly from the semantics, so we need a
+ -- check to see whether expansion is active before proceeding.
+
+ if not Expander_Active then
+ return;
+ end if;
+
+ -- Call using access to subprogram with explicit dereference
+
+ if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
+ Subp := Etype (Name (Call_Node));
+
+ -- Normal case
+
+ else
+ Subp := Entity (Name (Call_Node));
+ end if;
+
+ Formal := First_Formal (Subp);
+ Actual := First_Actual (Call_Node);
+
+ while Present (Formal) loop
+
+ pragma Assert (Ekind (Etype (Etype (Formal)))
+ /= E_Record_Type_With_Private);
+
+ -- Ada 2005 (AI-251): Conversion to interface to force "this"
+ -- displacement
+
+ Formal_Typ := Etype (Etype (Formal));
+ Actual_Typ := Etype (Actual);
+
+ if Is_Interface (Formal_Typ) then
+
+ Conversion := Convert_To (Formal_Typ, New_Copy_Tree (Actual));
+ Rewrite (Actual, Conversion);
+ Analyze_And_Resolve (Actual, Formal_Typ);
+
+ Rewrite (Actual,
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To
+ (Build_Anonymous_Access_Type (Formal_Typ, Call_Node),
+ Relocate_Node (Expression (Actual)))));
+
+ Analyze_And_Resolve (Actual, Formal_Typ);
+
+ -- Anonymous access type
+
+ elsif Is_Access_Type (Formal_Typ)
+ and then Is_Interface (Etype
+ (Directly_Designated_Type
+ (Formal_Typ)))
+ and then Interface_Present_In_Ancestor
+ (Typ => Etype (Directly_Designated_Type
+ (Actual_Typ)),
+ Iface => Etype (Directly_Designated_Type
+ (Formal_Typ)))
+ then
+
+ if Nkind (Actual) = N_Attribute_Reference
+ and then
+ (Attribute_Name (Actual) = Name_Access
+ or else Attribute_Name (Actual) = Name_Unchecked_Access)
+ then
+ Nam := Attribute_Name (Actual);
+
+ Conversion :=
+ Convert_To
+ (Etype (Directly_Designated_Type (Formal_Typ)),
+ Prefix (Actual));
+
+ Rewrite (Actual, Conversion);
+
+ Analyze_And_Resolve (Actual,
+ Etype (Directly_Designated_Type (Formal_Typ)));
+
+ Rewrite (Actual,
+ Unchecked_Convert_To (Formal_Typ,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Relocate_Node (Prefix (Expression (Actual))),
+ Attribute_Name => Nam)));
+
+ Analyze_And_Resolve (Actual, Formal_Typ);
+
+ else
+ Conversion :=
+ Convert_To (Formal_Typ, New_Copy_Tree (Actual));
+ Rewrite (Actual, Conversion);
+ Analyze_And_Resolve (Actual, Formal_Typ);
+ end if;
+ end if;
+
+ Next_Actual (Actual);
+ Next_Formal (Formal);
+ end loop;
+ end Expand_Interface_Actuals;
+
+ ----------------------------
+ -- Expand_Interface_Thunk --
+ ----------------------------
+
+ function Expand_Interface_Thunk
+ (N : Node_Id;
+ Thunk_Id : Entity_Id;
+ Iface_Tag : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Actuals : constant List_Id := New_List;
+ Decl : constant List_Id := New_List;
+ Formals : constant List_Id := New_List;
+ Thunk_Tag : constant Node_Id := Iface_Tag;
+ Thunk_Alias : constant Entity_Id := Alias (Entity (N));
+ Target : Entity_Id;
+ New_Code : Node_Id;
+ Formal : Node_Id;
+ New_Formal : Node_Id;
+ Decl_1 : Node_Id;
+ Decl_2 : Node_Id;
+ Subtyp_Mark : Node_Id;
+
+ begin
+
+ -- Traverse the list of alias to find the final target
+
+ Target := Thunk_Alias;
+
+ while Present (Alias (Target)) loop
+ Target := Alias (Target);
+ end loop;
+
+ -- Duplicate the formals
+
+ Formal := First_Formal (Thunk_Alias);
+
+ while Present (Formal) loop
+ New_Formal := Copy_Separate_Tree (Parent (Formal));
+
+ -- Handle the case in which the subprogram covering
+ -- the interface has been inherited:
+
+ -- Example:
+ -- type I is interface;
+ -- procedure P (X : in I) is abstract;
+
+ -- type T is tagged null record;
+ -- procedure P (X : T);
+
+ -- type DT is new T and I with ...
+
+ if Is_Controlling_Formal (Formal) then
+ Set_Parameter_Type (New_Formal,
+ New_Reference_To (Etype (First_Entity (Entity (N))), Loc));
+
+ -- Why is this line silently commented out ???
+
+ -- New_Reference_To (Etype (Formal), Loc));
+ end if;
+
+ Append_To (Formals, New_Formal);
+ Next_Formal (Formal);
+ end loop;
+
+ if Ekind (First_Formal (Thunk_Alias)) = E_In_Parameter
+ and then Ekind (Etype (First_Formal (Thunk_Alias)))
+ = E_Anonymous_Access_Type
+ then
+
+ -- Generate:
+
+ -- type T is access all <<type of the first formal>>
+ -- S1 := Storage_Offset!(First_formal)
+ -- - Storage_Offset!(First_Formal.Thunk_Tag'Position)
+
+ -- ... and the first actual of the call is generated as T!(S1)
+
+ Decl_2 :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('T')),
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Null_Exclusion_Present => False,
+ Constant_Present => False,
+ Subtype_Indication =>
+ New_Reference_To
+ (Directly_Designated_Type
+ (Etype (First_Formal (Thunk_Alias))), Loc)
+ ));
+
+ Decl_1 :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('S')),
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Storage_Offset), Loc),
+ Expression =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To
+ (RTE (RE_Storage_Offset),
+ New_Reference_To
+ (Defining_Identifier (First (Formals)), Loc)),
+ Right_Opnd =>
+ Unchecked_Convert_To
+ (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Reference_To
+ (Defining_Identifier (First (Formals)), Loc),
+ Selector_Name =>
+ New_Occurrence_Of (Thunk_Tag, Loc)),
+ Attribute_Name => Name_Position))));
+
+ Append_To (Decl, Decl_2);
+ Append_To (Decl, Decl_1);
+
+ -- Reference the new first actual
+
+ Append_To (Actuals,
+ Unchecked_Convert_To
+ (Defining_Identifier (Decl_2),
+ New_Reference_To (Defining_Identifier (Decl_1), Loc)));
+
+ -- Side note: The reverse order of declarations is just to ensure
+ -- that the call to RE_Print is correct.
+
+ else
+ -- Generate:
+ --
+ -- S1 := Storage_Offset!(First_formal'Address)
+ -- - Storage_Offset!(First_Formal.Thunk_Tag'Position)
+ -- S2 := Tag_Ptr!(S3)
+
+ Decl_1 :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Storage_Offset), Loc),
+ Expression =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To
+ (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To
+ (Defining_Identifier (First (Formals)), Loc),
+ Attribute_Name => Name_Address)),
+ Right_Opnd =>
+ Unchecked_Convert_To
+ (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Reference_To
+ (Defining_Identifier (First (Formals)), Loc),
+ Selector_Name =>
+ New_Occurrence_Of (Thunk_Tag, Loc)),
+ Attribute_Name => Name_Position))));
+
+ Decl_2 :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc),
+ Expression =>
+ Unchecked_Convert_To
+ (RTE (RE_Addr_Ptr),
+ New_Reference_To (Defining_Identifier (Decl_1), Loc)));
+
+ Append_To (Decl, Decl_1);
+ Append_To (Decl, Decl_2);
+
+ -- Reference the new first actual
+
+ Append_To (Actuals,
+ Unchecked_Convert_To
+ (Etype (First_Entity (Target)),
+ Make_Explicit_Dereference (Loc,
+ New_Reference_To (Defining_Identifier (Decl_2), Loc))));
+
+ end if;
+
+ Formal := Next (First (Formals));
+ while Present (Formal) loop
+ Append_To (Actuals,
+ New_Reference_To (Defining_Identifier (Formal), Loc));
+ Next (Formal);
+ end loop;
+
+ if Ekind (Thunk_Alias) = E_Procedure then
+ New_Code :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Thunk_Id,
+ Parameter_Specifications => Formals),
+ Declarations => Decl,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Target, Loc),
+ Parameter_Associations => Actuals))));
+
+ else pragma Assert (Ekind (Thunk_Alias) = E_Function);
+
+ if not Present (Alias (Thunk_Alias)) then
+ Subtyp_Mark := Subtype_Mark (Parent (Thunk_Alias));
+ else
+ -- The last element in the alias list has the correct subtype_mark
+ -- of the function result
+
+ declare
+ E : Entity_Id := Alias (Thunk_Alias);
+ begin
+ while Present (Alias (E)) loop
+ E := Alias (E);
+ end loop;
+ Subtyp_Mark := Subtype_Mark (Parent (E));
+ end;
+ end if;
+
+ New_Code :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Thunk_Id,
+ Parameter_Specifications => Formals,
+ Subtype_Mark => New_Copy (Subtyp_Mark)),
+ Declarations => Decl,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Return_Statement (Loc,
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Target, Loc),
+ Parameter_Associations => Actuals)))));
+ end if;
+
+ Analyze (New_Code);
+ Insert_After (N, New_Code);
+ return New_Code;
+ end Expand_Interface_Thunk;
+
-------------
-- Fill_DT --
-------------
function Fill_DT_Entry
- (Loc : Source_Ptr;
- Prim : Entity_Id)
- return Node_Id
+ (Loc : Source_Ptr;
+ Prim : Entity_Id;
+ Thunk_Id : Entity_Id := Empty) return Node_Id
is
- Typ : constant Entity_Id := Scope (DTC_Entity (Prim));
- DT_Ptr : constant Entity_Id := Node (First_Elmt
- (Access_Disp_Table (Typ)));
+ Typ : constant Entity_Id := Scope (DTC_Entity (Prim));
+ DT_Ptr : Entity_Id := Node (First_Elmt (Access_Disp_Table (Typ)));
+ Target : Entity_Id;
+ Tag : Entity_Id := First_Tag_Component (Typ);
+ Prim_Op : Entity_Id := Prim;
begin
+ -- Ada 2005 (AI-251): If we have a thunk available then generate code
+ -- that saves its address in the secondary dispatch table of its
+ -- abstract interface; otherwise save the address of the primitive
+ -- subprogram in the main virtual table.
+
+ if Thunk_Id /= Empty then
+ Target := Thunk_Id;
+ else
+ Target := Prim;
+ end if;
+
+ -- Ada 2005 (AI-251): If the subprogram is the alias of an abstract
+ -- interface subprogram then find the correct dispatch table pointer
+
+ if Present (Abstract_Interface_Alias (Prim)) then
+ Prim_Op := Abstract_Interface_Alias (Prim);
+
+ DT_Ptr := Find_Interface_ADT
+ (T => Typ,
+ Iface => Scope (DTC_Entity (Prim_Op)));
+
+ Tag := First_Tag_Component (Scope (DTC_Entity (Prim_Op)));
+ end if;
+
+ pragma Assert (DT_Position (Prim_Op) <= DT_Entry_Count (Tag));
+ pragma Assert (DT_Position (Prim_Op) > Uint_0);
+
return
Make_DT_Access_Action (Typ,
Action => Set_Prim_Op_Address,
Args => New_List (
- New_Reference_To (DT_Ptr, Loc), -- DTptr
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)), -- DTptr
- Make_Integer_Literal (Loc, DT_Position (Prim)), -- Position
+ Make_Integer_Literal (Loc, DT_Position (Prim_Op)), -- Position
Make_Attribute_Reference (Loc, -- Value
- Prefix => New_Reference_To (Prim, Loc),
+ Prefix => New_Reference_To (Target, Loc),
Attribute_Name => Name_Address)));
end Fill_DT_Entry;
-------------
function Make_DT (Typ : Entity_Id) return List_Id is
- Loc : constant Source_Ptr := Sloc (Typ);
-
- ADT_List : constant Elist_Id := New_Elmt_List;
- Result : constant List_Id := New_List;
- Elab_Code : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Result : constant List_Id := New_List;
+ Elab_Code : constant List_Id := New_List;
Tname : constant Name_Id := Chars (Typ);
Name_DT : constant Name_Id := New_External_Name (Tname, 'T');
Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname);
No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg);
+ Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
I_Depth : Int;
- Generalized_Tag : Entity_Id;
Size_Expr_Node : Node_Id;
Old_Tag1 : Node_Id;
Old_Tag2 : Node_Id;
+ Num_Ifaces : Int;
+ Nb_Prim : Int;
+ TSD_Num_Entries : Int;
+ Typ_Copy : constant Entity_Id := New_Copy (Typ);
+ AI : Elmt_Id;
begin
if not RTE_Available (RE_Tag) then
return New_List;
end if;
- if Is_CPP_Class (Root_Type (Typ)) then
- Generalized_Tag := RTE (RE_Vtable_Ptr);
- else
- Generalized_Tag := RTE (RE_Tag);
- end if;
+ -- Collect the full list of directly and indirectly implemented
+ -- interfaces
+
+ Set_Parent (Typ_Copy, Parent (Typ));
+ Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List);
+ Collect_All_Interfaces (Typ_Copy);
+
+ -- Calculate the number of entries required in the table of interfaces
+
+ Num_Ifaces := 0;
+ AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
+
+ while Present (AI) loop
+ Num_Ifaces := Num_Ifaces + 1;
+ Next_Elmt (AI);
+ end loop;
+
+ -- Count ancestors to compute the inheritance depth. For private
+ -- extensions, always go to the full view in order to compute the real
+ -- inheritance depth.
+
+ declare
+ Parent_Type : Entity_Id := Typ;
+ P : Entity_Id;
+
+ begin
+ I_Depth := 0;
+
+ loop
+ P := Etype (Parent_Type);
+
+ if Is_Private_Type (P) then
+ P := Full_View (Base_Type (P));
+ end if;
+
+ exit when P = Parent_Type;
+
+ I_Depth := I_Depth + 1;
+ Parent_Type := P;
+ end loop;
+ end;
+
+ TSD_Num_Entries := I_Depth + Num_Ifaces + 1;
+ Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
+
+ -- ----------------------------------------------------------------
-- Dispatch table and related entities are allocated statically
Left_Opnd =>
Make_DT_Access_Action (Typ, DT_Entry_Size, No_List),
Right_Opnd =>
- Make_Integer_Literal (Loc,
- DT_Entry_Count (First_Tag_Component (Typ)))));
+ Make_Integer_Literal (Loc, Nb_Prim)));
Append_To (Result,
Make_Object_Declaration (Loc,
-- Generate code to create the pointer to the dispatch table
- -- DT_Ptr : Tag := Tag!(DT'Address); Ada case
- -- or
- -- DT_Ptr : Vtable_Ptr := Vtable_Ptr!(DT'Address); CPP case
+ -- DT_Ptr : Tag := Tag!(DT'Address);
- -- According to the C++ ABI, the base of the vtable is located
- -- after the following prologue: Offset_To_Top, Typeinfo_Ptr.
- -- Hence, move the pointer to the base of the vtable down, after
- -- this prologue.
+ -- According to the C++ ABI, the base of the vtable is located after a
+ -- prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move
+ -- down the pointer to the real base of the vtable
Append_To (Result,
Make_Object_Declaration (Loc,
-- Set Access_Disp_Table field to be the dispatch table pointer
- Append_Elmt (DT_Ptr, ADT_List);
- Set_Access_Disp_Table (Typ, ADT_List);
+ if not Present (Access_Disp_Table (Typ)) then
+ Set_Access_Disp_Table (Typ, New_Elmt_List);
+ end if;
- -- Count ancestors to compute the inheritance depth. For private
- -- extensions, always go to the full view in order to compute the real
- -- inheritance depth.
-
- declare
- Parent_Type : Entity_Id := Typ;
- P : Entity_Id;
-
- begin
- I_Depth := 0;
-
- loop
- P := Etype (Parent_Type);
-
- if Is_Private_Type (P) then
- P := Full_View (Base_Type (P));
- end if;
-
- exit when P = Parent_Type;
-
- I_Depth := I_Depth + 1;
- Parent_Type := P;
- end loop;
- end;
+ Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ));
-- Generate code to create the storage for the type specific data object
-
- -- TSD: Storage_Array (1..TSD_Prologue_Size+(1+Idepth)*TSD_Entry_Size);
+ -- with enough space to store the tags of the ancestors plus the tags
+ -- of all the implemented interfaces (as described in a-tags.adb)
+ --
+ -- TSD: Storage_Array
+ -- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size);
-- for TSD'Alignment use Address'Alignment
Size_Expr_Node :=
Left_Opnd =>
Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List),
Right_Opnd =>
- Make_Op_Add (Loc,
- Left_Opnd => Make_Integer_Literal (Loc, 1),
- Right_Opnd =>
- Make_Integer_Literal (Loc, I_Depth))));
+ Make_Integer_Literal (Loc, TSD_Num_Entries)));
Append_To (Result,
Make_Object_Declaration (Loc,
Prefix => New_Reference_To (TSD, Loc),
Attribute_Name => Name_Address))));
+ -- Generate: Exname : constant String := full_qualified_name (typ);
+ -- The type itself may be an anonymous parent type, so use the first
+ -- subtype to have a user-recognizable name.
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Exname,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc,
+ Full_Qualified_Name (First_Subtype (Typ)))));
+
+ -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
+
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Set_Expanded_Name,
+ Args => New_List (
+ Node1 => New_Reference_To (DT_Ptr, Loc),
+ Node2 =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Exname, Loc),
+ Attribute_Name => Name_Address))));
+
+ -- Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>);
+
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Set_Access_Level,
+ Args => New_List (
+ Node1 => New_Reference_To (DT_Ptr, Loc),
+ Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ)))));
+
+ -- Generate:
+ -- Set_Offset_To_Top (DT_Ptr, 0);
+
+ Append_To (Elab_Code,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
+ Parameter_Associations => New_List (
+ New_Reference_To (DT_Ptr, Loc),
+ Make_Integer_Literal (Loc, Uint_0))));
+
if Typ = Etype (Typ)
or else Is_CPP_Class (Etype (Typ))
then
Node1 => Old_Tag2,
Node2 => New_Reference_To (DT_Ptr, Loc))));
- -- Generate: Exname : constant String := full_qualified_name (typ);
- -- The type itself may be an anonymous parent type, so use the first
- -- subtype to have a user-recognizable name.
-
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Exname,
- Constant_Present => True,
- Object_Definition => New_Reference_To (Standard_String, Loc),
- Expression =>
- Make_String_Literal (Loc,
- Full_Qualified_Name (First_Subtype (Typ)))));
-
- -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
-
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_Expanded_Name,
- Args => New_List (
- Node1 => New_Reference_To (DT_Ptr, Loc),
- Node2 =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Exname, Loc),
- Attribute_Name => Name_Address))));
-
-- for types with no controlled components
-- Generate: Set_RC_Offset (DT_Ptr, 0);
-- for simple types with controlled components
Condition => New_Reference_To (No_Reg, Loc),
Then_Statements => Elab_Code));
+ -- Ada 2005 (AI-251): Register the tag of the interfaces into
+ -- the table of implemented interfaces
+
+ if Present (Abstract_Interfaces (Typ))
+ and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
+ then
+ AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
+ while Present (AI) loop
+
+ -- Generate:
+ -- Register_Interface (DT_Ptr, Interface'Tag);
+
+ Append_To (Result,
+ Make_DT_Access_Action (Typ,
+ Action => Register_Interface_Tag,
+ Args => New_List (
+ Node1 => New_Reference_To (DT_Ptr, Loc),
+ Node2 => New_Reference_To
+ (Node
+ (First_Elmt
+ (Access_Disp_Table (Node (AI)))),
+ Loc))));
+
+ Next_Elmt (AI);
+ end loop;
+ end if;
+
return Result;
end Make_DT;
+ --------------------------------
+ -- Make_Abstract_Interface_DT --
+ --------------------------------
+
+ procedure Make_Abstract_Interface_DT
+ (AI_Tag : Entity_Id;
+ Acc_Disp_Tables : in out Elist_Id;
+ Result : out List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (AI_Tag);
+ Tname : constant Name_Id := Chars (AI_Tag);
+ Name_DT : constant Name_Id := New_External_Name (Tname, 'T');
+ Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
+
+ Iface_DT : constant Node_Id :=
+ Make_Defining_Identifier (Loc, Name_DT);
+ Iface_DT_Ptr : constant Node_Id :=
+ Make_Defining_Identifier (Loc, Name_DT_Ptr);
+
+ Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
+ Size_Expr_Node : Node_Id;
+ Nb_Prim : Int;
+
+ begin
+ Result := New_List;
+
+ -- Dispatch table and related entities are allocated statically
+
+ Set_Ekind (Iface_DT, E_Variable);
+ Set_Is_Statically_Allocated (Iface_DT);
+
+ Set_Ekind (Iface_DT_Ptr, E_Variable);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr);
+
+ -- Generate code to create the storage for the Dispatch_Table object
+
+ -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
+ -- for DT'Alignment use Address'Alignment
+
+ Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
+
+ Size_Expr_Node :=
+ Make_Op_Add (Loc,
+ Left_Opnd => Make_DT_Access_Action (Etype (AI_Tag),
+ DT_Prologue_Size,
+ No_List),
+ Right_Opnd =>
+ Make_Op_Multiply (Loc,
+ Left_Opnd =>
+ Make_DT_Access_Action (Etype (AI_Tag),
+ DT_Entry_Size,
+ No_List),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Nb_Prim)));
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Iface_DT,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
+ Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => Size_Expr_Node)))),
+
+ -- Initialize the signature of the interface tag. It is currently
+ -- a sequence of four bytes located in the unused Typeinfo_Ptr
+ -- field of the prologue). Its current value is the following
+ -- sequence: (80, Nb_Prim, 0, 80)
+
+ Expression =>
+ Make_Aggregate (Loc,
+ Component_Associations => New_List (
+ Make_Component_Association (Loc,
+
+ -- -80, 0, 0, -80
+
+ Choices => New_List (
+ Make_Integer_Literal (Loc, Uint_5),
+ Make_Integer_Literal (Loc, Uint_8)),
+ Expression =>
+ Make_Integer_Literal (Loc, Uint_80)),
+
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Integer_Literal (Loc, Uint_2)),
+ Expression =>
+ Make_Integer_Literal (Loc, Nb_Prim)),
+
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Expression => Make_Integer_Literal (Loc, Uint_0))))));
+
+ Append_To (Result,
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Reference_To (Iface_DT, Loc),
+ Chars => Name_Alignment,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
+ Attribute_Name => Name_Alignment)));
+
+ -- Generate code to create the pointer to the dispatch table
+
+ -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
+
+ -- According to the C++ ABI, the base of the vtable is located
+ -- after the following prologue: Offset_To_Top, and Typeinfo_Ptr.
+ -- Hence, move the pointer down to the real base of the vtable.
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Iface_DT_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (Generalized_Tag, Loc),
+ Expression =>
+ Unchecked_Convert_To (Generalized_Tag,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Iface_DT, Loc),
+ Attribute_Name => Name_Address)),
+ Right_Opnd =>
+ Make_DT_Access_Action (Etype (AI_Tag),
+ DT_Prologue_Size, No_List)))));
+
+ -- Note: Offset_To_Top will be initialized by the init subprogram
+
+ -- Set Access_Disp_Table field to be the dispatch table pointer
+
+ if not (Present (Acc_Disp_Tables)) then
+ Acc_Disp_Tables := New_Elmt_List;
+ end if;
+
+ Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables);
+
+ end Make_Abstract_Interface_DT;
+
---------------------------
-- Make_DT_Access_Action --
---------------------------
function Make_DT_Access_Action
(Typ : Entity_Id;
Action : DT_Access_Action;
- Args : List_Id)
- return Node_Id
+ Args : List_Id) return Node_Id
is
- Action_Name : Entity_Id;
+ Action_Name : constant Entity_Id := RTE (Ada_Actions (Action));
Loc : Source_Ptr;
begin
- if Is_CPP_Class (Root_Type (Typ)) then
- Action_Name := RTE (CPP_Actions (Action));
- else
- Action_Name := RTE (Ada_Actions (Action));
- end if;
-
if No (Args) then
-- This is a constant
Root_Typ : constant Entity_Id := Root_Type (Typ);
First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
The_Tag : constant Entity_Id := First_Tag_Component (Typ);
+
Adjusted : Boolean := False;
Finalized : Boolean := False;
- Parent_EC : Int;
+
+ Count_Prim : Int;
+ DT_Length : Int;
Nb_Prim : Int;
+ Parent_EC : Int;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
- begin
+ procedure Validate_Position (Prim : Entity_Id);
+ -- Check that the position assignated to Prim is completely safe
+ -- (it has not been assigned to a previously defined primitive
+ -- operation of Typ)
+
+ -----------------------
+ -- Validate_Position --
+ -----------------------
+
+ procedure Validate_Position (Prim : Entity_Id) is
+ Prim_Elmt : Elmt_Id;
+ begin
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt)
+ and then Node (Prim_Elmt) /= Prim
+ loop
+ -- Primitive operations covering abstract interfaces are
+ -- allocated later
+
+ if Present (Abstract_Interface_Alias (Node (Prim_Elmt))) then
+ null;
+
+ -- Predefined dispatching operations are completely safe.
+ -- They are allocated at fixed positions.
+
+ elsif Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then
+ null;
+ -- Aliased subprograms are safe
+
+ elsif Present (Alias (Prim)) then
+ null;
+
+ elsif DT_Position (Node (Prim_Elmt)) = DT_Position (Prim) then
+ raise Program_Error;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end Validate_Position;
+
+ -- Start of processing for Set_All_DT_Position
+
+ begin
-- Get Entry_Count of the parent
if Parent_Typ /= Typ
-- in a-tags.ad?)
else
- Nb_Prim := 1;
- Prim_Elmt := First_Prim;
+ -- First stage: Set the DTC entity of all the primitive operations
+ -- This is required to properly read the DT_Position attribute in
+ -- the latter stages.
+
+ Prim_Elmt := First_Prim;
+ Count_Prim := 0;
while Present (Prim_Elmt) loop
- Nb_Prim := Nb_Prim + 1;
- Prim := Node (Prim_Elmt);
- Set_DTC_Entity (Prim, The_Tag);
+ Count_Prim := Count_Prim + 1;
+ Prim := Node (Prim_Elmt);
+
+ -- Ada 2005 (AI-251)
+
+ if Present (Abstract_Interface_Alias (Prim)) then
+ Set_DTC_Entity (Prim,
+ Find_Interface_Tag
+ (T => Typ,
+ Iface => Scope (DTC_Entity
+ (Abstract_Interface_Alias (Prim)))));
- if Chars (Prim) = Name_uSize then
- Set_DT_Position (Prim, Uint_1);
- Nb_Prim := Nb_Prim - 1;
else
- Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
+ Set_DTC_Entity (Prim, The_Tag);
end if;
- if Chars (Prim) = Name_Finalize
- and then
- (Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
- or else not Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Prim))))
+ -- Clear any previous value of the DT_Position attribute. In this
+ -- way we ensure that the final position of all the primitives is
+ -- stablished by the following stages of this algorithm.
+
+ Set_DT_Position (Prim, No_Uint);
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ declare
+ Fixed_Prim : array (Int range 0 .. 10 + Parent_EC + Count_Prim)
+ of Boolean := (others => False);
+ E : Entity_Id;
+
+ begin
+ -- Second stage: Register fixed entries
+
+ Nb_Prim := 10;
+ Prim_Elmt := First_Prim;
+
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ -- Predefined primitives have a fixed position in all the
+ -- dispatch tables
+
+ if Is_Predefined_Dispatching_Operation (Prim) then
+ Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
+ Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True;
+
+ -- Overriding interface primitives of an ancestor
+
+ elsif DT_Position (Prim) = No_Uint
+ and then Present (Abstract_Interface_Alias (Prim))
+ and then Present (DTC_Entity
+ (Abstract_Interface_Alias (Prim)))
+ and then DT_Position (Abstract_Interface_Alias (Prim))
+ /= No_Uint
+ and then Is_Inherited_Operation (Prim)
+ and then Is_Ancestor (Scope
+ (DTC_Entity
+ (Abstract_Interface_Alias (Prim))),
+ Typ)
+ then
+ Set_DT_Position (Prim,
+ DT_Position (Abstract_Interface_Alias (Prim)));
+ Set_DT_Position (Alias (Prim),
+ DT_Position (Abstract_Interface_Alias (Prim)));
+ Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True;
+
+ -- Overriding primitives must use the same entry as the
+ -- overriden primitive
+
+ elsif DT_Position (Prim) = No_Uint
+ and then Present (Alias (Prim))
+ and then Present (DTC_Entity (Alias (Prim)))
+ and then DT_Position (Alias (Prim)) /= No_Uint
+ and then Is_Inherited_Operation (Prim)
+ and then Is_Ancestor (Scope (DTC_Entity (Alias (Prim))), Typ)
+ then
+ E := Alias (Prim);
+ while not (Present (DTC_Entity (E))
+ or else DT_Position (E) = No_Uint)
+ and then Present (Alias (E))
+ loop
+ E := Alias (E);
+ end loop;
+
+ pragma Assert (Present (DTC_Entity (E))
+ and then
+ DT_Position (E) /= No_Uint);
+
+ Set_DT_Position (Prim, DT_Position (E));
+ Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
+
+ -- If this is not the last element in the chain continue
+ -- traversing the chain. This is required to properly
+ -- handling renamed primitives
+
+ if Present (Alias (E)) then
+ while Present (Alias (E)) loop
+ E := Alias (E);
+ Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
+ end loop;
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ -- Third stage: Fix the position of all the new primitives
+ -- Entries associated with primitives covering interfaces
+ -- are handled in a latter round.
+
+ Prim_Elmt := First_Prim;
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ -- Skip primitives previously set entries
+
+ if DT_Position (Prim) /= No_Uint then
+ null;
+
+ elsif Etype (DTC_Entity (Prim)) /= RTE (RE_Tag) then
+ null;
+
+ -- Primitives covering interface primitives are
+ -- handled later
+
+ elsif Present (Abstract_Interface_Alias (Prim)) then
+ null;
+
+ else
+ -- Take the next available position in the DT
+
+ loop
+ Nb_Prim := Nb_Prim + 1;
+ exit when not Fixed_Prim (Nb_Prim);
+ end loop;
+
+ Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
+ Fixed_Prim (Nb_Prim) := True;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end;
+
+ -- Fourth stage: Complete the decoration of primitives covering
+ -- interfaces (that is, propagate the DT_Position attribute
+ -- from the aliased primitive)
+
+ Prim_Elmt := First_Prim;
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if DT_Position (Prim) = No_Uint
+ and then Present (Abstract_Interface_Alias (Prim))
then
+ -- Check if this entry will be placed in the primary DT
+
+ if Etype (DTC_Entity (Abstract_Interface_Alias (Prim)))
+ = RTE (RE_Tag)
+ then
+ pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
+ Set_DT_Position (Prim, DT_Position (Alias (Prim)));
+
+ -- Otherwise it will be placed in the secondary DT
+
+ else
+ pragma Assert
+ (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
+
+ Set_DT_Position (Prim,
+ DT_Position (Abstract_Interface_Alias (Prim)));
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ -- Final stage: Ensure that the table is correct plus some further
+ -- verifications concerning the primitives.
+
+ Prim_Elmt := First_Prim;
+ DT_Length := 0;
+
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ -- At this point all the primitives MUST have a position
+ -- in the dispatch table
+
+ if DT_Position (Prim) = No_Uint then
+ raise Program_Error;
+ end if;
+
+ -- Calculate real size of the dispatch table
+
+ if UI_To_Int (DT_Position (Prim)) > DT_Length then
+ DT_Length := UI_To_Int (DT_Position (Prim));
+ end if;
+
+ -- Ensure that the asignated position in the dispatch
+ -- table is correct
+
+ Validate_Position (Prim);
+
+ if Chars (Prim) = Name_Finalize then
Finalized := True;
end if;
-- An abstract operation cannot be declared in the private part
-- for a visible abstract type, because it could never be over-
- -- ridden. For explicit declarations this is checked at the point
- -- of declaration, but for inherited operations it must be done
- -- when building the dispatch table. Input is excluded because
+ -- ridden. For explicit declarations this is checked at the
+ -- point of declaration, but for inherited operations it must
+ -- be done when building the dispatch table. Input is excluded
+ -- because
if Is_Abstract (Typ)
and then Is_Abstract (Prim)
and then Present (Alias (Prim))
and then Is_Derived_Type (Typ)
and then In_Private_Part (Current_Scope)
- and then List_Containing (Parent (Prim))
- = Private_Declarations
+ and then
+ List_Containing (Parent (Prim)) =
+ Private_Declarations
(Specification (Unit_Declaration_Node (Current_Scope)))
and then Original_View_In_Visible_Part (Typ)
then
Error_Msg_NE
("abstract inherited private operation&" &
" must be overridden ('R'M 3.9.3(10))",
- Parent (Typ), Prim);
+ Parent (Typ), Prim);
end if;
end if;
+
Next_Elmt (Prim_Elmt);
end loop;
+ -- Additional check
+
if Is_Controlled (Typ) then
if not Finalized then
Error_Msg_N
end if;
end if;
- Set_DT_Entry_Count (The_Tag, UI_From_Int (Nb_Prim));
+ -- Set the final size of the Dispatch Table
+
+ Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
-- The derived type must have at least as many components as its
-- parent (for root types, the Etype points back to itself
-- and the test should not fail)
- pragma Assert (
- DT_Entry_Count (The_Tag) >=
- DT_Entry_Count (First_Tag_Component (Parent_Typ)));
+ -- This test fails compiling the partial view of a tagged type
+ -- derived from an interface which defines the overriding subprogram
+ -- in the private part. This needs further investigation???
+
+ if not Has_Private_Declaration (Typ) then
+ pragma Assert (
+ DT_Entry_Count (The_Tag) >=
+ DT_Entry_Count (First_Tag_Component (Parent_Typ)));
+ null;
+ end if;
+ end if;
+
+ if Debug_Flag_ZZ then
+ Write_DT (Typ);
end if;
end Set_All_DT_Position;
end if;
end Set_Default_Constructor;
+ --------------
+ -- Write_DT --
+ --------------
+
+ procedure Write_DT (Typ : Entity_Id) is
+ Elmt : Elmt_Id;
+ Prim : Node_Id;
+
+ begin
+ -- Protect this procedure against wrong usage. Required because it will
+ -- be used directly from GDB
+
+ if not (Typ in First_Node_Id .. Last_Node_Id)
+ or else not Is_Tagged_Type (Typ)
+ then
+ Write_Str ("wrong usage: write_dt must be used with tagged types");
+ Write_Eol;
+ return;
+ end if;
+
+ Write_Int (Int (Typ));
+ Write_Str (": ");
+ Write_Name (Chars (Typ));
+
+ if Is_Interface (Typ) then
+ Write_Str (" is interface");
+ end if;
+
+ Write_Eol;
+
+ Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Elmt) loop
+ Prim := Node (Elmt);
+ Write_Str (" - ");
+
+ -- Indicate if this primitive will be allocated in the primary
+ -- dispatch table or in a secondary dispatch table associated
+ -- with an abstract interface type
+
+ if Present (DTC_Entity (Prim)) then
+ if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
+ Write_Str ("[P] ");
+ else
+ Write_Str ("[s] ");
+ end if;
+ end if;
+
+ -- Output the node of this primitive operation and its name
+
+ Write_Int (Int (Prim));
+ Write_Str (": ");
+ Write_Name (Chars (Prim));
+
+ -- Indicate if this primitive has an aliased primitive
+
+ if Present (Alias (Prim)) then
+ Write_Str (" (alias = ");
+ Write_Int (Int (Alias (Prim)));
+
+ -- If the DTC_Entity attribute is already set we can also output
+ -- the name of the interface covered by this primitive (if any)
+
+ if Present (DTC_Entity (Alias (Prim)))
+ and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
+ then
+ Write_Str (" from interface ");
+ Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
+ end if;
+
+ if Present (Abstract_Interface_Alias (Prim)) then
+ Write_Str (", AI_Alias of ");
+ Write_Name (Chars (Scope (DTC_Entity
+ (Abstract_Interface_Alias (Prim)))));
+ Write_Char (':');
+ Write_Int (Int (Abstract_Interface_Alias (Prim)));
+ end if;
+
+ Write_Str (")");
+ end if;
+
+ -- Display the final position of this primitive in its associated
+ -- (primary or secondary) dispatch table
+
+ if Present (DTC_Entity (Prim))
+ and then DT_Position (Prim) /= No_Uint
+ then
+ Write_Str (" at #");
+ Write_Int (UI_To_Int (DT_Position (Prim)));
+ end if;
+
+ if Is_Abstract (Prim) then
+ Write_Str (" is abstract;");
+ end if;
+
+ Write_Eol;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end Write_DT;
+
end Exp_Disp;
------------------------------------------------------------------------------
-- This package contains routines involved in tagged types and dynamic
--- dispatching expansion
+-- dispatching expansion.
with Types; use Types;
package Exp_Disp is
type DT_Access_Action is
(CW_Membership,
+ IW_Membership,
DT_Entry_Size,
DT_Prologue_Size,
+ Get_Access_Level,
Get_External_Tag,
Get_Prim_Op_Address,
Get_RC_Offset,
Get_Remotely_Callable,
Inherit_DT,
Inherit_TSD,
+ Register_Interface_Tag,
Register_Tag,
+ Set_Access_Level,
Set_Expanded_Name,
Set_External_Tag,
Set_Prim_Op_Address,
TSD_Prologue_Size);
function Fill_DT_Entry
- (Loc : Source_Ptr;
- Prim : Entity_Id)
- return Node_Id;
+ (Loc : Source_Ptr;
+ Prim : Entity_Id;
+ Thunk_Id : Entity_Id := Empty) return Node_Id;
-- Generate the code necessary to fill the appropriate entry of the
-- dispatch table of Prim's controlling type with Prim's address.
+ 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;
- Args : List_Id)
- return Node_Id;
+ Args : List_Id) return Node_Id;
-- Generate a call to one of the Dispatch Table Access Subprograms defined
-- in Ada.Tags or in Interfaces.Cpp
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
+ -- Class case check that no pragma CPP_Virtual is missing and that the
-- DT_Position are coherent
procedure Expand_Dispatching_Call (Call_Node : Node_Id);
-- the required tag checks when appropriate. For CPP types the call is
-- done through the Vtable (tag checks are not relevant)
+ procedure Expand_Interface_Actuals (Call_Node : Node_Id);
+ -- Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide
+ -- interfaces to reference the interface tag of the actual object
+
+ procedure Expand_Interface_Conversion (N : Node_Id);
+ -- Ada 2005 (AI-251): N is a type-conversion node. Reference the base of
+ -- the object to give access to the interface tag associated with the
+ -- secondary dispatch table
+
+ function Expand_Interface_Thunk
+ (N : Node_Id;
+ Thunk_Id : Entity_Id;
+ Iface_Tag : Entity_Id) return Node_Id;
+ -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
+ -- generate additional subprograms (thunks) to have a layout compatible
+ -- with the C++ ABI. The thunk modifies the value of the first actual of
+ -- the call (that is, the pointer to the object) before transferring
+ -- control to the target function.
+
procedure Set_Default_Constructor (Typ : Entity_Id);
-- Typ is a CPP_Class type. Create the Init procedure of that type to
-- be the default constructor (i.e. the function returning this type,
-- Return an expression that holds True if the object can be transmitted
-- onto another partition according to E.4 (18)
+ procedure Write_DT (Typ : Entity_Id);
+ pragma Export (Ada, Write_DT);
+ -- Debugging procedure (to be called within gdb)
+
end Exp_Disp;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
-- procedure of record with task components, or for a dynamically
-- created task that is assigned to a selected component.
+ procedure Find_Interface_Tag
+ (T : Entity_Id;
+ Iface : Entity_Id;
+ Iface_Tag : out Entity_Id;
+ Iface_ADT : out Entity_Id);
+ -- Ada 2005 (AI-251): Subsidiary procedure to Find_Interface_ADT and
+ -- Find_Interface_Tag. Given a type T implementing the interface,
+ -- returns the corresponding Tag and Access_Disp_Table entities.
+
function Make_CW_Equivalent_Type
(T : Entity_Id;
E : Node_Id) return Entity_Id;
then
if Is_Itype (Exp_Typ) then
- -- No need to generate a new one
+ -- Within an initialization procedure, a selected component
+ -- denotes a component of the enclosing record, and it appears
+ -- as an actual in a call to its own initialization procedure.
+ -- If this component depends on the outer discriminant, we must
+ -- generate the proper actual subtype for it.
- T := Exp_Typ;
+ if Nkind (Exp) = N_Selected_Component
+ and then Within_Init_Proc
+ then
+ declare
+ Decl : constant Node_Id :=
+ Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
+ begin
+ if Present (Decl) then
+ Insert_Action (N, Decl);
+ T := Defining_Identifier (Decl);
+ else
+ T := Exp_Typ;
+ end if;
+ end;
+
+ -- No need to generate a new one (new what???)
+
+ else
+ T := Exp_Typ;
+ end if;
else
T :=
end if;
end Expand_Subtype_From_Expr;
+ ------------------------
+ -- Find_Interface_Tag --
+ ------------------------
+
+ procedure Find_Interface_Tag
+ (T : Entity_Id;
+ Iface : Entity_Id;
+ Iface_Tag : out Entity_Id;
+ Iface_ADT : out Entity_Id)
+ is
+ AI_Tag : Entity_Id;
+ ADT_Elmt : Elmt_Id;
+ Found : Boolean := False;
+
+ procedure Find_AI_Tag (Typ : in Entity_Id; Found : in out Boolean);
+ -- This must be commented ???
+
+ -----------------
+ -- Find_AI_Tag --
+ -----------------
+
+ procedure Find_AI_Tag (Typ : in Entity_Id; Found : in out Boolean) is
+ T : Entity_Id := Typ;
+ Etyp : Entity_Id; -- := Etype (Typ); -- why is this commented ???
+ AI_Elmt : Elmt_Id;
+ AI : Node_Id;
+
+ begin
+ -- Check if the interface is an immediate ancestor of the type and
+ -- therefore shares the main tag.
+
+ if Typ = Iface then
+ AI_Tag := First_Tag_Component (Typ);
+ ADT_Elmt := First_Elmt (Access_Disp_Table (Typ));
+ Found := True;
+ return;
+ end if;
+
+ -- Handle private types
+
+ if Has_Private_Declaration (T)
+ and then Present (Full_View (T))
+ then
+ T := Full_View (T);
+ end if;
+
+ if Is_Access_Type (Typ) then
+ T := Directly_Designated_Type (T);
+
+ elsif Ekind (T) = E_Protected_Type
+ or else Ekind (T) = E_Task_Type
+ then
+ T := Corresponding_Record_Type (T);
+ end if;
+
+ Etyp := Etype (T);
+
+ -- Climb to the root type
+
+ if Etyp /= Typ then
+ Find_AI_Tag (Etyp, Found);
+ end if;
+
+ -- Traverse the list of interfaces implemented by the type
+
+ if not Found
+ and then Present (Abstract_Interfaces (T))
+ and then not Is_Empty_Elmt_List (Abstract_Interfaces (T))
+ then
+ -- Skip the tag associated with the primary table (if
+ -- already placed in the record)
+
+ if Etype (Node (First_Elmt
+ (Access_Disp_Table (T)))) = RTE (RE_Tag)
+ then
+ AI_Tag := Next_Tag_Component (First_Tag_Component (T));
+ ADT_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
+ else
+ AI_Tag := First_Tag_Component (T);
+ ADT_Elmt := First_Elmt (Access_Disp_Table (T));
+ end if;
+
+ pragma Assert (Present (AI_Tag));
+ pragma Assert (Present (Node (ADT_Elmt)));
+
+ AI_Elmt := First_Elmt (Abstract_Interfaces (T));
+ while Present (AI_Elmt) loop
+ AI := Node (AI_Elmt);
+
+ if AI = Iface or else Is_Ancestor (Iface, AI) then
+ Found := True;
+ return;
+ end if;
+
+ AI_Tag := Next_Tag_Component (AI_Tag);
+ Next_Elmt (AI_Elmt);
+ Next_Elmt (ADT_Elmt);
+ end loop;
+ end if;
+ end Find_AI_Tag;
+
+ begin
+ Find_AI_Tag (T, Found);
+ pragma Assert (Found);
+
+ Iface_Tag := AI_Tag;
+ Iface_ADT := Node (ADT_Elmt);
+ end Find_Interface_Tag;
+
+ ------------------------
+ -- Find_Interface_Tag --
+ ------------------------
+
+ function Find_Interface_ADT
+ (T : Entity_Id;
+ Iface : Entity_Id) return Entity_Id
+ is
+ Iface_Tag : Entity_Id := Empty;
+ Iface_ADT : Entity_Id := Empty;
+ begin
+ Find_Interface_Tag (T, Iface, Iface_Tag, Iface_ADT);
+ return Iface_ADT;
+ end Find_Interface_ADT;
+
+ ------------------------
+ -- Find_Interface_Tag --
+ ------------------------
+
+ function Find_Interface_Tag
+ (T : Entity_Id;
+ Iface : Entity_Id) return Entity_Id
+ is
+ Iface_Tag : Entity_Id := Empty;
+ Iface_ADT : Entity_Id := Empty;
+ begin
+ Find_Interface_Tag (T, Iface, Iface_Tag, Iface_ADT);
+ return Iface_Tag;
+ end Find_Interface_Tag;
+
------------------
-- Find_Prim_Op --
------------------
Par : Node_Id;
begin
- -- Loop to determine whether there is a component reference in
- -- the left hand side if Exp appears on the left side of an
- -- assignment statement. Needed to determine if form of result
- -- must be a variable.
+ -- Loop to determine whether there is a component reference in the left
+ -- hand side if Exp appears on the left side of an assignment statement.
+ -- Needed to determine if form of result must be a variable.
Par := Exp;
while Present (Par)
end if;
end loop;
- -- If the expression is a selected component, it is being evaluated
- -- as part of a discriminant check. If it is part of a left-hand
- -- side, this is the last use of its value and it is safe to create
- -- a renaming for it, rather than a temporary. In addition, if it
- -- is not an addressable field, creating a temporary may be a problem
- -- for gigi, or might drop the value of the assignment. Therefore,
- -- if the expression is on the lhs of an assignment, remove side
- -- effects without requiring a temporary, and create a renaming.
- -- (See remove_side_effects for details).
+ -- If the expression is a selected component, it is being evaluated as
+ -- part of a discriminant check. If it is part of a left-hand side, this
+ -- is the last use of its value and it is safe to create a renaming for
+ -- it, rather than a temporary. In addition, if it is not an addressable
+ -- field, creating a temporary may be a problem for gigi, or might drop
+ -- the value of the assignment. Therefore, if the expression is on the
+ -- lhs of an assignment, remove side effects without requiring a
+ -- temporary, and create a renaming. (See remove_side_effects for
+ -- details).
Remove_Side_Effects
(Exp, Name_Req, Variable_Ref => not Component_In_Lhs);
-- If we fall off the top of the tree, then that's odd, but
-- perhaps it could occur in some error situation, and the
- -- safest response is simply to assume that the outcome of
- -- the condition is unknown. No point in bombing during an
- -- attempt to optimize things.
+ -- safest response is simply to assume that the outcome of the
+ -- condition is unknown. No point in bombing during an attempt
+ -- to optimize things.
if No (N) then
return;
end if;
end;
- -- ELSIF part. Condition is known true within the referenced
- -- ELSIF, known False in any subsequent ELSIF or ELSE part,
- -- and unknown before the ELSE part or after the IF statement.
+ -- ELSIF part. Condition is known true within the referenced ELSIF,
+ -- known False in any subsequent ELSIF or ELSE part, and unknown before
+ -- the ELSE part or after the IF statement.
elsif Nkind (CV) = N_Elsif_Part then
Stm := Parent (CV);
return;
end if;
- -- Again we lack the SLOC of the ELSE, so we need to climb the
- -- tree to see if we are within the ELSIF part in question.
+ -- Again we lack the SLOC of the ELSE, so we need to climb the tree
+ -- to see if we are within the ELSIF part in question.
declare
N : Node_Id;
-- If we fall off the top of the tree, then that's odd, but
-- perhaps it could occur in some error situation, and the
- -- safest response is simply to assume that the outcome of
- -- the condition is unknown. No point in bombing during an
- -- attempt to optimize things.
+ -- safest response is simply to assume that the outcome of the
+ -- condition is unknown. No point in bombing during an attempt
+ -- to optimize things.
if No (N) then
return;
return;
end if;
- -- If we fall through here, then we have a reportable
- -- condition, Sens is True if the condition is true and
- -- False if it needs inverting.
+ -- If we fall through here, then we have a reportable condition, Sens is
+ -- True if the condition is true and False if it needs inverting.
-- Deal with NOT operators, inverting sense
return True;
end Is_All_Null_Statements;
+ ------------------------
+ -- Is_Default_Prim_Op --
+ ------------------------
+
+ function Is_Predefined_Dispatching_Operation
+ (Subp : Entity_Id) return Boolean
+ is
+ TSS_Name : TSS_Name_Type;
+ E : Entity_Id := Subp;
+ begin
+ pragma Assert (Is_Dispatching_Operation (Subp));
+
+ -- Handle overriden subprograms
+
+ while Present (Alias (E)) loop
+ E := Alias (E);
+ end loop;
+
+ Get_Name_String (Chars (E));
+
+ if Name_Len > TSS_Name_Type'Last then
+ TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
+ .. Name_Len));
+ if Chars (E) = Name_uSize
+ or else Chars (E) = Name_uAlignment
+ or else TSS_Name = TSS_Stream_Read
+ or else TSS_Name = TSS_Stream_Write
+ or else TSS_Name = TSS_Stream_Input
+ or else TSS_Name = TSS_Stream_Output
+ or else Chars (E) = Name_Op_Eq
+ or else Chars (E) = Name_uAssign
+ or else TSS_Name = TSS_Deep_Adjust
+ or else TSS_Name = TSS_Deep_Finalize
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_Predefined_Dispatching_Operation;
+
----------------------------------
-- Is_Possibly_Unaligned_Object --
----------------------------------
begin
-- If component reference is for an array with non-static bounds,
- -- then it is always aligned, we can only unaligned arrays with
- -- static bounds (more accurately bounds known at compile time)
+ -- then it is always aligned: we can only process unaligned
+ -- arrays with static bounds (more accurately bounds known at
+ -- compile time).
if Is_Array_Type (T)
and then not Compile_Time_Known_Bounds (T)
-- Actions field of the N_Compilation_Aux node for the main unit).
procedure Insert_Library_Level_Actions (L : List_Id);
- -- Similar, but inserts a list of actions.
+ -- Similar, but inserts a list of actions
-----------------------
-- Other Subprograms --
-- The node N is an expression whose root-type is Boolean, and which
-- represents a boolean value used as a condition (i.e. a True/False
-- value). This routine handles the case of C and Fortran convention
- -- boolean types, which have zero/non-zero semantics rather than the
- -- normal 0/1 semantics, and also the case of an enumeration rep
- -- clause that specifies a non-standard representation. On return,
- -- node N always has the type Standard.Boolean, with a value that
- -- is a standard Boolean values of 0/1 for False/True. This procedure
- -- is used in two situations. First, the processing for a condition
- -- field always calls Adjust_Condition, so that the boolean value
- -- presented to the backend is a standard value. Second, for the
- -- code for boolean operations such as AND, Adjust_Condition is
- -- called on both operands, and then the operation is done in the
- -- domain of Standard_Boolean, then Adjust_Result_Type is called
- -- on the result to possibly reset the original type. This procedure
+ -- boolean types, which have zero/non-zero semantics rather than the normal
+ -- 0/1 semantics, and also the case of an enumeration rep clause that
+ -- specifies a non-standard representation. On return, node N always has
+ -- the type Standard.Boolean, with a value that is a standard Boolean
+ -- values of 0/1 for False/True. This procedure is used in two situations.
+ -- First, the processing for a condition field always calls
+ -- Adjust_Condition, so that the boolean value presented to the backend is
+ -- a standard value. Second, for the code for boolean operations such as
+ -- AND, Adjust_Condition is called on both operands, and then the operation
+ -- is done in the domain of Standard_Boolean, then Adjust_Result_Type is
+ -- called on the result to possibly reset the original type. This procedure
-- also takes care of validity checking if Validity_Checks = Tests.
procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id);
-- The processing of boolean operations like AND uses the procedure
- -- Adjust_Condition so that it can operate on Standard.Boolean, which
- -- is the only boolean type on which the backend needs to be able to
- -- implement such operators. This means that the result is also of
- -- type Standard.Boolean. In general the type must be reset back to
- -- the original type to get proper semantics, and that is the purpose
- -- of this procedure. N is the node (of type Standard.Boolean), and
- -- T is the desired type. As an optimization, this procedure leaves
- -- the type as Standard.Boolean in contexts where this is permissible
- -- (in particular for Condition fields, and for operands of other
- -- logical operations higher up the tree). The call to this procedure
- -- is completely ignored if the argument N is not of type Boolean.
+ -- Adjust_Condition so that it can operate on Standard.Boolean, which is
+ -- the only boolean type on which the backend needs to be able to implement
+ -- such operators. This means that the result is also of type
+ -- Standard.Boolean. In general the type must be reset back to the original
+ -- type to get proper semantics, and that is the purpose of this procedure.
+ -- N is the node (of type Standard.Boolean), and T is the desired type. As
+ -- an optimization, this procedure leaves the type as Standard.Boolean in
+ -- contexts where this is permissible (in particular for Condition fields,
+ -- and for operands of other logical operations higher up the tree). The
+ -- call to this procedure is completely ignored if the argument N is not of
+ -- type Boolean.
procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id);
-- Add a new freeze action for the given type. The freeze action is
- -- attached to the freeze node for the type. Actions will be elaborated
- -- in the order in which they are added. Note that the added node is not
+ -- attached to the freeze node for the type. Actions will be elaborated in
+ -- the order in which they are added. Note that the added node is not
-- analyzed. The analyze call is found in Sem_Ch13.Expand_N_Freeze_Entity.
procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id);
- -- Adds the given list of freeze actions (declarations or statements)
- -- for the given type. The freeze actions are attached to the freeze
- -- node for the type. Actions will be elaborated in the order in which
- -- they are added, and the actions within the list will be elaborated in
- -- list order. Note that the added nodes are not analyzed. The analyze
- -- call is found in Sem_Ch13.Expand_N_Freeze_Entity.
+ -- Adds the given list of freeze actions (declarations or statements) for
+ -- the given type. The freeze actions are attached to the freeze node for
+ -- the type. Actions will be elaborated in the order in which they are
+ -- added, and the actions within the list will be elaborated in list order.
+ -- Note that the added nodes are not analyzed. The analyze call is found in
+ -- Sem_Ch13.Expand_N_Freeze_Entity.
function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id;
-- Build an N_Procedure_Call_Statement calling the given runtime entity.
Id_Ref : Node_Id;
A_Type : Entity_Id)
return List_Id;
- -- Build declaration for a variable that holds an identifying string
- -- to be used as a task name. Id_Ref is an identifier if the task is
- -- a variable, and a selected or indexed component if the task is a
- -- component of an object. If it is an indexed component, A_Type is
- -- the corresponding array type. Its index types are used to build the
- -- string as an image of the index values. For composite types, the
- -- result includes two declarations: one for a generated function that
- -- computes the image without using concatenation, and one for the
- -- variable that holds the result.
+ -- Build declaration for a variable that holds an identifying string to be
+ -- used as a task name. Id_Ref is an identifier if the task is a variable,
+ -- and a selected or indexed component if the task is component of an
+ -- object. If it is an indexed component, A_Type is the corresponding array
+ -- type. Its index types are used to build the string as an image of the
+ -- index values. For composite types, the result includes two declarations:
+ -- one for a generated function that computes the image without using
+ -- concatenation, and one for the variable that holds the result.
function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean;
- -- This function is in charge of detecting record components that may
- -- cause trouble in the back end if an attempt is made to assign the
- -- component. The back end can handle such assignments with no problem
- -- if the components involved are small (64-bits or less) records or
- -- scalar items (including bit-packed arrays represented with modular
- -- types) or are both aligned on a byte boundary (starting on a byte
- -- boundary, and occupying an integral number of bytes).
+ -- This function is in charge of detecting record components that may cause
+ -- trouble in the back end if an attempt is made to assign the component.
+ -- The back end can handle such assignments with no problem if the
+ -- components involved are small (64-bits or less) records or scalar items
+ -- (including bit-packed arrays represented with modular types) or are both
+ -- aligned on a byte boundary (starting on a byte boundary, and occupying
+ -- an integral number of bytes).
--
- -- However, problems arise for records larger than 64 bits, or for
- -- arrays (other than bit-packed arrays represented with a modular
- -- type) if the component starts on a non-byte boundary, or does
- -- not occupy an integral number of bytes (i.e. there are some bits
- -- possibly shared with fields at the start or beginning of the
- -- component). The back end cannot handle loading and storing such
- -- components in a single operation.
+ -- However, problems arise for records larger than 64 bits, or for arrays
+ -- (other than bit-packed arrays represented with a modular type) if the
+ -- component starts on a non-byte boundary, or does not occupy an integral
+ -- number of bytes (i.e. there are some bits possibly shared with fields at
+ -- the start or beginning of the component). The back end cannot handle
+ -- loading and storing such components in a single operation.
--
-- This function is used to detect the troublesome situation. it is
- -- conservative in the sense that it produces True unless it knows
- -- for sure that the component is safe (as outlined in the first
- -- paragraph above). The code generation for record and array
- -- assignment checks for trouble using this function, and if so
- -- the assignment is generated component-wise, which the back end
- -- is required to handle correctly.
+ -- conservative in the sense that it produces True unless it knows for sure
+ -- that the component is safe (as outlined in the first paragraph above).
+ -- The code generation for record and array assignment checks for trouble
+ -- using this function, and if so the assignment is generated
+ -- component-wise, which the back end is required to handle correctly.
--
- -- Note that in GNAT 3, the back end will reject such components
- -- anyway, so the hard work in checking for this case is wasted
- -- in GNAT 3, but it's harmless, so it is easier to do it in
- -- all cases, rather than conditionalize it in GNAT 5 or beyond.
+ -- Note that in GNAT 3, the back end will reject such components anyway, so
+ -- the hard work in checking for this case is wasted in GNAT 3, but it's
+ -- harmless, so it is easier to do it in all cases, rather than
+ -- conditionalize it in GNAT 5 or beyond.
procedure Convert_To_Actual_Subtype (Exp : Node_Id);
- -- The Etype of an expression is the nominal type of the expression,
- -- not the actual subtype. Often these are the same, but not always.
- -- For example, a reference to a formal of unconstrained type has the
- -- unconstrained type as its Etype, but the actual subtype is obtained
- -- by applying the actual bounds. This routine is given an expression,
- -- Exp, and (if necessary), replaces it using Rewrite, with a conversion
- -- to the actual subtype, building the actual subtype if necessary. If
- -- the expression is already of the requested type, then it is unchanged.
+ -- The Etype of an expression is the nominal type of the expression, not
+ -- the actual subtype. Often these are the same, but not always. For
+ -- example, a reference to a formal of unconstrained type has the
+ -- unconstrained type as its Etype, but the actual subtype is obtained by
+ -- applying the actual bounds. This routine is given an expression, Exp,
+ -- and (if necessary), replaces it using Rewrite, with a conversion to the
+ -- actual subtype, building the actual subtype if necessary. If the
+ -- expression is already of the requested type, then it is unchanged.
function Current_Sem_Unit_Declarations return List_Id;
-- Return the a place where it is fine to insert declarations for the
function Duplicate_Subexpr
(Exp : Node_Id;
Name_Req : Boolean := False) return Node_Id;
- -- Given the node for a subexpression, this function makes a logical
- -- copy of the subexpression, and returns it. This is intended for use
- -- when the expansion of an expression needs to repeat part of it. For
- -- example, replacing a**2 by a*a requires two references to a which
- -- may be a complex subexpression. Duplicate_Subexpr guarantees not
- -- to duplicate side effects. If necessary, it generates actions to
- -- save the expression value in a temporary, inserting these actions
- -- into the tree using Insert_Actions with Exp as the insertion location.
- -- The original expression and the returned result then become references
- -- to this saved value. Exp must be analyzed on entry. On return, Exp
- -- is analyzed, but the caller is responsible for analyzing the returned
- -- copy after it is attached to the tree. The Name_Req flag is set to
- -- ensure that the result is suitable for use in a context requiring a
- -- name (e.g. the prefix of an attribute reference).
+ -- Given the node for a subexpression, this function makes a logical copy
+ -- of the subexpression, and returns it. This is intended for use when the
+ -- expansion of an expression needs to repeat part of it. For example,
+ -- replacing a**2 by a*a requires two references to a which may be a
+ -- complex subexpression. Duplicate_Subexpr guarantees not to duplicate
+ -- side effects. If necessary, it generates actions to save the expression
+ -- value in a temporary, inserting these actions into the tree using
+ -- Insert_Actions with Exp as the insertion location. The original
+ -- expression and the returned result then become references to this saved
+ -- value. Exp must be analyzed on entry. On return, Exp is analyzed, but
+ -- the caller is responsible for analyzing the returned copy after it is
+ -- attached to the tree. The Name_Req flag is set to ensure that the result
+ -- is suitable for use in a context requiring name (e.g. the prefix of an
+ -- attribute reference).
--
-- Note that if there are any run time checks in Exp, these same checks
-- will be duplicated in the returned duplicated expression. The two
function Duplicate_Subexpr_Move_Checks
(Exp : Node_Id;
Name_Req : Boolean := False) return Node_Id;
- -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks
- -- is called on Exp after the duplication is complete, so that the
- -- original expression does not include checks. In this case the result
- -- returned (the duplicated expression) will retain the original checks.
- -- This is appropriate for use when the duplicated expression is sure
- -- to be elaborated before the original expression Exp, so that there
- -- is no need to repeat the checks.
+ -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks is
+ -- called on Exp after the duplication is complete, so that the original
+ -- expression does not include checks. In this case the result returned
+ -- (the duplicated expression) will retain the original checks. This is
+ -- appropriate for use when the duplicated expression is sure to be
+ -- elaborated before the original expression Exp, so that there is no need
+ -- to repeat the checks.
procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id);
-- This procedure ensures that type referenced by Typ is defined. For the
-- Rewrites Cond with the expression: Cond and then Cond1. If Cond is
-- Empty, then simply returns Cond1 (this allows the use of Empty to
-- initialize a series of checks evolved by this routine, with a final
- -- result of Empty indicating that no checks were required). The Sloc
- -- field of the constructed N_And_Then node is copied from Cond1.
+ -- result of Empty indicating that no checks were required). The Sloc field
+ -- of the constructed N_And_Then node is copied from Cond1.
procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id);
- -- Rewrites Cond with the expression: Cond or else Cond1. If Cond is
- -- Empty, then simply returns Cond1 (this allows the use of Empty to
- -- initialize a series of checks evolved by this routine, with a final
- -- result of Empty indicating that no checks were required). The Sloc
- -- field of the constructed N_Or_Else node is copied from Cond1.
+ -- Rewrites Cond with the expression: Cond or else Cond1. If Cond is Empty,
+ -- then simply returns Cond1 (this allows the use of Empty to initialize a
+ -- series of checks evolved by this routine, with a final result of Empty
+ -- indicating that no checks were required). The Sloc field of the
+ -- constructed N_Or_Else node is copied from Cond1.
procedure Expand_Subtype_From_Expr
(N : Node_Id;
-- declarations and/or allocations when the type is indefinite (including
-- class-wide).
+ function Find_Interface_ADT
+ (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;
+ -- Ada 2005 (AI-251): Given a type T implementing the interface Iface,
+ -- return the record component containing the tag of Iface.
+
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
(Var : Node_Id;
Op : out Node_Kind;
Val : out Node_Id);
- -- This routine processes the Current_Value field of the variable Var.
- -- If the Current_Value field is null or if it represents a known value,
- -- then on return Cond is set to N_Empty, and Val is set to Empty.
+ -- This routine processes the Current_Value field of the variable Var. If
+ -- the Current_Value field is null or if it represents a known value, then
+ -- on return Cond is set to N_Empty, and Val is set to Empty.
--
- -- The other case is when Current_Value points to an N_If_Statement
- -- or an N_Elsif_Part (while statement). Such a setting only occurs
- -- if the condition of an IF or ELSIF is of the form X op Y, where X
- -- is the variable in question, Y is a compile-time known value, and
- -- op is one of the six possible relational operators.
+ -- The other case is when Current_Value points to an N_If_Statement or an
+ -- N_Elsif_Part (while statement). Such a setting only occurs if the
+ -- condition of an IF or ELSIF is of the form X op Y, where is the variable
+ -- in question, Y is a compile-time known value, and op is one of the six
+ -- possible relational operators.
--
- -- In this case, Get_Current_Condition digs out the condition, and
- -- then checks if the condition is known false, known true, or not
- -- known at all. In the first two cases, Get_Current_Condition will
- -- return with Op set to the appropriate conditional operator (inverted
- -- if the condition is known false), and Val set to the constant value.
- -- If the condition is not known, then Cond and Val are set for the
- -- empty case (N_Empty and Empty).
+ -- In this case, Get_Current_Condition digs out the condition, and then
+ -- checks if the condition is known false, known true, or not known at all.
+ -- In the first two cases, Get_Current_Condition will return with Op set to
+ -- the appropriate conditional operator (inverted if the condition is known
+ -- false), and Val set to the constant value. If the condition is not
+ -- known, then Cond and Val are set for the empty case (N_Empty and Empty).
--
-- The check for whether the condition is true/false unknown depends
-- on the case:
--
- -- For an IF, the condition is known true in the THEN part, known
- -- false in any ELSIF or ELSE part, and not known outside the IF
- -- statement in question.
+ -- For an IF, the condition is known true in the THEN part, known false
+ -- in any ELSIF or ELSE part, and not known outside the IF statement in
+ -- question.
--
- -- For an ELSIF, the condition is known true in the ELSIF part,
- -- known FALSE in any subsequent ELSIF, or ELSE part, and not
- -- known before the ELSIF, or after the end of the IF statement.
+ -- For an ELSIF, the condition is known true in the ELSIF part, known
+ -- FALSE in any subsequent ELSIF, or ELSE part, and not known before the
+ -- ELSIF, or after the end of the IF statement.
--
- -- The caller can use this result to determine the value (for the
- -- case of N_Op_Eq), or to determine the result of some other test
- -- in other cases (e.g. no access check required if N_Op_Ne Null).
+ -- The caller can use this result to determine the value (for the case of
+ -- N_Op_Eq), or to determine the result of some other test in other cases
+ -- (e.g. no access check required if N_Op_Ne Null).
function Homonym_Number (Subp : Entity_Id) return Nat;
-- Here subp is the entity for a subprogram. This routine returns the
- -- homonym number used to disambiguate overloaded subprograms in the
- -- same scope (the number is used as part of constructed names to make
- -- sure that they are unique). The number is the ordinal position on
- -- the Homonym chain, counting only entries in the curren scope. If
- -- an entity is not overloaded, the returned number will be one.
+ -- homonym number used to disambiguate overloaded subprograms in the same
+ -- scope (the number is used as part of constructed names to make sure that
+ -- they are unique). The number is the ordinal position on the Homonym
+ -- chain, counting only entries in the curren scope. If an entity is not
+ -- overloaded, the returned number will be one.
function Inside_Init_Proc return Boolean;
-- Returns True if current scope is within an init proc
function In_Unconditional_Context (Node : Node_Id) return Boolean;
- -- Node is the node for a statement or a component of a statement.
- -- This function deteermines if the statement appears in a context
- -- that is unconditionally executed, i.e. it is not within a loop
- -- or a conditional or a case statement etc.
+ -- Node is the node for a statement or a component of a statement. This
+ -- function deteermines if the statement appears in a context that is
+ -- unconditionally executed, i.e. it is not within a loop or a conditional
+ -- or a case statement etc.
function Is_All_Null_Statements (L : List_Id) return Boolean;
- -- Return True if all the items of the list are N_Null_Statement
- -- nodes. False otherwise. True for an empty list. It is an error
- -- to call this routine with No_List as the argument.
+ -- Return True if all the items of the list are N_Null_Statement nodes.
+ -- False otherwise. True for an empty list. It is an error to call this
+ -- routine with No_List as the argument.
+
+ function Is_Predefined_Dispatching_Operation
+ (Subp : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-251): Determines if Subp is a predefined primitive
+ -- operation.
function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean;
- -- Determine whether the node P is a reference to a bit packed
- -- array, i.e. whether the designated object is a component of
- -- a bit packed array, or a subcomponent of such a component.
- -- If so, then all subscripts in P are evaluated with a call
- -- to Force_Evaluation, and True is returned. Otherwise False
- -- is returned, and P is not affected.
+ -- Determine whether the node P is a reference to a bit packed array, i.e.
+ -- whether the designated object is a component of a bit packed array, or a
+ -- subcomponent of such a component. If so, then all subscripts in P are
+ -- evaluated with a call to Force_Evaluation, and True is returned.
+ -- Otherwise False is returned, and P is not affected.
function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean;
- -- Determine whether the node P is a reference to a bit packed
- -- slice, i.e. whether the designated object is bit packed slice
- -- or a component of a bit packed slice. Return True if so.
+ -- Determine whether the node P is a reference to a bit packed slice, i.e.
+ -- whether the designated object is bit packed slice or a component of a
+ -- bit packed slice. Return True if so.
function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean;
-- Determine whether the node P is a slice of an array where the slice
-- is not compatible with the type. Return True if so.
function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean;
- -- Node N is an object reference. This function returns True if it
- -- is possible that the object may not be aligned according to the
- -- normal default alignment requirement for its type (e.g. if it
- -- appears in a packed record, or as part of a component that has
- -- a component clause.
+ -- Node N is an object reference. This function returns True if it is
+ -- possible that the object may not be aligned according to the normal
+ -- default alignment requirement for its type (e.g. if it appears in a
+ -- packed record, or as part of a component that has a component clause.
function Is_Renamed_Object (N : Node_Id) return Boolean;
- -- Returns True if the node N is a renamed object. An expression
- -- is considered to be a renamed object if either it is the Name
- -- of an object renaming declaration, or is the prefix of a name
- -- which is a renamed object. For example, in:
+ -- Returns True if the node N is a renamed object. An expression is
+ -- considered to be a renamed object if either it is the Name of an object
+ -- renaming declaration, or is the prefix of a name which is a renamed
+ -- object. For example, in:
--
-- x : r renames a (1 .. 2) (1);
--
- -- We consider that a (1 .. 2) is a renamed object since it is the
- -- prefix of the name in the renaming declaration.
+ -- We consider that a (1 .. 2) is a renamed object since it is the prefix
+ -- of the name in the renaming declaration.
function Is_Untagged_Derivation (T : Entity_Id) return Boolean;
-- Returns true if type T is not tagged and is a derived type,
-- or is a private type whose completion is such a type.
procedure Kill_Dead_Code (N : Node_Id);
- -- N represents a node for a section of code that is known to be
- -- dead. The node is deleted, and any exception handler references
- -- and warning messages relating to this code are removed.
+ -- N represents a node for a section of code that is known to be dead. The
+ -- node is deleted, and any exception handler references and warning
+ -- messages relating to this code are removed.
procedure Kill_Dead_Code (L : List_Id);
-- Like the above procedure, but applies to every element in the given
-- a classwide type.
function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean;
- -- Determines if the given type, Typ, may require a large temporary
- -- of the kind that causes back-end trouble if stack checking is enabled.
- -- The result is True only the size of the type is known at compile time
- -- and large, where large is defined heuristically by the body of this
- -- routine. The purpose of this routine is to help avoid generating
- -- troublesome temporaries that interfere with stack checking mechanism.
- -- Note that the caller has to check whether stack checking is actually
- -- enabled in order to guide the expansion (typically of a function call).
+ -- Determines if the given type, Typ, may require a large temporary of the
+ -- kind that causes back-end trouble if stack checking is enabled. The
+ -- result is True only the size of the type is known at compile time and
+ -- large, where large is defined heuristically by the body of this routine.
+ -- The purpose of this routine is to help avoid generating troublesome
+ -- temporaries that interfere with stack checking mechanism. Note that the
+ -- caller has to check whether stack checking is actually enabled in order
+ -- to guide the expansion (typically of a function call).
procedure Remove_Side_Effects
(Exp : Node_Id;
Name_Req : Boolean := False;
Variable_Ref : Boolean := False);
- -- Given the node for a subexpression, this function replaces the node
- -- if necessary by an equivalent subexpression that is guaranteed to be
- -- side effect free. This is done by extracting any actions that could
- -- cause side effects, and inserting them using Insert_Actions into the
- -- tree to which Exp is attached. Exp must be analyzed and resolved
- -- before the call and is analyzed and resolved on return. The Name_Req
- -- may only be set to True if Exp has the form of a name, and the
- -- effect is to guarantee that any replacement maintains the form of a
- -- name. If Variable_Ref is set to TRUE, a variable is considered as a
- -- side effect (used in implementing Force_Evaluation). Note: after a
- -- call to Remove_Side_Effects, it is safe to call New_Copy_Tree to
- -- obtain a copy of the resulting expression.
+ -- Given the node for a subexpression, this function replaces the node if
+ -- necessary by an equivalent subexpression that is guaranteed to be side
+ -- effect free. This is done by extracting any actions that could cause
+ -- side effects, and inserting them using Insert_Actions into the tree to
+ -- which Exp is attached. Exp must be analyzed and resolved before the call
+ -- and is analyzed and resolved on return. The Name_Req may only be set to
+ -- True if Exp has the form of a name, and the effect is to guarantee that
+ -- any replacement maintains the form of name. If Variable_Ref is set to
+ -- TRUE, a variable is considered as side effect (used in implementing
+ -- Force_Evaluation). Note: after call to Remove_Side_Effects, it is safe
+ -- to call New_Copy_Tree to obtain a copy of the resulting expression.
function Represented_As_Scalar (T : Entity_Id) return Boolean;
-- Returns True iff the implementation of this type in code generation
-- packed arrays which are represented by a scalar (modular) type.
function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean;
- -- Given the node for an N_Unchecked_Type_Conversion, return True
- -- if this is an unchecked conversion that Gigi can handle directly.
- -- Otherwise return False if it is one for which the front end must
- -- provide a temporary. Note that the node need not be analyzed, and
- -- thus the Etype field may not be set, but in that case it must be
- -- the case that the Subtype_Mark field of the node is set/analyzed.
+ -- Given the node for an N_Unchecked_Type_Conversion, return True if this
+ -- is an unchecked conversion that Gigi can handle directly. Otherwise
+ -- return False if it is one for which the front end must provide a
+ -- temporary. Note that the node need not be analyzed, and thus the Etype
+ -- field may not be set, but in that case it must be the case that the
+ -- Subtype_Mark field of the node is set/analyzed.
procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id);
- -- N is the node for a subprogram or generic body, and Spec_Id
- -- is the entity for the corresponding spec. If an elaboration
- -- entity is defined, then this procedure generates an assignment
- -- statement to set it True, immediately after the body is elaborated.
- -- However, no assignment is generated in the case of library level
- -- procedures, since the setting of the flag in this case is generated
- -- in the binder. We do that so that we can detect cases where this is
- -- the only elaboration action that is required.
+ -- N is the node for a subprogram or generic body, and Spec_Id is the
+ -- entity for the corresponding spec. If an elaboration entity is defined,
+ -- then this procedure generates an assignment statement to set it True,
+ -- immediately after the body is elaborated. However, no assignment is
+ -- generated in the case of library level procedures, since the setting of
+ -- the flag in this case is generated in the binder. We do that so that we
+ -- can detect cases where this is the only elaboration action that is
+ -- required.
function Target_Has_Fixed_Ops
(Left_Typ : Entity_Id;
function Type_May_Have_Bit_Aligned_Components
(Typ : Entity_Id) return Boolean;
- -- Determines if Typ is a composite type that has within it (looking
- -- down recursively at any subcomponents), a record type which has a
- -- component that may be bit aligned (see Possible_Bit_Aligned_Component).
- -- The result is conservative, in that a result of False is decisive.
- -- A result of True means that such a component may or may not be present.
+ -- Determines if Typ is a composite type that has within it (looking down
+ -- recursively at any subcomponents), a record type which has component
+ -- that may be bit aligned (see Possible_Bit_Aligned_Component). The result
+ -- is conservative, in that a result of False is decisive. A result of True
+ -- means that such a component may or may not be present.
procedure Wrap_Cleanup_Procedure (N : Node_Id);
- -- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer
- -- call at the start of the statement sequence, and an Abort_Undefer call
- -- at the end of the statement sequence. All cleanup routines (i.e. those
- -- that are called from "at end" handlers) must defer abort on entry and
- -- undefer abort on exit. Note that it is assumed that the code for the
- -- procedure does not contain any return statements which would allow the
- -- flow of control to escape doing the undefer call.
+ -- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer call
+ -- at the start of the statement sequence, and an Abort_Undefer call at the
+ -- end of the statement sequence. All cleanup routines (i.e. those that are
+ -- called from "at end" handlers) must defer abort on entry and undefer
+ -- abort on exit. Note that it is assumed that the code for the procedure
+ -- does not contain any return statements which would allow the flow of
+ -- control to escape doing the undefer call.
private
pragma Inline (Force_Evaluation);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
-with Ada.Tags; use Ada.Tags;
-with System; use System;
-with System.Storage_Elements; use System.Storage_Elements;
+-- Dummy body to deal with bootstrap issues (there used to be a real body)
package body Interfaces.CPP is
-
--- Structure of the Dispatch Table
-
--- +-----------------------+
--- | Offset_To_Top |
--- +-----------------------+
--- | Typeinfo_Ptr/TSD_Ptr |----> Type Specific Data
--- Tag ---> +-----------------------+ +-------------------+
--- | table of | | inheritance depth |
--- : primitive ops : +-------------------+
--- | pointers | | expanded name |
--- +-----------------------+ +-------------------+
--- | external tag |
--- +-------------------+
--- | Hash table link |
--- +-------------------+
--- | Remotely Callable |
--- +-------------------+
--- | Rec Ctrler offset |
--- +-------------------+
--- | table of |
--- : ancestor :
--- | tags |
--- +-------------------+
-
- -- The declarations below need (extensive) comments ???
-
- subtype Cstring is String (Positive);
- type Cstring_Ptr is access all Cstring;
- type Tag_Table is array (Natural range <>) of Vtable_Ptr;
- pragma Suppress_Initialization (Tag_Table);
-
- type Type_Specific_Data is record
- Idepth : Natural;
- Expanded_Name : Cstring_Ptr;
- External_Tag : Cstring_Ptr;
- HT_Link : Tag;
- Ancestor_Tags : Tag_Table (Natural);
- end record;
-
- type Vtable_Entry is record
- Pfn : System.Address;
- end record;
-
- type Vtable_Entry_Array is array (Positive range <>) of Vtable_Entry;
-
- type VTable is record
- -- Offset_To_Top : Integer;
- -- Typeinfo_Ptr : System.Address; -- TSD is currently also here???
- Prims_Ptr : Vtable_Entry_Array (Positive);
- end record;
- -- Note: See comment in a-tags.adb explaining why the components
- -- Offset_To_Top and Typeinfo_Ptr have been commented out.
- -- -----------------------------------------------------------------------
- -- 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
- -- actual array size, allocates the Dispatch_Table record accordingly, and
- -- generates code that displaces the base of the record after the
- -- Typeinfo_Ptr component. For this reason the first two components have
- -- been commented in the previous declaration. The access to these
- -- components is done by means of local functions.
-
- ---------------------------
- -- Unchecked Conversions --
- ---------------------------
-
- type Int_Ptr is access Integer;
-
- function To_Int_Ptr is
- new Unchecked_Conversion (System.Address, Int_Ptr);
-
- function To_Cstring_Ptr is
- new Unchecked_Conversion (Address, Cstring_Ptr);
-
- function To_Address is
- new Unchecked_Conversion (Cstring_Ptr, Address);
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- 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).
-
- function Offset_To_Top (T : Vtable_Ptr) return Integer;
- -- Returns the current value of the offset_to_top component available in
- -- the prologue of the dispatch table.
-
- function Typeinfo_Ptr (T : Vtable_Ptr) return System.Address;
- -- Returns the current value of the typeinfo_ptr component available in
- -- the prologue of the dispatch table.
-
- pragma Unreferenced (Offset_To_Top);
- pragma Unreferenced (Typeinfo_Ptr);
- -- These functions will be used for full compatibility with the C++ ABI
-
- -----------------------
- -- CPP_CW_Membership --
- -----------------------
-
- function CPP_CW_Membership
- (Obj_Tag : Vtable_Ptr;
- Typ_Tag : Vtable_Ptr) return Boolean
- is
- Pos : constant Integer := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
- begin
- return Pos >= 0 and then TSD (Obj_Tag).Ancestor_Tags (Pos) = Typ_Tag;
- end CPP_CW_Membership;
-
- --------------------------
- -- CPP_Get_External_Tag --
- --------------------------
-
- function CPP_Get_External_Tag (T : Vtable_Ptr) return Address is
- begin
- return To_Address (TSD (T).External_Tag);
- end CPP_Get_External_Tag;
-
- -------------------------
- -- CPP_Get_Prim_Op_Address --
- -------------------------
-
- function CPP_Get_Prim_Op_Address
- (T : Vtable_Ptr;
- Position : Positive) return Address
- is
- begin
- return T.Prims_Ptr (Position).Pfn;
- end CPP_Get_Prim_Op_Address;
-
- -----------------------
- -- CPP_Get_RC_Offset --
- -----------------------
-
- function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is
- pragma Warnings (Off, T);
- begin
- return 0;
- end CPP_Get_RC_Offset;
-
- -------------------------------
- -- CPP_Get_Remotely_Callable --
- -------------------------------
-
- function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean is
- pragma Warnings (Off, T);
- begin
- return True;
- end CPP_Get_Remotely_Callable;
-
- --------------------
- -- CPP_Inherit_DT --
- --------------------
-
- procedure CPP_Inherit_DT
- (Old_T : Vtable_Ptr;
- New_T : Vtable_Ptr;
- Entry_Count : Natural)
- is
- begin
- if Old_T /= null then
- New_T.Prims_Ptr (1 .. Entry_Count)
- := Old_T.Prims_Ptr (1 .. Entry_Count);
- end if;
- end CPP_Inherit_DT;
-
- ---------------------
- -- CPP_Inherit_TSD --
- ---------------------
-
- procedure CPP_Inherit_TSD
- (Old_Tag : Vtable_Ptr;
- New_Tag : Vtable_Ptr)
- is
- New_TSD_Ptr : constant Type_Specific_Data_Ptr := TSD (New_Tag);
- Old_TSD_Ptr : Type_Specific_Data_Ptr;
-
- begin
- if Old_Tag /= null then
- Old_TSD_Ptr := TSD (Old_Tag);
- New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
- New_TSD_Ptr.Ancestor_Tags (1 .. New_TSD_Ptr.Idepth) :=
- Old_TSD_Ptr.Ancestor_Tags (0 .. Old_TSD_Ptr.Idepth);
- else
- New_TSD_Ptr.Idepth := 0;
- end if;
-
- New_TSD_Ptr.Ancestor_Tags (0) := New_Tag;
- end CPP_Inherit_TSD;
-
- ---------------------------
- -- CPP_Set_Expanded_Name --
- ---------------------------
-
- procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : Address) is
- begin
- TSD (T).Expanded_Name := To_Cstring_Ptr (Value);
- end CPP_Set_Expanded_Name;
-
- --------------------------
- -- CPP_Set_External_Tag --
- --------------------------
-
- procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : Address) is
- begin
- TSD (T).External_Tag := To_Cstring_Ptr (Value);
- end CPP_Set_External_Tag;
-
- -----------------------------
- -- CPP_Set_Prim_Op_Address --
- -----------------------------
-
- procedure CPP_Set_Prim_Op_Address
- (T : Vtable_Ptr;
- Position : Positive;
- Value : Address)
- is
- begin
- T.Prims_Ptr (Position).Pfn := Value;
- end CPP_Set_Prim_Op_Address;
-
- -----------------------
- -- CPP_Set_RC_Offset --
- -----------------------
-
- procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is
- pragma Warnings (Off, T);
- pragma Warnings (Off, Value);
- begin
- null;
- end CPP_Set_RC_Offset;
-
- -------------------------------
- -- CPP_Set_Remotely_Callable --
- -------------------------------
-
- procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean) is
- pragma Warnings (Off, T);
- pragma Warnings (Off, Value);
- begin
- null;
- end CPP_Set_Remotely_Callable;
-
- -----------------
- -- CPP_Set_TSD --
- -----------------
-
- procedure CPP_Set_TSD (T : Vtable_Ptr; Value : Address) is
- use type System.Storage_Elements.Storage_Offset;
- TSD_Ptr : constant Addr_Ptr :=
- To_Addr_Ptr (To_Address (T) - CPP_DT_Typeinfo_Ptr_Size);
- begin
- TSD_Ptr.all := Value;
- end CPP_Set_TSD;
-
- --------------------
- -- Displaced_This --
- --------------------
-
- function Displaced_This
- (Current_This : System.Address;
- Vptr : Vtable_Ptr;
- Position : Positive)
- return System.Address
- is
- pragma Warnings (Off, Vptr);
- pragma Warnings (Off, Position);
-
- begin
- return Current_This;
-
- -- why is the following here commented out ???
- -- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
- end Displaced_This;
-
- -------------------
- -- Expanded_Name --
- -------------------
-
- function Expanded_Name (T : Vtable_Ptr) return String is
- Result : constant Cstring_Ptr := TSD (T).Expanded_Name;
- begin
- return Result (1 .. Length (Result));
- end Expanded_Name;
-
- ------------------
- -- External_Tag --
- ------------------
-
- function External_Tag (T : Vtable_Ptr) return String is
- Result : constant Cstring_Ptr := TSD (T).External_Tag;
- begin
- return Result (1 .. Length (Result));
- end External_Tag;
-
- ------------
- -- Length --
- ------------
-
- function Length (Str : Cstring_Ptr) return Natural is
- Len : Integer := 1;
-
- begin
- while Str (Len) /= ASCII.Nul loop
- Len := Len + 1;
- end loop;
-
- return Len - 1;
- end Length;
-
- ------------------
- -- Offset_To_Top --
- ------------------
-
- function Offset_To_Top (T : Vtable_Ptr) return Integer is
- use type System.Storage_Elements.Storage_Offset;
-
- TSD_Ptr : constant Int_Ptr
- := To_Int_Ptr (To_Address (T) - CPP_DT_Prologue_Size);
- begin
- return TSD_Ptr.all;
- end Offset_To_Top;
-
- ------------------
- -- Typeinfo_Ptr --
- ------------------
-
- function Typeinfo_Ptr (T : Vtable_Ptr) return System.Address is
- use type System.Storage_Elements.Storage_Offset;
- TSD_Ptr : constant Addr_Ptr :=
- To_Addr_Ptr (To_Address (T) - CPP_DT_Typeinfo_Ptr_Size);
- begin
- return TSD_Ptr.all;
- end Typeinfo_Ptr;
-
- ---------
- -- TSD --
- ---------
-
- function TSD (T : Vtable_Ptr) return Type_Specific_Data_Ptr is
- use type System.Storage_Elements.Storage_Offset;
- TSD_Ptr : constant Addr_Ptr :=
- To_Addr_Ptr (To_Address (T) - CPP_DT_Typeinfo_Ptr_Size);
- begin
- return To_Type_Specific_Data_Ptr (TSD_Ptr.all);
- end TSD;
-
end Interfaces.CPP;
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT RUN-TIME COMPONENTS --
-- --
-- I N T E R F A C E S . C P P --
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
--- Definitions for interfacing to C++ classes
-
--- This package corresponds to Ada.Tags but applied to tagged types which are
--- are imported from C++ and correspond exactly to a C++ Class. The code that
--- the GNAT front end generates does not know about the structure of the C++
--- dispatch table (Vtable) but always accesses it through the procedural
--- interface defined in this package, thus the implementation of this package
--- (the body) can be customized to another C++ compiler without any change in
--- the compiler code itself as long as this procedural interface is respected.
--- Note that Ada.Tags defines a very similar procedural interface to the
--- regular Ada Dispatch Table.
-
-with System;
-with System.Storage_Elements;
-with Unchecked_Conversion;
+-- Missing package comment ???
+with Ada.Tags;
package Interfaces.CPP is
+pragma Elaborate_Body;
+-- We have a dummy body to deal with bootstrap path issues
- type Vtable_Ptr is private;
-
- function Expanded_Name (T : Vtable_Ptr) return String;
- function External_Tag (T : Vtable_Ptr) return String;
-
-private
- package S renames System;
- package SSE renames System.Storage_Elements;
-
- type Vtable;
- type Vtable_Ptr is access all Vtable;
-
- type Type_Specific_Data;
- type Type_Specific_Data_Ptr is access all Type_Specific_Data;
-
- -- These subprograms are in the private part. They are never accessed
- -- directly except from compiler generated code, which has access to
- -- private components of packages via the Rtsfind interface.
-
- procedure CPP_Set_Prim_Op_Address
- (T : Vtable_Ptr;
- Position : Positive;
- Value : S.Address);
- -- Given a pointer to a dispatch Table (T) and a position in the
- -- dispatch Table put the address of the virtual function in it
- -- (used for overriding)
-
- function CPP_Get_Prim_Op_Address
- (T : Vtable_Ptr;
- Position : Positive)
- return S.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)
-
- procedure CPP_Set_TSD (T : Vtable_Ptr; Value : S.Address);
- -- Given a pointer T to a dispatch Table, stores the address of the
- -- record containing the Type Specific Data generated by GNAT
-
- CPP_DT_Prologue_Size : constant SSE.Storage_Count :=
- SSE.Storage_Count
- (2 * (Standard'Address_Size / S.Storage_Unit));
- -- Size of the first part of the dispatch table
-
- CPP_DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count :=
- SSE.Storage_Count
- (Standard'Address_Size / System.Storage_Unit);
- -- Size of the Typeinfo_Ptr field of the Dispatch Table.
-
- CPP_DT_Entry_Size : constant SSE.Storage_Count :=
- SSE.Storage_Count
- (1 * (Standard'Address_Size / S.Storage_Unit));
- -- Size of each primitive operation entry in the Dispatch Table.
-
- CPP_TSD_Prologue_Size : constant SSE.Storage_Count :=
- SSE.Storage_Count
- (4 * (Standard'Address_Size / S.Storage_Unit));
- -- Size of the first part of the type specific data
-
- CPP_TSD_Entry_Size : constant SSE.Storage_Count :=
- SSE.Storage_Count
- (1 * (Standard'Address_Size / S.Storage_Unit));
- -- Size of each ancestor tag entry in the TSD
-
- procedure CPP_Inherit_DT
- (Old_T : Vtable_Ptr;
- New_T : Vtable_Ptr;
- Entry_Count : Natural);
- -- Entry point used to initialize the DT of a type knowing the
- -- tag of the direct ancestor and the number of primitive ops that are
- -- inherited (Entry_Count).
-
- procedure CPP_Inherit_TSD
- (Old_Tag : Vtable_Ptr;
- New_Tag : Vtable_Ptr);
- -- Entry point used to initialize the TSD of a type knowing the
- -- TSD of the direct ancestor.
-
- function CPP_CW_Membership (Obj_Tag, Typ_Tag : Vtable_Ptr) return Boolean;
- -- Given the tag of an object and the tag associated to a type, return
- -- true if Obj is in Typ'Class.
-
- procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : S.Address);
- -- Set the address of the string containing the external tag
- -- in the Dispatch table
-
- function CPP_Get_External_Tag (T : Vtable_Ptr) return S.Address;
- -- Retrieve the address of a null terminated string containing
- -- the external name
-
- procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : S.Address);
- -- Set the address of the string containing the expanded name
- -- in the Dispatch table
-
- procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean);
- -- Since the notions of spec/body distinction and categorized packages
- -- do not exist in C, this procedure will do nothing
-
- function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean;
- -- This function will always return True for the reason explained above
-
- procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset);
- -- Sets the Offset of the implicit record controller when the object
- -- has controlled components. Set to O otherwise.
-
- function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset;
- -- Return the Offset of the implicit record controller when the object
- -- has controlled components. O otherwise.
-
- function Displaced_This
- (Current_This : S.Address;
- Vptr : Vtable_Ptr;
- Position : Positive)
- return S.Address;
- -- Compute the displacement on the "this" pointer in order to be
- -- compatible with MI.
- -- (used for virtual function calls)
-
- function TSD (T : Vtable_Ptr) 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
-
- type Addr_Ptr is access System.Address;
-
- function To_Address is
- new Unchecked_Conversion (Vtable_Ptr, System.Address);
+ subtype Vtable_Ptr is Ada.Tags.Tag;
- function To_Addr_Ptr is
- new Unchecked_Conversion (System.Address, Addr_Ptr);
+ -- These need commenting (this is not an RM package!)
- function To_Type_Specific_Data_Ptr is
- new Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
+ function Expanded_Name (T : Vtable_Ptr) return String
+ renames Ada.Tags.Expanded_Name;
- pragma Inline (CPP_Set_Prim_Op_Address);
- pragma Inline (CPP_Get_Prim_Op_Address);
- pragma Inline (CPP_Set_TSD);
- pragma Inline (CPP_Inherit_DT);
- pragma Inline (CPP_CW_Membership);
- pragma Inline (CPP_Set_External_Tag);
- pragma Inline (CPP_Get_External_Tag);
- pragma Inline (CPP_Set_Expanded_Name);
- pragma Inline (CPP_Set_Remotely_Callable);
- pragma Inline (CPP_Get_Remotely_Callable);
- pragma Inline (Displaced_This);
- pragma Inline (TSD);
+ function External_Tag (T : Vtable_Ptr) return String
+ renames Ada.Tags.External_Tag;
end Interfaces.CPP;
if Token = Tok_Identifier then
- -- Ada 2005 (AI-284): Compiling in Ada95 mode we notify
- -- that interface, overriding, and synchronized are
- -- new reserved words
+ -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE,
+ -- OVERRIDING, and SYNCHRONIZED are new reserved words.
- if Ada_Version = Ada_95 then
+ if Ada_Version = Ada_95
+ and then Warn_On_Ada_2005_Compatibility
+ then
if Token_Name = Name_Overriding
or else Token_Name = Name_Synchronized
or else (Token_Name = Name_Interface
-- PRIVATE_EXTENSION_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
- -- [abstract] new ancestor_SUBTYPE_INDICATION with private;
+ -- [abstract] new ancestor_SUBTYPE_INDICATION
+ -- [and INTERFACE_LIST] with private;
-- TYPE_DEFINITION ::=
-- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
Typedef_Node := P_Interface_Type_Definition
(Is_Synchronized => True);
+ Abstract_Present := True;
case Saved_Token is
when Tok_Task =>
-- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
-- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
+ -- ACCESS_DEFINITION [:= EXPRESSION];
+ -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
-- NUMBER_DECLARATION ::=
Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
- Set_Object_Definition (Decl_Node,
- P_Subtype_Indication (Not_Null_Present));
+ if Token = Tok_Access then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("generalized use of anonymous access types " &
+ "is an Ada 2005 extension");
+ Error_Msg_SP
+ ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Set_Object_Definition
+ (Decl_Node, P_Access_Definition (Not_Null_Present));
+ else
+ Set_Object_Definition
+ (Decl_Node, P_Subtype_Indication (Not_Null_Present));
+ end if;
end if;
if Token = Tok_Renames then
else
Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
- Set_Object_Definition (Decl_Node,
- P_Subtype_Indication (Not_Null_Present));
+
+ -- Access definition (AI-406) or subtype indication.
+
+ if Token = Tok_Access then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("generalized use of anonymous access types " &
+ "is an Ada 2005 extension");
+ Error_Msg_SP
+ ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Set_Object_Definition
+ (Decl_Node, P_Access_Definition (Not_Null_Present));
+ else
+ Set_Object_Definition
+ (Decl_Node, P_Subtype_Indication (Not_Null_Present));
+ end if;
end if;
-- Array case
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
- -- Ada 2005 (AI-254)
+ -- Ada 2005 (AI-254, AI-406)
elsif Token = Tok_Not then
-- OBJECT_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
+ -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
+ -- ACCESS_DEFINITION [:= EXPRESSION];
-- OBJECT_RENAMING_DECLARATION ::=
-- ...
Acc_Node := P_Access_Definition (Not_Null_Present);
if Token /= Tok_Renames then
- Error_Msg_SC ("RENAMES expected");
- raise Error_Resync;
- end if;
+ Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
+ Set_Object_Definition (Decl_Node, Acc_Node);
+ goto init;
- Scan; -- past renames
- No_List;
- Decl_Node :=
- New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
- Set_Access_Definition (Decl_Node, Acc_Node);
- Set_Name (Decl_Node, P_Name);
+ else
+ Scan; -- past renames
+ No_List;
+ Decl_Node :=
+ New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
+ Set_Access_Definition (Decl_Node, Acc_Node);
+ Set_Name (Decl_Node, P_Name);
+ end if;
else
Type_Node := P_Subtype_Mark;
Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
+ -- Object declaration with access definition, or renaming.
+
if Token /= Tok_Renames then
- Error_Msg_SC ("RENAMES expected");
- raise Error_Resync;
- end if;
+ Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
+ Set_Object_Definition (Decl_Node, Acc_Node);
+ goto init; -- ??? is this really needed goes here anyway
- Scan; -- past renames
- No_List;
- Decl_Node :=
- New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
- Set_Access_Definition (Decl_Node, Acc_Node);
- Set_Name (Decl_Node, P_Name);
+ else
+ Scan; -- past renames
+ No_List;
+ Decl_Node :=
+ New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
+ Set_Access_Definition (Decl_Node, Acc_Node);
+ Set_Name (Decl_Node, P_Name);
+ end if;
-- Subtype indication case
-- Scan out initialization, allowed only for object declaration
+ <<init>> -- is this really needed ???
Init_Loc := Token_Ptr;
Init_Expr := Init_Expr_Opt;
Make_Private_Extension_Declaration (No_Location,
Defining_Identifier => Empty,
Subtype_Indication => Subtype_Indication (Typedef_Node),
- Abstract_Present => Abstract_Present (Typedef_Node));
+ Abstract_Present => Abstract_Present (Typedef_Node),
+ Interface_List => Interface_List (Typedef_Node));
Delete_Node (Typedef_Node);
return Typedecl_Node;
Check_Bad_Layout;
P_Identifier_Declarations (Decls, Done, In_Spec);
+ -- Ada2005: A subprogram declaration can start with "not" or
+ -- "overriding". In older versions, "overriding" is handled
+ -- like an identifier, with the appropriate warning.
+
+ when Tok_Not =>
+ Check_Bad_Layout;
+ Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+ Done := False;
+
+ when Tok_Overriding =>
+ Check_Bad_Layout;
+ Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+ Done := False;
+
when Tok_Package =>
Check_Bad_Layout;
Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
-- --
-- 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- --
RE_Stream_Access, -- Ada.Streams.Stream_IO
+ RE_Addr_Ptr, -- Ada.Tags
RE_CW_Membership, -- Ada.Tags
+ RE_IW_Membership, -- Ada.Tags
+ RE_Descendant_Tag, -- Ada.Tags
RE_DT_Entry_Size, -- Ada.Tags
RE_DT_Prologue_Size, -- Ada.Tags
RE_External_Tag, -- Ada.Tags
+ RE_Get_Access_Level, -- Ada.Tags
RE_Get_External_Tag, -- Ada.Tags
RE_Get_Prim_Op_Address, -- Ada.Tags
RE_Get_RC_Offset, -- Ada.Tags
RE_Inherit_DT, -- Ada.Tags
RE_Inherit_TSD, -- Ada.Tags
RE_Internal_Tag, -- Ada.Tags
+ RE_Is_Descendant_At_Same_Level, -- Ada.Tags
+ RE_Register_Interface_Tag, -- Ada.Tags
RE_Register_Tag, -- Ada.Tags
+ RE_Set_Access_Level, -- Ada.Tags
RE_Set_Expanded_Name, -- Ada.Tags
RE_Set_External_Tag, -- Ada.Tags
+ RE_Set_Offset_To_Top, -- Ada.Tags
RE_Set_Prim_Op_Address, -- Ada.Tags
RE_Set_RC_Offset, -- Ada.Tags
RE_Set_Remotely_Callable, -- Ada.Tags
RE_Tag_Error, -- Ada.Tags
RE_TSD_Entry_Size, -- Ada.Tags
RE_TSD_Prologue_Size, -- Ada.Tags
+ RE_Interface_Tag, -- Ada.Tags
RE_Tag, -- Ada.Tags
RE_Address_Array, -- Ada.Tags
RE_Stream_Access => Ada_Streams_Stream_IO,
+ RE_Addr_Ptr => Ada_Tags,
RE_CW_Membership => Ada_Tags,
+ RE_IW_Membership => Ada_Tags,
+ RE_Descendant_Tag => Ada_Tags,
RE_DT_Entry_Size => Ada_Tags,
RE_DT_Prologue_Size => Ada_Tags,
RE_External_Tag => Ada_Tags,
+ RE_Get_Access_Level => Ada_Tags,
RE_Get_External_Tag => Ada_Tags,
RE_Get_Prim_Op_Address => Ada_Tags,
RE_Get_RC_Offset => Ada_Tags,
RE_Inherit_DT => Ada_Tags,
RE_Inherit_TSD => Ada_Tags,
RE_Internal_Tag => Ada_Tags,
+ RE_Is_Descendant_At_Same_Level => Ada_Tags,
+ RE_Register_Interface_Tag => Ada_Tags,
RE_Register_Tag => Ada_Tags,
+ RE_Set_Access_Level => Ada_Tags,
RE_Set_Expanded_Name => Ada_Tags,
RE_Set_External_Tag => Ada_Tags,
+ RE_Set_Offset_To_Top => Ada_Tags,
RE_Set_Prim_Op_Address => Ada_Tags,
RE_Set_RC_Offset => Ada_Tags,
RE_Set_Remotely_Callable => Ada_Tags,
RE_Tag_Error => Ada_Tags,
RE_TSD_Entry_Size => Ada_Tags,
RE_TSD_Prologue_Size => Ada_Tags,
+ RE_Interface_Tag => Ada_Tags,
RE_Tag => Ada_Tags,
RE_Address_Array => Ada_Tags,
-- --
-- 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- --
-- parent at the end of the instantiation (see Remove_Parent).
type Instance_Env is record
- Ada_Version : Ada_Version_Type;
- Instantiated_Parent : Assoc;
- Exchanged_Views : Elist_Id;
- Hidden_Entities : Elist_Id;
- Current_Sem_Unit : Unit_Number_Type;
- Parent_Unit_Visible : Boolean := False;
+ Ada_Version : Ada_Version_Type;
+ Ada_Version_Explicit : Ada_Version_Type;
+ Instantiated_Parent : Assoc;
+ Exchanged_Views : Elist_Id;
+ Hidden_Entities : Elist_Id;
+ Current_Sem_Unit : Unit_Number_Type;
+ Parent_Unit_Visible : Boolean := False;
end record;
package Instance_Envs is new Table.Table (
end if;
Formal := New_Copy (Pack_Id);
+ Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
+
New_N :=
Copy_Generic_Node
(Original_Node (Gen_Decl), Empty, Instantiating => True);
-- generic is not a child unit of another generic, to avoid scope
-- problems and the reinstallation of parent instances.
- if Front_End_Inlining
- and then Expander_Active
+ if Expander_Active
and then (not Is_Child_Unit (Gen_Unit)
or else not Is_Generic_Unit (Scope (Gen_Unit)))
- and then (Is_In_Main_Unit (N)
- or else In_Main_Context (Current_Scope))
- and then Nkind (Parent (N)) /= N_Compilation_Unit
and then Might_Inline_Subp
and then not Is_Actual_Pack
then
- Inline_Now := True;
+ if Front_End_Inlining
+ and then (Is_In_Main_Unit (N)
+ or else In_Main_Context (Current_Scope))
+ and then Nkind (Parent (N)) /= N_Compilation_Unit
+ then
+ Inline_Now := True;
+
+ -- In configurable_run_time mode we force the inlining of
+ -- predefined subprogram marked Inline_Always, to minimize
+ -- the use of the run-time library.
+
+ elsif Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
+ and then Configurable_Run_Time_Mode
+ and then Nkind (Parent (N)) /= N_Compilation_Unit
+ then
+ Inline_Now := True;
+ end if;
end if;
Needs_Body :=
or else Might_Inline_Subp)
and then not Is_Actual_Pack
and then not Inline_Now
-
and then (Operating_Mode = Generate_Code
or else (Operating_Mode = Check_Semantics
and then ASIS_Mode));
end if;
-- If the current context is generic, and the package being
- -- instantiated is declared within a formal package, there
- -- is no body to instantiate until the enclosing generic is
- -- instantiated, and there is an actual for the formal
- -- package. If the formal package has parameters, we build a
- -- regular package instance for it, that preceeds the original
- -- formal package declaration.
+ -- instantiated is declared within a formal package, there is no
+ -- body to instantiate until the enclosing generic is instantiated
+ -- and there is an actual for the formal package. If the formal
+ -- package has parameters, we build regular package instance for
+ -- it, that preceeds the original formal package declaration.
if In_Open_Scopes (Scope (Scope (Gen_Unit))) then
declare
end if;
end;
- -- If we are generating the calling stubs from the instantiation
- -- of a generic RCI package, we will not use the body of the
- -- generic package.
+ -- If we are generating the calling stubs from the instantiation of
+ -- a generic RCI package, we will not use the body of the generic
+ -- package.
if Distribution_Stub_Mode = Generate_Caller_Stub_Body
and then Is_Compilation_Unit (Defining_Entity (N))
end if;
end if;
- -- There is a problem with inlining here.
+ -- There is a problem with inlining here
+ -- More comments needed??? what problem
Set_Unit (Parent (N), Act_Decl);
Set_Parent_Spec (Act_Decl, Parent_Spec (N));
Check_Elab_Instantiation (N);
end if;
+ if Is_Dispatching_Operation (Act_Decl_Id)
+ and then Ada_Version >= Ada_05
+ then
+ declare
+ Formal : Entity_Id;
+
+ begin
+ Formal := First_Formal (Act_Decl_Id);
+ while Present (Formal) loop
+ if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+ and then Is_Controlling_Formal (Formal)
+ and then not Can_Never_Be_Null (Formal)
+ then
+ Error_Msg_NE ("access parameter& is controlling,",
+ N, Formal);
+ Error_Msg_NE ("\corresponding parameter of & must be"
+ & " explicitly null-excluding", N, Gen_Id);
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+ end;
+ end if;
+
Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
-- Subject to change, pending on if other pragmas are inherited ???
Validate_Categorization_Dependency (N, Act_Decl_Id);
if not Is_Intrinsic_Subprogram (Act_Decl_Id) then
-
if not Generic_Separately_Compiled (Gen_Unit) then
Inherit_Context (Gen_Decl, N);
end if;
or else Is_Inlined (Act_Decl_Id))
and then (Operating_Mode = Generate_Code
or else (Operating_Mode = Check_Semantics
- and then ASIS_Mode))
+ and then ASIS_Mode))
and then (Expander_Active or else ASIS_Mode)
and then not ABE_Is_Certain (N)
and then not Is_Eliminated (Act_Decl_Id)
(E1, E2 : Entity_Id) return Boolean
is
Ent : Entity_Id;
+
begin
Ent := E2;
while Present (Ent) loop
Saved : Instance_Env;
begin
- Saved.Ada_Version := Ada_Version;
- Saved.Instantiated_Parent := Current_Instantiated_Parent;
- Saved.Exchanged_Views := Exchanged_Views;
- Saved.Hidden_Entities := Hidden_Entities;
- Saved.Current_Sem_Unit := Current_Sem_Unit;
- Saved.Parent_Unit_Visible := Parent_Unit_Visible;
+ Saved.Ada_Version := Ada_Version;
+ Saved.Ada_Version_Explicit := Ada_Version_Explicit;
+ Saved.Instantiated_Parent := Current_Instantiated_Parent;
+ Saved.Exchanged_Views := Exchanged_Views;
+ Saved.Hidden_Entities := Hidden_Entities;
+ Saved.Current_Sem_Unit := Current_Sem_Unit;
+ Saved.Parent_Unit_Visible := Parent_Unit_Visible;
Instance_Envs.Increment_Last;
Instance_Envs.Table (Instance_Envs.Last) := Saved;
Nam := Make_Identifier (Loc, Chars (Formal_Sub));
end if;
+ elsif Nkind (Specification (Formal)) = N_Procedure_Specification
+ and then Null_Present (Specification (Formal))
+ then
+ -- Generate null body for procedure, for use in the instance
+
+ Decl_Node :=
+ Make_Subprogram_Body (Loc,
+ Specification => New_Spec,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Make_Null_Statement (Loc))));
+
+ Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec));
+ return Decl_Node;
+
else
Error_Msg_Sloc := Sloc (Scope (Analyzed_S));
Error_Msg_NE
Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T)));
end if;
- if not Is_Ancestor (Base_Type (Ancestor), Act_T) then
+ -- Ada 2005 (AI-251)
+
+ if Ada_Version >= Ada_05
+ and then Is_Interface (Ancestor)
+ then
+ if not Interface_Present_In_Ancestor (Act_T, Ancestor) then
+ Error_Msg_NE
+ ("(Ada 2005) expected type implementing & in instantiation",
+ Actual, Ancestor);
+ end if;
+
+ elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then
Error_Msg_NE
("expect type derived from & in instantiation",
Actual, First_Subtype (Ancestor));
begin
Ada_Version := Saved.Ada_Version;
+ Ada_Version_Explicit := Saved.Ada_Version_Explicit;
if No (Current_Instantiated_Parent.Act_Id) then
(Gen_Unit : Entity_Id;
Act_Unit : Entity_Id)
is
-
begin
-- Regardless of the current mode, predefined units are analyzed in
-- the most current Ada mode, and earlier version Ada checks do not
-- apply to predefined units.
+ -- Why is this not using the routine Opt.Set_Opt_Config_Switches ???
+
if Is_Internal_File_Name
(Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
Renamings_Included => True) then
Ada_Version := Ada_Version_Type'Last;
+ Ada_Version_Explicit := Ada_Version_Explicit_Config;
end if;
Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);
-- --
-- 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- --
-- Local Subprograms --
-----------------------
+ procedure Add_Interface_Tag_Components
+ (N : Node_Id; Typ : Entity_Id);
+ -- Ada 2005 (AI-251): Add the tag components corresponding to all the
+ -- abstract interface types implemented by a record type or a derived
+ -- record type.
+
procedure Build_Derived_Type
(N : Node_Id;
Parent_Type : Entity_Id;
-- False is for an implicit derived full type for a type derived from a
-- private type (see Build_Derived_Type).
+ procedure Collect_Interfaces
+ (N : Node_Id;
+ Derived_Type : Entity_Id);
+ -- Ada 2005 (AI-251): Subsidiary procedure to Build_Derived_Record_Type.
+ -- Collect the list of interfaces that are not already implemented by the
+ -- ancestors. This is the list of interfaces for which we must provide
+ -- additional tag components.
+
+ procedure Complete_Subprograms_Derivation
+ (Partial_View : Entity_Id;
+ Derived_Type : Entity_Id);
+ -- Ada 2005 (AI-251): Used to complete type derivation of private tagged
+ -- types implementing interfaces. In this case some interface primitives
+ -- may have been overriden with the partial-view and, instead of
+ -- re-calculating them, they are included in the list of primitive
+ -- operations of the full-view.
+
function Inherit_Components
(N : Node_Id;
Parent_Base : Entity_Id;
-- the appropriate semantic fields. If the full view of the parent is
-- a record type, build constrained components of subtype.
+ procedure Derive_Interface_Subprograms
+ (Derived_Type : Entity_Id);
+ -- Ada 2005 (AI-251): Subsidiary procedure to Build_Derived_Record_Type.
+ -- Traverse the list of implemented interfaces and derive all their
+ -- subprograms.
+
procedure Derived_Standard_Character
(N : Node_Id;
Parent_Type : Entity_Id;
-- defined in the N_Full_Type_Declaration node N, that is T is the
-- derived type.
- function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id;
- -- Given a subtype indication S (which is really an N_Subtype_Indication
- -- node or a plain N_Identifier), find the type of the subtype mark.
-
procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id);
-- Insert each literal in symbol table, as an overloadable identifier
-- Each enumeration type is mapped into a sequence of integers, and
Error_Msg_N ("task entries cannot have access parameters", N);
end if;
+ -- Ada 2005: for an object declaration, the corresponding anonymous
+ -- type is declared in the current scope. For access formals, access
+ -- components, and access discriminants, the scope is that of the
+ -- enclosing declaration, as set above.
+
+ if Nkind (Related_Nod) = N_Object_Declaration then
+ Set_Scope (Anon_Type, Current_Scope);
+ end if;
+
+ if All_Present (N)
+ and then Ada_Version >= Ada_05
+ then
+ Error_Msg_N ("ALL is not permitted for anonymous access types", N);
+ end if;
+
-- Ada 2005 (AI-254): In case of anonymous access to subprograms
-- call the corresponding semantic routine
Set_Is_Access_Constant (Anon_Type, Constant_Present (N));
- -- The context is either a subprogram declaration or an access
- -- discriminant, in a private or a full type declaration. In the case
- -- of a subprogram, If the designated type is incomplete, the operation
- -- will be a primitive operation of the full type, to be updated
- -- subsequently. If the type is imported through a limited with clause,
- -- it is not a primitive operation of the type (which is declared
- -- elsewhere in some other scope).
+ -- The context is either a subprogram declaration, object declaration,
+ -- or an access discriminant, in a private or a full type declaration.
+ -- In the case of a subprogram, if the designated type is incomplete,
+ -- the operation will be a primitive operation of the full type, to be
+ -- updated subsequently. If the type is imported through a limited_with
+ -- clause, the subprogram is not a primitive operation of the type
+ -- (which is declared elsewhere in some other scope).
if Ekind (Desig_Type) = E_Incomplete_Type
and then not From_With_Type (Desig_Type)
Desig_Type : constant Entity_Id :=
Create_Itype (E_Subprogram_Type, Parent (T_Def));
+ D_Ityp : Node_Id := Associated_Node_For_Itype (Desig_Type);
begin
+ -- Associate the Itype node with the inner full-type declaration
+ -- or subprogram spec. This is required to handle nested anonymous
+ -- declarations. For example:
+
+ -- procedure P
+ -- (X : access procedure
+ -- (Y : access procedure
+ -- (Z : access T)))
+
+ while Nkind (D_Ityp) /= N_Full_Type_Declaration
+ and then Nkind (D_Ityp) /= N_Procedure_Specification
+ and then Nkind (D_Ityp) /= N_Function_Specification
+ and then Nkind (D_Ityp) /= N_Object_Renaming_Declaration
+ and then Nkind (D_Ityp) /= N_Formal_Type_Declaration
+ loop
+ D_Ityp := Parent (D_Ityp);
+ pragma Assert (D_Ityp /= Empty);
+ end loop;
+
+ Set_Associated_Node_For_Itype (Desig_Type, D_Ityp);
+
+ if Nkind (D_Ityp) = N_Procedure_Specification
+ or else Nkind (D_Ityp) = N_Function_Specification
+ then
+ Set_Scope (Desig_Type, Scope (Defining_Unit_Name (D_Ityp)));
+
+ elsif Nkind (D_Ityp) = N_Full_Type_Declaration
+ or else Nkind (D_Ityp) = N_Object_Renaming_Declaration
+ or else Nkind (D_Ityp) = N_Formal_Type_Declaration
+ then
+ Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp)));
+ end if;
+
if Nkind (T_Def) = N_Access_Function_Definition then
Analyze (Subtype_Mark (T_Def));
Set_Etype (Desig_Type, Entity (Subtype_Mark (T_Def)));
Set_Is_Access_Constant (T, Constant_Present (Def));
end Access_Type_Declaration;
+ ----------------------------------
+ -- Add_Interface_Tag_Components --
+ ----------------------------------
+
+ procedure Add_Interface_Tag_Components
+ (N : Node_Id;
+ Typ : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Elmt : Elmt_Id;
+ Ext : Node_Id;
+ L : List_Id;
+ Last_Tag : Node_Id;
+ Comp : Node_Id;
+
+ procedure Add_Tag (Iface : Entity_Id);
+ -- Comment required ???
+
+ -------------
+ -- Add_Tag --
+ -------------
+
+ procedure Add_Tag (Iface : Entity_Id) is
+ Def : Node_Id;
+ Tag : Entity_Id;
+ Decl : Node_Id;
+
+ begin
+ pragma Assert (Is_Tagged_Type (Iface)
+ and then Is_Interface (Iface));
+
+ Def :=
+ Make_Component_Definition (Loc,
+ Aliased_Present => True,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Interface_Tag), Loc));
+
+ Tag := Make_Defining_Identifier (Loc, New_Internal_Name ('V'));
+
+ Decl :=
+ Make_Component_Declaration (Loc,
+ Defining_Identifier => Tag,
+ Component_Definition => Def);
+
+ Analyze_Component_Declaration (Decl);
+
+ Set_Analyzed (Decl);
+ Set_Ekind (Tag, E_Component);
+ Set_Is_Limited_Record (Tag);
+ Set_Is_Tag (Tag);
+ Init_Component_Location (Tag);
+
+ pragma Assert (Is_Frozen (Iface));
+
+ Set_DT_Entry_Count (Tag,
+ DT_Entry_Count (First_Entity (Iface)));
+
+ if not Present (Last_Tag) then
+ Prepend (Decl, L);
+ else
+ Insert_After (Last_Tag, Decl);
+ end if;
+
+ Last_Tag := Decl;
+ end Add_Tag;
+
+ -- Start of procesing for Add_Interface_Tag_Components
+
+ begin
+ if Ekind (Typ) /= E_Record_Type
+ or else not Present (Abstract_Interfaces (Typ))
+ or else Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
+ then
+ return;
+ end if;
+
+ if Present (Abstract_Interfaces (Typ)) then
+
+ -- Find the current last tag
+
+ if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
+ Ext := Record_Extension_Part (Type_Definition (N));
+ else
+ pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition);
+ Ext := Type_Definition (N);
+ end if;
+
+ Last_Tag := Empty;
+
+ if not (Present (Component_List (Ext))) then
+ Set_Null_Present (Ext, False);
+ L := New_List;
+ Set_Component_List (Ext,
+ Make_Component_List (Loc,
+ Component_Items => L,
+ Null_Present => False));
+ else
+ if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
+ L := Component_Items
+ (Component_List
+ (Record_Extension_Part
+ (Type_Definition (N))));
+ else
+ L := Component_Items
+ (Component_List
+ (Type_Definition (N)));
+ end if;
+
+ -- Find the last tag component
+
+ Comp := First (L);
+
+ while Present (Comp) loop
+ if Is_Tag (Defining_Identifier (Comp)) then
+ Last_Tag := Comp;
+ end if;
+
+ Next (Comp);
+ end loop;
+ end if;
+
+ -- At this point L references the list of components and Last_Tag
+ -- references the current last tag (if any). Now we add the tag
+ -- corresponding with all the interfaces that are not implemented
+ -- by the parent.
+
+ pragma Assert (Present
+ (First_Elmt (Abstract_Interfaces (Typ))));
+
+ Elmt := First_Elmt (Abstract_Interfaces (Typ));
+ while Present (Elmt) loop
+ Add_Tag (Node (Elmt));
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+ end Add_Interface_Tag_Components;
+
-----------------------------------
-- Analyze_Component_Declaration --
-----------------------------------
T := Access_Definition
(Related_Nod => N,
N => Access_Definition (Component_Definition (N)));
-
- -- Ada 2005 (AI-230): In case of components that are anonymous
- -- access types the level of accessibility depends on the enclosing
- -- type declaration
-
- Set_Scope (T, Current_Scope); -- Ada 2005 (AI-230)
+ Set_Is_Local_Anonymous_Access (T);
-- Ada 2005 (AI-254)
-- If the subtype is a constrained subtype of the enclosing record,
-- (which must have a partial view) the back-end does not handle
- -- properly the recursion. Rewrite the component declaration with
- -- an explicit subtype indication, which is acceptable to Gigi. We
- -- can copy the tree directly because side effects have already been
- -- removed from discriminant constraints.
+ -- properly the recursion. Rewrite the component declaration with an
+ -- explicit subtype indication, which is acceptable to Gigi. We can copy
+ -- the tree directly because side effects have already been removed from
+ -- discriminant constraints.
if Ekind (T) = E_Access_Subtype
and then Is_Entity_Name (Subtype_Indication (Component_Definition (N)))
Null_Exclusion_Static_Checks (N);
end if;
- -- If this component is private (or depends on a private type),
- -- flag the record type to indicate that some operations are not
- -- available.
+ -- If this component is private (or depends on a private type), flag the
+ -- record type to indicate that some operations are not available.
P := Private_Component (T);
-- Protected objects with interrupt handlers must be at library level
- if Has_Interrupt_Handler (T) then
+ -- Ada 2005: this test is not needed (and the corresponding clause
+ -- in the RM is removed) because accessibility checks are sufficient
+ -- to make handlers not at the library level illegal.
+
+ if Has_Interrupt_Handler (T)
+ and then Ada_Version < Ada_05
+ then
Error_Msg_N
("interrupt object can only be declared at library level", Id);
end if;
Parent_Base : Entity_Id;
begin
+ -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor
+ -- interfaces
+
+ if Is_Non_Empty_List (Interface_List (N)) then
+ declare
+ I : Node_Id := First (Interface_List (N));
+ T : Entity_Id;
+ begin
+ while Present (I) loop
+ T := Find_Type_Of_Subtype_Indic (I);
+
+ if not Is_Interface (T) then
+ Error_Msg_NE ("(Ada 2005) & must be an interface", I, T);
+ end if;
+
+ Next (I);
+ end loop;
+ end;
+ end if;
+
Generate_Definition (T);
Enter_Name (T);
Element_Type := Access_Definition
(Related_Nod => Related_Id,
N => Access_Definition (Component_Def));
+ Set_Is_Local_Anonymous_Access (Element_Type);
-- Ada 2005 (AI-230): In case of components that are anonymous
-- access types the level of accessibility depends on the enclosing
elsif Is_Abstract (Element_Type) then
Error_Msg_N
- ("The type of a component cannot be abstract",
+ ("the type of a component cannot be abstract",
Subtype_Indication (Component_Def));
end if;
Last_Discrim : Entity_Id;
Constrs : Elist_Id;
- Discs : Elist_Id := New_Elmt_List;
+ Discs : Elist_Id := New_Elmt_List;
-- An empty Discs list means that there were no constraints in the
-- subtype indication or that there was an error processing it.
- Assoc_List : Elist_Id;
- New_Discrs : Elist_Id;
- New_Base : Entity_Id;
- New_Decl : Node_Id;
- New_Indic : Node_Id;
+ Assoc_List : Elist_Id;
+ New_Discrs : Elist_Id;
+ New_Base : Entity_Id;
+ New_Decl : Node_Id;
+ New_Indic : Node_Id;
Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type);
Discriminant_Specs : constant Boolean :=
Private_Extension : constant Boolean :=
(Nkind (N) = N_Private_Extension_Declaration);
- Constraint_Present : Boolean;
- Inherit_Discrims : Boolean := False;
-
- Save_Etype : Entity_Id;
- Save_Discr_Constr : Elist_Id;
- Save_Next_Entity : Entity_Id;
+ Constraint_Present : Boolean;
+ Has_Interfaces : Boolean := False;
+ Inherit_Discrims : Boolean := False;
+ Last_Inherited_Prim_Op : Elmt_Id;
+ Tagged_Partial_View : Entity_Id;
+ Save_Etype : Entity_Id;
+ Save_Discr_Constr : Elist_Id;
+ Save_Next_Entity : Entity_Id;
begin
if Ekind (Parent_Type) = E_Record_Type_With_Private
Freeze_Before (N, Parent_Type);
end if;
- if Type_Access_Level (Derived_Type) /= Type_Access_Level (Parent_Type)
+ -- In Ada 2005 (AI-344), the restriction that a derived tagged type
+ -- cannot be declared at a deeper level than its parent type is
+ -- removed. The check on derivation within a generic body is also
+ -- relaxed, but there's a restriction that a derived tagged type
+ -- cannot be declared in a generic body if it's derived directly
+ -- or indirectly from a formal type of that generic.
+
+ if Ada_Version >= Ada_05 then
+ if Present (Enclosing_Generic_Body (Derived_Type)) then
+ declare
+ Ancestor_Type : Entity_Id := Parent_Type;
+
+ begin
+ -- Check to see if any ancestor of the derived type is a
+ -- formal type.
+
+ while not Is_Generic_Type (Ancestor_Type)
+ and then Etype (Ancestor_Type) /= Ancestor_Type
+ loop
+ Ancestor_Type := Etype (Ancestor_Type);
+ end loop;
+
+ -- If the derived type does have a formal type as an
+ -- ancestor, then it's an error if the derived type is
+ -- declared within the body of the generic unit that
+ -- declares the formal type in its generic formal part. It's
+ -- sufficient to check whether the ancestor type is declared
+ -- inside the same generic body as the derived type (such as
+ -- within a nested generic spec), in which case the
+ -- derivation is legal. If the formal type is declared
+ -- outside of that generic body, then it's guaranteed that
+ -- the derived type is declared within the generic body of
+ -- the generic unit declaring the formal type.
+
+ if Is_Generic_Type (Ancestor_Type)
+ and then Enclosing_Generic_Body (Ancestor_Type) /=
+ Enclosing_Generic_Body (Derived_Type)
+ then
+ Error_Msg_NE
+ ("parent type of& must not be descendant of formal type"
+ & " of an enclosing generic body",
+ Indic, Derived_Type);
+ end if;
+ end;
+ end if;
+
+ elsif Type_Access_Level (Derived_Type) /=
+ Type_Access_Level (Parent_Type)
and then not Is_Generic_Type (Derived_Type)
then
if Is_Controlled (Parent_Type) then
end if;
end if;
+ -- Ada 2005 (AI-251)
+
+ if Ada_Version = Ada_05
+ and then Is_Tagged
+ then
+
+ -- "The declaration of a specific descendant of an interface type
+ -- freezes the interface type" (RM 13.14).
+
+ declare
+ Iface : Node_Id;
+ begin
+ if Is_Non_Empty_List (Interface_List (Type_Def)) then
+ Iface := First (Interface_List (Type_Def));
+
+ while Present (Iface) loop
+ Freeze_Before (N, Etype (Iface));
+ Next (Iface);
+ end loop;
+ end if;
+ end;
+ end if;
+
-- STEP 1b : preliminary cleanup of the full view of private types
-- If the type is already marked as having discriminants, then it's the
Set_Is_Tagged_Type (Derived_Type, Is_Tagged);
Set_Stored_Constraint (Derived_Type, No_Elist);
+ -- Ada 2005 (AI-251): Private type-declarations can implement interfaces
+ -- but cannot be interfaces
+
+ if not Private_Extension
+ and then Ekind (Derived_Type) /= E_Private_Type
+ and then Ekind (Derived_Type) /= E_Limited_Private_Type
+ then
+ Set_Is_Interface (Derived_Type, Interface_Present (Type_Def));
+ Set_Abstract_Interfaces (Derived_Type, No_Elist);
+ end if;
+
-- Fields inherited from the Parent_Type
Set_Discard_Names
(Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs));
end if;
+ -- Ada 2005 (AI-251): Look for the partial view of tagged types
+ -- declared in the private part. This will be used 1) to check that
+ -- the set of interfaces in both views is equal, and 2) to complete
+ -- the derivation of subprograms covering interfaces.
+
+ Tagged_Partial_View := Empty;
+
+ if Has_Private_Declaration (Derived_Type) then
+ Tagged_Partial_View := Next_Entity (Derived_Type);
+ loop
+ exit when Has_Private_Declaration (Tagged_Partial_View)
+ and then Full_View (Tagged_Partial_View) = Derived_Type;
+
+ Next_Entity (Tagged_Partial_View);
+ end loop;
+ end if;
+
+ -- Ada 2005 (AI-251): Collect the whole list of implemented
+ -- interfaces.
+
+ if Ada_Version >= Ada_05 then
+ Set_Abstract_Interfaces (Derived_Type, New_Elmt_List);
+
+ if Nkind (N) = N_Private_Extension_Declaration then
+ Collect_Interfaces (N, Derived_Type);
+ else
+ Collect_Interfaces (Type_Definition (N), Derived_Type);
+ end if;
+
+ -- Check that the full view and the partial view agree
+ -- in the set of implemented interfaces
+
+ if Has_Private_Declaration (Derived_Type)
+ and then Present (Abstract_Interfaces (Derived_Type))
+ and then not Is_Empty_Elmt_List
+ (Abstract_Interfaces (Derived_Type))
+ then
+ declare
+ N_Partial : constant Node_Id := Parent (Tagged_Partial_View);
+ N_Full : constant Node_Id := Parent (Derived_Type);
+
+ Iface_Partial : Entity_Id;
+ Iface_Full : Entity_Id;
+ Num_Ifaces_Partial : Natural := 0;
+ Num_Ifaces_Full : Natural := 0;
+ Same_Interfaces : Boolean := True;
+
+ begin
+ -- Count the interfaces implemented by the partial view
+
+ if not Is_Empty_List (Interface_List (N_Partial)) then
+ Iface_Partial := First (Interface_List (N_Partial));
+
+ while Present (Iface_Partial) loop
+ Num_Ifaces_Partial := Num_Ifaces_Partial + 1;
+ Next (Iface_Partial);
+ end loop;
+ end if;
+
+ -- Take into account the case in which the partial
+ -- view is a directly derived from an interface
+
+ if Is_Interface (Etype
+ (Defining_Identifier (N_Partial)))
+ then
+ Num_Ifaces_Partial := Num_Ifaces_Partial + 1;
+ end if;
+
+ -- Count the interfaces implemented by the full view
+
+ if not Is_Empty_List (Interface_List
+ (Type_Definition (N_Full)))
+ then
+ Iface_Full := First (Interface_List
+ (Type_Definition (N_Full)));
+
+ while Present (Iface_Full) loop
+ Num_Ifaces_Full := Num_Ifaces_Full + 1;
+ Next (Iface_Full);
+ end loop;
+ end if;
+
+ -- Take into account the case in which the full
+ -- view is a directly derived from an interface
+
+ if Is_Interface (Etype
+ (Defining_Identifier (N_Full)))
+ then
+ Num_Ifaces_Full := Num_Ifaces_Full + 1;
+ end if;
+
+ if Num_Ifaces_Full > 0
+ and then Num_Ifaces_Full = Num_Ifaces_Partial
+ then
+
+ -- Check that the full-view and the private-view have
+ -- the same list of interfaces
+
+ Iface_Full := First (Interface_List
+ (Type_Definition (N_Full)));
+
+ while Present (Iface_Full) loop
+ Iface_Partial := First (Interface_List (N_Partial));
+
+ while Present (Iface_Partial)
+ and then Etype (Iface_Partial) /= Etype (Iface_Full)
+ loop
+ Next (Iface_Partial);
+ end loop;
+
+ -- If not found we check if the partial view is a
+ -- direct derivation of the interface.
+
+ if not Present (Iface_Partial)
+ and then
+ Etype (Tagged_Partial_View) /= Etype (Iface_Full)
+ then
+ Same_Interfaces := False;
+ exit;
+ end if;
+
+ Next (Iface_Full);
+ end loop;
+ end if;
+
+ if Num_Ifaces_Partial /= Num_Ifaces_Full
+ or else not Same_Interfaces
+ then
+ Error_Msg_N
+ ("(Ada 2005) full declaration and private declaration"
+ & " must have the same list of interfaces",
+ Derived_Type);
+ end if;
+ end;
+ end if;
+ end if;
+
else
Set_Is_Packed (Derived_Type, Is_Packed (Parent_Base));
Set_Has_Non_Standard_Rep
Expand_Record_Extension (Derived_Type, Type_Def);
+ -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
+ -- implemented interfaces if we are in expansion mode
+
+ if Expander_Active then
+ Add_Interface_Tag_Components (N, Derived_Type);
+ end if;
+
-- Analyze the record extension
Record_Type_Definition
-- derived freeze if necessary.
Set_Has_Delayed_Freeze (Derived_Type);
+
if Derive_Subps then
Derive_Subprograms (Parent_Type, Derived_Type);
+
+ -- Ada 2005 (AI-251): Check if this tagged type implements abstract
+ -- interfaces
+
+ Has_Interfaces := False;
+
+ if Is_Tagged_Type (Derived_Type) then
+ declare
+ E : Entity_Id;
+
+ begin
+ E := Derived_Type;
+ loop
+ if Is_Interface (E)
+ or else (Present (Abstract_Interfaces (E))
+ and then
+ not Is_Empty_Elmt_List (Abstract_Interfaces (E)))
+ then
+ Has_Interfaces := True;
+ exit;
+ end if;
+
+ exit when Etype (E) = E
+
+ -- Protect the frontend against wrong source
+
+ or else Etype (E) = Derived_Type;
+
+ E := Etype (E);
+ end loop;
+ end;
+ end if;
+
+ -- Ada 2005 (AI-251): Keep separate the management of tagged types
+ -- implementing interfaces
+
+ if Is_Tagged_Type (Derived_Type)
+ and then Has_Interfaces
+ then
+ -- Complete the decoration of private tagged types
+
+ if Present (Tagged_Partial_View) then
+ Complete_Subprograms_Derivation
+ (Partial_View => Tagged_Partial_View,
+ Derived_Type => Derived_Type);
+ end if;
+
+ -- Ada 2005 (AI-251): Derive the interface subprograms of all the
+ -- implemented interfaces and check if some of the subprograms
+ -- inherited from the ancestor cover some interface subprogram.
+
+ if not Present (Tagged_Partial_View) then
+ declare
+ Subp_Elmt : Elmt_Id := First_Elmt
+ (Primitive_Operations
+ (Derived_Type));
+ Iface_Subp_Elmt : Elmt_Id;
+ Subp : Entity_Id;
+ Iface_Subp : Entity_Id;
+ Is_Interface_Subp : Boolean;
+
+ begin
+ -- Ada 2005 (AI-251): Remember the entity corresponding to
+ -- the last inherited primitive operation. This is required
+ -- to check if some of the inherited subprograms covers some
+ -- of the new interfaces.
+
+ Last_Inherited_Prim_Op := No_Elmt;
+
+ while Present (Subp_Elmt) loop
+ Last_Inherited_Prim_Op := Subp_Elmt;
+ Next_Elmt (Subp_Elmt);
+ end loop;
+
+ -- Ada 2005 (AI-251): Derive subprograms in abstract
+ -- interfaces
+
+ Derive_Interface_Subprograms (Derived_Type);
+
+ -- Ada 2005 (AI-251): Check if some of the inherited
+ -- subprograms cover some of the new interfaces.
+
+ if Present (Last_Inherited_Prim_Op) then
+ Iface_Subp_Elmt := Next_Elmt (Last_Inherited_Prim_Op);
+ while Present (Iface_Subp_Elmt) loop
+ Subp_Elmt := First_Elmt (Primitive_Operations
+ (Derived_Type));
+ while Subp_Elmt /= Last_Inherited_Prim_Op loop
+ Subp := Node (Subp_Elmt);
+ Iface_Subp := Node (Iface_Subp_Elmt);
+
+ Is_Interface_Subp :=
+ Present (Alias (Subp))
+ and then Present (DTC_Entity (Alias (Subp)))
+ and then Is_Interface (Scope
+ (DTC_Entity
+ (Alias (Subp))));
+
+ if Chars (Subp) = Chars (Iface_Subp)
+ and then not Is_Interface_Subp
+ and then not Is_Abstract (Subp)
+ and then Type_Conformant (Iface_Subp, Subp)
+ then
+ Check_Dispatching_Operation
+ (Subp => Subp,
+ Old_Subp => Iface_Subp);
+
+ -- Traverse the list of aliased subprograms
+
+ declare
+ E : Entity_Id := Alias (Subp);
+ begin
+ while Present (Alias (E)) loop
+ E := Alias (E);
+ end loop;
+ Set_Alias (Subp, E);
+ end;
+
+ Set_Has_Delayed_Freeze (Subp);
+ exit;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+
+ Next_Elmt (Iface_Subp_Elmt);
+ end loop;
+ end if;
+ end;
+ end if;
+ end if;
end if;
-- If we have a private extension which defines a constrained derived
Error_Msg_NE
("type must be declared abstract or & overridden",
T, Subp);
+
+ -- Ada 2005 (AI-345): Protected or task type implementing
+ -- abstract interfaces
+
+ elsif Is_Concurrent_Record_Type (T)
+ and then Present (Abstract_Interfaces (T))
+ then
+ Error_Msg_NE
+ ("interface subprogram & must be overridden",
+ T, Subp);
end if;
else
Error_Msg_NE
-- ??? Also need to check components of record extensions, but not
-- components of protected types (which are always limited).
+ -- Ada 2005: AI-363 relaxes this rule, to allow heap objects
+ -- of such types to be unconstrained. This is safe because it is
+ -- illegal to create access subtypes to such types with explicit
+ -- discriminant constraints.
+
if not Is_Limited_Type (T) then
if Ekind (T) = E_Record_Type then
C := First_Component (T);
and then Has_Discriminants (Etype (C))
and then not Is_Constrained (Etype (C))
and then not In_Instance
+ and then Ada_Version < Ada_05
then
Error_Msg_N
("aliased component must be constrained ('R'M 3.6(11))",
Resolve (Bound, Standard_Float);
end Check_Real_Bound;
- ------------------------------
- -- Complete_Private_Subtype --
- ------------------------------
+ ------------------------
+ -- Collect_Interfaces --
+ ------------------------
- procedure Complete_Private_Subtype
- (Priv : Entity_Id;
- Full : Entity_Id;
- Full_Base : Entity_Id;
- Related_Nod : Node_Id)
- is
- Save_Next_Entity : Entity_Id;
- Save_Homonym : Entity_Id;
+ procedure Collect_Interfaces (N : Node_Id; Derived_Type : Entity_Id) is
+ I : Node_Id;
- begin
- -- Set semantic attributes for (implicit) private subtype completion.
- -- If the full type has no discriminants, then it is a copy of the full
- -- view of the base. Otherwise, it is a subtype of the base with a
- -- possible discriminant constraint. Save and restore the original
- -- Next_Entity field of full to ensure that the calls to Copy_Node
- -- do not corrupt the entity chain.
+ procedure Add_Interface (Iface : Entity_Id);
- -- Note that the type of the full view is the same entity as the
+ procedure Add_Interface (Iface : Entity_Id) is
+ Elmt : Elmt_Id := First_Elmt (Abstract_Interfaces (Derived_Type));
+
+ begin
+ while Present (Elmt) and then Node (Elmt) /= Iface loop
+ Next_Elmt (Elmt);
+ end loop;
+
+ if not Present (Elmt) then
+ Append_Elmt (Node => Iface,
+ To => Abstract_Interfaces (Derived_Type));
+ end if;
+ end Add_Interface;
+
+ begin
+ pragma Assert (False
+ or else Nkind (N) = N_Derived_Type_Definition
+ or else Nkind (N) = N_Record_Definition
+ or else Nkind (N) = N_Private_Extension_Declaration);
+
+ -- Traverse the graph of ancestor interfaces
+
+ if Is_Non_Empty_List (Interface_List (N)) then
+ I := First (Interface_List (N));
+
+ while Present (I) loop
+
+ -- Protect against wrong usages. Example:
+ -- type I is interface;
+ -- type O is tagged null record;
+ -- type Wrong is new I and O with null record;
+
+ if Is_Interface (Etype (I)) then
+
+ -- Do not add the interface when the derived type already
+ -- implements this interface
+
+ if not Interface_Present_In_Ancestor (Derived_Type,
+ Etype (I))
+ then
+ Collect_Interfaces
+ (Type_Definition (Parent (Etype (I))),
+ Derived_Type);
+ Add_Interface (Etype (I));
+ end if;
+ end if;
+
+ Next (I);
+ end loop;
+ end if;
+ end Collect_Interfaces;
+
+ ------------------------------
+ -- Complete_Private_Subtype --
+ ------------------------------
+
+ procedure Complete_Private_Subtype
+ (Priv : Entity_Id;
+ Full : Entity_Id;
+ Full_Base : Entity_Id;
+ Related_Nod : Node_Id)
+ is
+ Save_Next_Entity : Entity_Id;
+ Save_Homonym : Entity_Id;
+
+ begin
+ -- Set semantic attributes for (implicit) private subtype completion.
+ -- If the full type has no discriminants, then it is a copy of the full
+ -- view of the base. Otherwise, it is a subtype of the base with a
+ -- possible discriminant constraint. Save and restore the original
+ -- Next_Entity field of full to ensure that the calls to Copy_Node
+ -- do not corrupt the entity chain.
+
+ -- Note that the type of the full view is the same entity as the
-- type of the partial view. In this fashion, the subtype has
-- access to the correct view of the parent.
end if;
end Complete_Private_Subtype;
+ -------------------------------------
+ -- Complete_Subprograms_Derivation --
+ -------------------------------------
+
+ procedure Complete_Subprograms_Derivation
+ (Partial_View : Entity_Id;
+ Derived_Type : Entity_Id)
+ is
+ Result : constant Elist_Id := New_Elmt_List;
+ Elmt_P : Elmt_Id := No_Elmt;
+ Elmt_D : Elmt_Id;
+ Found : Boolean;
+ Prim_Op : Entity_Id;
+ E : Entity_Id;
+
+ begin
+ if Is_Tagged_Type (Partial_View) then
+ Elmt_P := First_Elmt (Primitive_Operations (Partial_View));
+ end if;
+
+ -- Inherit primitives declared with the partial-view
+
+ while Present (Elmt_P) loop
+ Prim_Op := Node (Elmt_P);
+ Found := False;
+ Elmt_D := First_Elmt (Primitive_Operations (Derived_Type));
+ while Present (Elmt_D) loop
+ if Node (Elmt_D) = Prim_Op then
+ Found := True;
+ exit;
+ end if;
+
+ Next_Elmt (Elmt_D);
+ end loop;
+
+ if not Found then
+ Append_Elmt (Prim_Op, Result);
+
+ -- Search for entries associated with abstract interfaces that
+ -- have been covered by this primitive
+
+ Elmt_D := First_Elmt (Primitive_Operations (Derived_Type));
+ while Present (Elmt_D) loop
+ E := Node (Elmt_D);
+
+ if Chars (E) = Chars (Prim_Op)
+ and then Is_Abstract (E)
+ and then Present (Alias (E))
+ and then Present (DTC_Entity (Alias (E)))
+ and then Is_Interface (Scope (DTC_Entity (Alias (E))))
+ then
+ Remove_Elmt (Primitive_Operations (Derived_Type), Elmt_D);
+ end if;
+
+ Next_Elmt (Elmt_D);
+ end loop;
+ end if;
+
+ Next_Elmt (Elmt_P);
+ end loop;
+
+ -- Append the entities of the full-view to the list of primitives
+ -- of derived_type
+
+ Elmt_D := First_Elmt (Result);
+ while Present (Elmt_D) loop
+ Append_Elmt (Node (Elmt_D), Primitive_Operations (Derived_Type));
+ Next_Elmt (Elmt_D);
+ end loop;
+ end Complete_Subprograms_Derivation;
+
----------------------------
-- Constant_Redeclaration --
----------------------------
then
Enter_Name (Id);
- -- Verify that types of both declarations match
+ -- Verify that types of both declarations match, or else that both types
+ -- are anonymous access types whose designated subtypes statically match
+ -- (as allowed in Ada 2005 by AI-385).
- elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) then
+ elsif Base_Type (Etype (Prev)) /= Base_Type (New_T)
+ and then
+ (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type
+ or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type
+ or else not Subtypes_Statically_Match
+ (Designated_Type (Etype (Prev)),
+ Designated_Type (Etype (New_T))))
+ then
Error_Msg_Sloc := Sloc (Prev);
Error_Msg_N ("type does not match declaration#", N);
Set_Full_View (Prev, Id);
Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod);
Constraint_OK : Boolean := True;
+ function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean;
+ -- Simple predicate to test for defaulted discriminants
+ -- Shouldn't this be in sem_util???
+
+ ---------------------------------
+ -- Has_Defaulted_Discriminants --
+ ---------------------------------
+
+ function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
+ begin
+ return Has_Discriminants (Typ)
+ and then Present (First_Discriminant (Typ))
+ and then Present
+ (Discriminant_Default_Value (First_Discriminant (Typ)));
+ end Has_Defaulted_Discriminants;
+
+ -- Start of processing for Constrain_Access
+
begin
if Is_Array_Type (Desig_Type) then
Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P');
-- a derivation from a private type) has no discriminants.
-- (Defect Report 8652/0008, Technical Corrigendum 1, checked
-- by ACATS B371001).
+ -- Rule updated for Ada 2005: the private type is said to have
+ -- a constrained partial view, given that objects of the type
+ -- can be declared.
declare
Pack : constant Node_Id :=
then
if No (Discriminant_Specifications (Decl)) then
Error_Msg_N
- ("cannot constrain general access type " &
- "if designated type has unconstrained view", S);
+ ("cannot constrain general access type if " &
+ "designated type has constrained partial view",
+ S);
end if;
exit;
Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T));
Conditional_Delay (Def_Id, T);
+
+ -- AI-363 : Subtypes of general access types whose designated
+ -- types have default discriminants are disallowed. In instances,
+ -- the rule has to be checked against the actual, of which T is
+ -- the subtype. In a generic body, the rule is checked assuming
+ -- that the actual type has defaulted discriminants.
+
+ if Ada_Version >= Ada_05 then
+ if Ekind (Base_Type (T)) = E_General_Access_Type
+ and then Has_Defaulted_Discriminants (Desig_Type)
+ then
+ Error_Msg_N
+ ("access subype of general access type not allowed", S);
+ Error_Msg_N ("\ when discriminants have defaults", S);
+
+ elsif Is_Access_Type (T)
+ and then Is_Generic_Type (Desig_Type)
+ and then Has_Discriminants (Desig_Type)
+ and then In_Package_Body (Current_Scope)
+ then
+ Error_Msg_N ("access subtype not allowed in generic body", S);
+ Error_Msg_N
+ ("\ wben designated type is a discriminated formal", S);
+ end if;
+ end if;
end Constrain_Access;
---------------------
if Constraint_OK then
Set_First_Index (Def_Id, First (Constraints (C)));
+ else
+ Set_First_Index (Def_Id, First_Index (T));
end if;
Set_Is_Constrained (Def_Id, True);
Set_Is_Constrained (T);
end Decimal_Fixed_Point_Type_Declaration;
+ ---------------------------------
+ -- Derive_Interface_Subprogram --
+ ---------------------------------
+
+ procedure Derive_Interface_Subprograms (Derived_Type : Entity_Id) is
+
+ procedure Do_Derivation (T : Entity_Id);
+ -- This inner subprograms is used to climb to the ancestors.
+ -- It is needed to add the derivations to the Derived_Type.
+
+ procedure Do_Derivation (T : Entity_Id) is
+ Etyp : constant Entity_Id := Etype (T);
+ AI : Elmt_Id;
+
+ begin
+ if Etyp /= T
+ and then Is_Interface (Etyp)
+ then
+ Do_Derivation (Etyp);
+ end if;
+
+ if Present (Abstract_Interfaces (T))
+ and then not Is_Empty_Elmt_List (Abstract_Interfaces (T))
+ then
+ AI := First_Elmt (Abstract_Interfaces (T));
+
+ while Present (AI) loop
+ Derive_Subprograms
+ (Parent_Type => Node (AI),
+ Derived_Type => Derived_Type,
+ Is_Interface_Derivation => True);
+
+ Next_Elmt (AI);
+ end loop;
+ end if;
+ end Do_Derivation;
+
+ begin
+ Do_Derivation (Derived_Type);
+
+ -- At this point the list of primitive operations of Derived_Type
+ -- contains the entities corresponding to all the subprograms of all the
+ -- implemented interfaces. If N interfaces have subprograms with the
+ -- same profile we have N entities in this list because each one must be
+ -- allocated in its corresponding virtual table.
+
+ -- Its alias attribute references its original interface subprogram.
+ -- When overriden, the alias attribute is later saved in the
+ -- Abstract_Interface_Alias attribute.
+
+ end Derive_Interface_Subprograms;
+
-----------------------
-- Derive_Subprogram --
-----------------------
------------------------
procedure Derive_Subprograms
- (Parent_Type : Entity_Id;
- Derived_Type : Entity_Id;
- Generic_Actual : Entity_Id := Empty)
+ (Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id;
+ Generic_Actual : Entity_Id := Empty;
+ Is_Interface_Derivation : Boolean := False)
is
Op_List : constant Elist_Id :=
Collect_Primitive_Operations (Parent_Type);
Subp := Node (Elmt);
if Ekind (Subp) /= E_Enumeration_Literal then
- if No (Generic_Actual) then
+ if Is_Interface_Derivation then
+ if not Is_Predefined_Dispatching_Operation (Subp) then
+ Derive_Subprogram
+ (New_Subp, Subp, Derived_Type, Parent_Base);
+ end if;
+
+ elsif No (Generic_Actual) then
Derive_Subprogram
(New_Subp, Subp, Derived_Type, Parent_Base);
Is_Completion : Boolean)
is
Def : constant Node_Id := Type_Definition (N);
+ Iface_Def : Node_Id;
Indic : constant Node_Id := Subtype_Indication (Def);
Extension : constant Node_Id := Record_Extension_Part (Def);
Parent_Type : Entity_Id;
begin
Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
+ -- Ada 2005 (AI-251): In case of interface derivation check that the
+ -- parent is also an interface.
+
+ if Interface_Present (Def) then
+ if not Is_Interface (Parent_Type) then
+ Error_Msg_NE ("(Ada 2005) & must be an interface",
+ Indic, Parent_Type);
+
+ else
+ Iface_Def := Type_Definition (Parent (Parent_Type));
+
+ -- Ada 2005 (AI-251): Limited interfaces can only inherit from
+ -- other limited interfaces.
+
+ if Limited_Present (Def) then
+ if Limited_Present (Iface_Def) then
+ null;
+
+ elsif Protected_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) limited interface cannot" &
+ " inherit from protected interface", Indic);
+
+ elsif Synchronized_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) limited interface cannot" &
+ " inherit from synchronized interface", Indic);
+
+ elsif Task_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) limited interface cannot" &
+ " inherit from task interface", Indic);
+
+ else
+ Error_Msg_N ("(Ada 2005) limited interface cannot" &
+ " inherit from non-limited interface", Indic);
+ end if;
+
+ -- Ada 2005 (AI-345): Non-limited interfaces can only inherit
+ -- from non-limited or limited interfaces.
+
+ elsif not Protected_Present (Def)
+ and then not Synchronized_Present (Def)
+ and then not Task_Present (Def)
+ then
+ if Limited_Present (Iface_Def) then
+ null;
+
+ elsif Protected_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) non-limited interface cannot" &
+ " inherit from protected interface", Indic);
+
+ elsif Synchronized_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) non-limited interface cannot" &
+ " inherit from synchronized interface", Indic);
+
+ elsif Task_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) non-limited interface cannot" &
+ " inherit from task interface", Indic);
+
+ else
+ null;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor
+ -- interfaces
+
+ if Is_Tagged_Type (Parent_Type)
+ and then Is_Non_Empty_List (Interface_List (Def))
+ then
+ declare
+ I : Node_Id := First (Interface_List (Def));
+ T : Entity_Id;
+ begin
+ while Present (I) loop
+ T := Find_Type_Of_Subtype_Indic (I);
+
+ if not Is_Interface (T) then
+ Error_Msg_NE ("(Ada 2005) & must be an interface", I, T);
+ end if;
+
+ Next (I);
+ end loop;
+ end;
+ end if;
+
if Parent_Type = Any_Type
or else Etype (Parent_Type) = Any_Type
or else (Is_Class_Wide_Type (Parent_Type)
("completion of nonlimited type cannot be limited", N);
end if;
+ -- Ada 2005 (AI-251): Private extension declaration of a
+ -- task type. This case arises with tasks implementing interfaces
+
+ elsif Nkind (N) = N_Task_Type_Declaration
+ or else Nkind (N) = N_Protected_Type_Declaration
+ then
+ null;
+
elsif Nkind (N) /= N_Full_Type_Declaration
or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition
then
if Is_Type (Prev)
and then (Is_Tagged_Type (Prev)
or else Present (Class_Wide_Type (Prev)))
+ and then (Nkind (N) /= N_Task_Type_Declaration
+ and then Nkind (N) /= N_Protected_Type_Declaration)
then
-- The full declaration is either a tagged record or an
-- extension otherwise this is an error
and then No (Expression (P))
then
null;
-
else
Insert_Actions (Obj_Def, Freeze_Entity (T, Sloc (P)));
end if;
+ -- Ada 2005 AI-406: the object definition in an object declaration
+ -- can be an access definition.
+
+ elsif Def_Kind = N_Access_Definition then
+ T := Access_Definition (Related_Nod, Obj_Def);
+ Set_Is_Local_Anonymous_Access (T);
+
+ -- comment here, what cases ???
+
else
T := Process_Subtype (Obj_Def, Related_Nod);
end if;
Component := First_Entity (Parent_Base);
while Present (Component) loop
- if Ekind (Component) /= E_Component
+
+ -- Ada 2005 (AI-251): Do not inherit tags corresponding with the
+ -- interfaces of the parent
+
+ if Ekind (Component) = E_Component
+ and then Is_Tag (Component)
+ and then Etype (Component) = RTE (RE_Interface_Tag)
+ then
+ null;
+
+ elsif Ekind (Component) /= E_Component
or else Chars (Component) = Name_uParent
then
null;
if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
Discr_Type := Access_Definition (N, Discriminant_Type (Discr));
+ -- Ada 2005 (AI-230): Access discriminants are now allowed for
+ -- nonlimited types, and are treated like other components of
+ -- anonymous access types in terms of accessibility.
+
+ if not Is_Concurrent_Type (Current_Scope)
+ and then not Is_Concurrent_Record_Type (Current_Scope)
+ and then not Is_Limited_Record (Current_Scope)
+ and then Ekind (Current_Scope) /= E_Limited_Private_Type
+ then
+ Set_Is_Local_Anonymous_Access (Discr_Type);
+ end if;
+
-- Ada 2005 (AI-254)
if Present (Access_To_Subprogram_Definition
Full_Parent : Entity_Id;
Full_Indic : Node_Id;
+ function Find_Interface_In_Descendant
+ (Typ : Entity_Id) return Entity_Id;
+ -- Find an implemented interface in the derivation chain of Typ
+
+ ----------------------------------
+ -- Find_Interface_In_Descendant --
+ ----------------------------------
+
+ function Find_Interface_In_Descendant
+ (Typ : Entity_Id) return Entity_Id
+ is
+ T : Entity_Id;
+
+ begin
+ T := Typ;
+ while T /= Etype (T) loop
+ if Is_Interface (Etype (T)) then
+ return Etype (T);
+ end if;
+
+ T := Etype (T);
+ end loop;
+
+ return Empty;
+ end Find_Interface_In_Descendant;
+
+ -- Start of processing for Process_Full_View
+
begin
-- First some sanity checks that must be done after semantic
-- decoration of the full view and thus cannot be placed with other
Error_Msg_N ("generic type cannot have a completion", Full_T);
end if;
+ -- Ada 2005 (AI-396): A full view shall be a descendant of an
+ -- interface type if and only if the corresponding partial view
+ -- (if any) is also a descendant of the interface type, or if
+ -- the partial view is untagged.
+
+ if Ada_Version >= Ada_05
+ and then Is_Tagged_Type (Full_T)
+ then
+ declare
+ Iface : Entity_Id;
+ Iface_Def : Node_Id;
+
+ begin
+ Iface := Find_Interface_In_Descendant (Full_T);
+
+ if Present (Iface) then
+ Iface_Def := Type_Definition (Parent (Iface));
+ end if;
+
+ -- The full view derives from an interface descendant, but the
+ -- partial view does not share the same tagged type.
+
+ if Present (Iface)
+ and then Is_Tagged_Type (Priv_T)
+ and then Etype (Full_T) /= Etype (Priv_T)
+ then
+ Error_Msg_N ("(Ada 2005) tagged partial view cannot be " &
+ "completed by a type that implements an " &
+ "interface", Priv_T);
+ end if;
+
+ -- The full view derives from a limited, protected,
+ -- synchronized or task interface descendant, but the
+ -- partial view is not labeled as limited.
+
+ if Present (Iface)
+ and then (Limited_Present (Iface_Def)
+ or Protected_Present (Iface_Def)
+ or Synchronized_Present (Iface_Def)
+ or Task_Present (Iface_Def))
+ and then not Limited_Present (Parent (Priv_T))
+ then
+ Error_Msg_N ("(Ada 2005) non-limited private type cannot be " &
+ "completed by a limited type", Priv_T);
+ end if;
+ end;
+ end if;
+
if Is_Tagged_Type (Priv_T)
and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
and then Is_Derived_Type (Full_T)
return;
elsif not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) then
- Error_Msg_N
- ("parent of full type must descend from parent"
- & " of private extension", Full_Indic);
+
+ -- Ada 2005 (AI-251): No error needed if the immediate
+ -- ancestor of the partial view is an interface
+ --
+ -- Example:
+ --
+ -- type PT1 is new I1 with private;
+ -- private
+ -- type PT1 is new T and I1 with null record;
+
+ if Is_Interface (Base_Type (Priv_Parent)) then
+ null;
+
+ else
+ Error_Msg_N
+ ("parent of full type must descend from parent"
+ & " of private extension", Full_Indic);
+ end if;
-- Check the rules of 7.3(10): if the private extension inherits
-- known discriminants, then the full type must also inherit those
then
Error_Msg_N
("full view must define a constrained type if partial view"
- & " has no discriminants", Full_T);
+ & " has no discriminants", Full_T);
end if;
-- ??????? Do we implement the following properly ?????
end if;
end if;
+ -- Ada 2005 AI-363: if the full view has discriminants with
+ -- defaults, it is illegal to declare constrained access subtypes
+ -- whose designated type is the current type. This allows objects
+ -- of the type that are declared in the heap to be unconstrained.
+
+ if not Has_Unknown_Discriminants (Priv_T)
+ and then not Has_Discriminants (Priv_T)
+ and then Has_Discriminants (Full_T)
+ and then
+ Present
+ (Discriminant_Default_Value (First_Discriminant (Full_T)))
+ then
+ Set_Has_Constrained_Partial_View (Full_T);
+ Set_Has_Constrained_Partial_View (Priv_T);
+ end if;
+
-- Create a full declaration for all its subtypes recorded in
-- Private_Dependents and swap them similarly to the base type. These
-- are subtypes that have been define before the full declaration of
Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
- -- Set Ekind of orphan itype, to prevent cascaded errors.
+ -- Set Ekind of orphan itype, to prevent cascaded errors
if Present (Def_Id) then
Set_Ekind (Def_Id, Ekind (Any_Type));
N : Node_Id;
Prev : Entity_Id)
is
- Def : constant Node_Id := Type_Definition (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Def : constant Node_Id := Type_Definition (N);
+ Inc_T : Entity_Id := Empty;
Is_Tagged : Boolean;
Tag_Comp : Entity_Id;
- begin
- -- The flag Is_Tagged_Type might have already been set by Find_Type_Name
- -- if it detected an error for declaration T. This arises in the case of
- -- private tagged types where the full view omits the word tagged.
+ procedure Check_Anonymous_Access_Types (Comp_List : Node_Id);
+ -- Ada 2005 AI-382: an access component in a record declaration can
+ -- refer to the enclosing record, in which case it denotes the type
+ -- itself, and not the current instance of the type. We create an
+ -- anonymous access type for the component, and flag it as an access
+ -- to a component, so that accessibility checks are properly performed
+ -- on it. The declaration of the access type is placed ahead of that
+ -- of the record, to prevent circular order-of-elaboration issues in
+ -- gigi. We create an incomplete type for the record declaration, which
+ -- is the designated type of the anonymous access.
+
+ procedure Make_Incomplete_Type_Declaration;
+ -- If the record type contains components that include an access to the
+ -- current record, create an incomplete type declaration for the record,
+ -- to be used as the designated type of the anonymous access. This is
+ -- done only once, and only if there is no previous partial view of the
+ -- type.
- Is_Tagged :=
- Tagged_Present (Def)
- or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T));
+ ----------------------------------
+ -- Check_Anonymous_Access_Types --
+ ----------------------------------
- -- Records constitute a scope for the component declarations within.
- -- The scope is created prior to the processing of these declarations.
- -- Discriminants are processed first, so that they are visible when
- -- processing the other components. The Ekind of the record type itself
- -- is set to E_Record_Type (subtypes appear as E_Record_Subtype).
+ procedure Check_Anonymous_Access_Types (Comp_List : Node_Id) is
+ Anon_Access : Entity_Id;
+ Acc_Def : Node_Id;
+ Comp : Node_Id;
+ Decl : Node_Id;
+ Type_Def : Node_Id;
- -- Enter record scope
+ function Mentions_T (Acc_Def : Node_Id) return Boolean;
+ -- Check whether an access definition includes a reference to
+ -- the enclosing record type. The reference can be a subtype
+ -- mark in the access definition itself, or a 'Class attribute
+ -- reference, or recursively a reference appearing in a parameter
+ -- type in an access_to_subprogram definition.
- New_Scope (T);
+ ----------------
+ -- Mentions_T --
+ ----------------
+
+ function Mentions_T (Acc_Def : Node_Id) return Boolean is
+ Subt : Node_Id;
+
+ begin
+ if No (Access_To_Subprogram_Definition (Acc_Def)) then
+ Subt := Subtype_Mark (Acc_Def);
+
+ if Nkind (Subt) = N_Identifier then
+ return Chars (Subt) = Chars (T);
+ elsif Nkind (Subt) = N_Attribute_Reference
+ and then Attribute_Name (Subt) = Name_Class
+ then
+ return (Chars (Prefix (Subt))) = Chars (T);
+ else
+ return False;
+ end if;
+
+ else
+ -- Component is an access_to_subprogram: examine its formals
+
+ declare
+ Param_Spec : Node_Id;
+
+ begin
+ Param_Spec :=
+ First
+ (Parameter_Specifications
+ (Access_To_Subprogram_Definition (Acc_Def)));
+ while Present (Param_Spec) loop
+ if Nkind (Parameter_Type (Param_Spec))
+ = N_Access_Definition
+ and then Mentions_T (Parameter_Type (Param_Spec))
+ then
+ return True;
+ end if;
+
+ Next (Param_Spec);
+ end loop;
+
+ return False;
+ end;
+ end if;
+ end Mentions_T;
+
+ -- Start of processing for Check_Anonymous_Access_Types
+
+ begin
+ if No (Comp_List) then
+ return;
+ end if;
+
+ Comp := First (Component_Items (Comp_List));
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Component_Declaration
+ and then
+ Present (Access_Definition (Component_Definition (Comp)))
+ and then
+ Mentions_T (Access_Definition (Component_Definition (Comp)))
+ then
+ Acc_Def :=
+ Access_To_Subprogram_Definition
+ (Access_Definition (Component_Definition (Comp)));
+
+ Make_Incomplete_Type_Declaration;
+ Anon_Access :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('S'));
+
+ -- Create a declaration for the anonymous access type: either
+ -- an access_to_object or an access_to_subprogram.
+
+ if Present (Acc_Def) then
+ if Nkind (Acc_Def) = N_Access_Function_Definition then
+ Type_Def :=
+ Make_Access_Function_Definition (Loc,
+ Parameter_Specifications =>
+ Parameter_Specifications (Acc_Def),
+ Subtype_Mark => Subtype_Mark (Acc_Def));
+ else
+ Type_Def :=
+ Make_Access_Procedure_Definition (Loc,
+ Parameter_Specifications =>
+ Parameter_Specifications (Acc_Def));
+ end if;
+
+ else
+ Type_Def :=
+ Make_Access_To_Object_Definition (Loc,
+ Subtype_Indication =>
+ Relocate_Node
+ (Subtype_Mark
+ (Access_Definition
+ (Component_Definition (Comp)))));
+ end if;
+
+ Decl := Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Anon_Access,
+ Type_Definition => Type_Def);
+
+ Insert_Before (N, Decl);
+ Analyze (Decl);
+
+ Set_Access_Definition (Component_Definition (Comp), Empty);
+ Set_Subtype_Indication (Component_Definition (Comp),
+ New_Occurrence_Of (Anon_Access, Loc));
+ Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
+ Set_Is_Local_Anonymous_Access (Anon_Access);
+ end if;
+
+ Next (Comp);
+ end loop;
+
+ if Present (Variant_Part (Comp_List)) then
+ declare
+ V : Node_Id;
+ begin
+ V := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
+ while Present (V) loop
+ Check_Anonymous_Access_Types (Component_List (V));
+ Next_Non_Pragma (V);
+ end loop;
+ end;
+ end if;
+ end Check_Anonymous_Access_Types;
+ --------------------------------------
+ -- Make_Incomplete_Type_Declaration --
+ --------------------------------------
+
+ procedure Make_Incomplete_Type_Declaration is
+ Decl : Node_Id;
+ H : Entity_Id;
+
+ begin
+ -- If there is a previous partial view, no need to create a new one.
+
+ if Prev /= T then
+ return;
+
+ elsif No (Inc_T) then
+ Inc_T := Make_Defining_Identifier (Loc, Chars (T));
+ Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T);
+
+ -- Type has already been inserted into the current scope.
+ -- Remove it, and add incomplete declaration for type, so
+ -- that subsequent anonymous access types can use it.
+
+ H := Current_Entity (T);
+
+ if H = T then
+ Set_Name_Entity_Id (Chars (T), Empty);
+ else
+ while Present (H)
+ and then Homonym (H) /= T
+ loop
+ H := Homonym (T);
+ end loop;
+
+ Set_Homonym (H, Homonym (T));
+ end if;
+
+ Insert_Before (N, Decl);
+ Analyze (Decl);
+ Set_Full_View (Inc_T, T);
+
+ if Tagged_Present (Def) then
+ Make_Class_Wide_Type (Inc_T);
+ Set_Class_Wide_Type (T, Class_Wide_Type (Inc_T));
+ end if;
+ end if;
+ end Make_Incomplete_Type_Declaration;
+
+ -- Start of processing for Record_Type_Declaration
+
+ begin
-- These flags must be initialized before calling Process_Discriminants
-- because this routine makes use of them.
- Set_Is_Tagged_Type (T, Is_Tagged);
- Set_Is_Limited_Record (T, Limited_Present (Def));
+ Set_Ekind (T, E_Record_Type);
+ Set_Etype (T, T);
+ Init_Size_Align (T);
+ Set_Abstract_Interfaces (T, No_Elist);
+ Set_Stored_Constraint (T, No_Elist);
- -- Type is abstract if full declaration carries keyword, or if
- -- previous partial view did.
+ -- Normal case
- Set_Is_Abstract (T, Is_Abstract (T) or else Abstract_Present (Def));
+ if Ada_Version < Ada_05
+ or else not Interface_Present (Def)
+ then
+ -- The flag Is_Tagged_Type might have already been set by
+ -- Find_Type_Name if it detected an error for declaration T. This
+ -- arises in the case of private tagged types where the full view
+ -- omits the word tagged.
- Set_Ekind (T, E_Record_Type);
- Set_Etype (T, T);
- Init_Size_Align (T);
+ Is_Tagged :=
+ Tagged_Present (Def)
+ or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T));
- Set_Stored_Constraint (T, No_Elist);
+ Set_Is_Tagged_Type (T, Is_Tagged);
+ Set_Is_Limited_Record (T, Limited_Present (Def));
+
+ -- Type is abstract if full declaration carries keyword, or if
+ -- previous partial view did.
+
+ Set_Is_Abstract (T, Is_Abstract (T)
+ or else Abstract_Present (Def));
+
+ else
+ Is_Tagged := True;
+ Set_Is_Tagged_Type (T);
+
+ Set_Is_Limited_Record (T, Limited_Present (Def)
+ or else Task_Present (Def)
+ or else Protected_Present (Def));
+
+ -- Type is abstract if full declaration carries keyword, or if
+ -- previous partial view did.
+
+ Set_Is_Abstract (T);
+ Set_Is_Interface (T);
+ end if;
+
+ -- First pass: if there are self-referential access components,
+ -- create the required anonymous access type declarations, and if
+ -- need be an incomplete type declaration for T itself.
+
+ Check_Anonymous_Access_Types (Component_List (Def));
+
+ -- Ada 2005 (AI-251): Complete the initialization of attributes
+ -- associated with abstract interfaces and decorate the names in the
+ -- list of ancestor interfaces (if any).
+
+ if Ada_Version >= Ada_05
+ and then Present (Interface_List (Def))
+ then
+ declare
+ Iface : Node_Id;
+ Iface_Def : Node_Id;
+ Iface_Typ : Entity_Id;
+ begin
+ Iface := First (Interface_List (Def));
+
+ while Present (Iface) loop
+ Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
+ Iface_Def := Type_Definition (Parent (Iface_Typ));
+
+ if not Is_Interface (Iface_Typ) then
+ Error_Msg_NE ("(Ada 2005) & must be an interface",
+ Iface, Iface_Typ);
+
+ else
+ -- "The declaration of a specific descendant of an
+ -- interface type freezes the interface type" RM 13.14
+
+ Freeze_Before (N, Iface_Typ);
+
+ -- Ada 2005 (AI-345): Protected interfaces can only
+ -- inherit from limited, synchronized or protected
+ -- interfaces.
+
+ if Protected_Present (Def) then
+ if Limited_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def)
+ or else Protected_Present (Iface_Def)
+ then
+ null;
+
+ elsif Task_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) protected interface cannot"
+ & " inherit from task interface", Iface);
+
+ else
+ Error_Msg_N ("(Ada 2005) protected interface cannot"
+ & " inherit from non-limited interface", Iface);
+ end if;
+
+ -- Ada 2005 (AI-345): Synchronized interfaces can only
+ -- inherit from limited and synchronized.
+
+ elsif Synchronized_Present (Def) then
+ if Limited_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def)
+ then
+ null;
+
+ elsif Protected_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) synchronized interface " &
+ "cannot inherit from protected interface", Iface);
+
+ elsif Task_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) synchronized interface " &
+ "cannot inherit from task interface", Iface);
+
+ else
+ Error_Msg_N ("(Ada 2005) synchronized interface " &
+ "cannot inherit from non-limited interface",
+ Iface);
+ end if;
+
+ -- Ada 2005 (AI-345): Task interfaces can only inherit
+ -- from limited, synchronized or task interfaces.
+
+ elsif Task_Present (Def) then
+ if Limited_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def)
+ or else Task_Present (Iface_Def)
+ then
+ null;
+
+ elsif Protected_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) task interface cannot" &
+ " inherit from protected interface", Iface);
+
+ else
+ Error_Msg_N ("(Ada 2005) task interface cannot" &
+ " inherit from non-limited interface", Iface);
+ end if;
+ end if;
+ end if;
+
+ Next (Iface);
+ end loop;
+
+ Set_Abstract_Interfaces (T, New_Elmt_List);
+ Collect_Interfaces (Type_Definition (N), T);
+ end;
+ end if;
+
+ -- Records constitute a scope for the component declarations within.
+ -- The scope is created prior to the processing of these declarations.
+ -- Discriminants are processed first, so that they are visible when
+ -- processing the other components. The Ekind of the record type itself
+ -- is set to E_Record_Type (subtypes appear as E_Record_Subtype).
+
+ -- Enter record scope
+
+ New_Scope (T);
-- If an incomplete or private type declaration was already given for
-- the type, then this scope already exists, and the discriminants have
Enter_Name (Tag_Comp);
Set_Is_Tag (Tag_Comp);
+ Set_Is_Aliased (Tag_Comp);
Set_Ekind (Tag_Comp, E_Component);
Set_Etype (Tag_Comp, RTE (RE_Tag));
Set_DT_Entry_Count (Tag_Comp, No_Uint);
Set_Original_Record_Component (Tag_Comp, Tag_Comp);
Init_Component_Location (Tag_Comp);
+
+ -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
+ -- implemented interfaces
+
+ Add_Interface_Tag_Components (N, T);
end if;
Make_Class_Wide_Type (T);
-- Exit from record scope
End_Scope;
+
+ if Expander_Active
+ and then Is_Tagged
+ and then not Is_Empty_List (Interface_List (Def))
+ then
+ -- Ada 2005 (AI-251): Derive the interface subprograms of all the
+ -- implemented interfaces and check if some of the subprograms
+ -- inherited from the ancestor cover some interface subprogram.
+
+ Derive_Interface_Subprograms (T);
+ end if;
end Record_Type_Declaration;
----------------------------
-- --
-- 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- --
else
declare
- Def_Id : Entity_Id;
+ Def_Id : Entity_Id;
+ Base_Typ : Entity_Id;
begin
-- If the allocator includes a N_Subtype_Indication then a
-- access-to-composite type, but the constraint is ignored.
Find_Type (Subtype_Mark (E));
+ Base_Typ := Entity (Subtype_Mark (E));
- if Is_Elementary_Type (Entity (Subtype_Mark (E))) then
+ if Is_Elementary_Type (Base_Typ) then
if not (Ada_Version = Ada_83
- and then Is_Access_Type (Entity (Subtype_Mark (E))))
+ and then Is_Access_Type (Base_Typ))
then
Error_Msg_N ("constraint not allowed here", E);
Rewrite (E, New_Copy_Tree (Subtype_Mark (E)));
Analyze_Allocator (N);
return;
+
+ -- Ada 2005, AI-363: if the designated type has a constrained
+ -- partial view, it cannot receive a discriminant constraint,
+ -- and the allocated object is unconstrained.
+
+ elsif Ada_Version >= Ada_05
+ and then Has_Constrained_Partial_View (Base_Typ)
+ then
+ Error_Msg_N
+ ("constraint no allowed when type " &
+ "has a constrained partial view", Constraint (E));
end if;
if Expander_Active then
if Ekind (Etype (Nam)) = E_Subprogram_Type then
Nam_Ent := Etype (Nam);
+ -- If the prefix is an access_to_subprogram, this may be an indirect
+ -- call. This is the case if the name in the call is not an entity
+ -- name, or if it is a function name in the context of a procedure
+ -- call. In this latter case, we have a call to a parameterless
+ -- function that returns a pointer_to_procedure which is the entity
+ -- being called.
+
elsif Is_Access_Type (Etype (Nam))
and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type
- and then not Name_Denotes_Function
+ and then
+ (not Name_Denotes_Function
+ or else Nkind (N) = N_Procedure_Call_Statement)
then
Nam_Ent := Designated_Type (Etype (Nam));
Insert_Explicit_Dereference (Nam);
Is_Indexed :=
Try_Indexed_Call (N, Nam, Designated_Type (Subp_Type));
+ -- The prefix can also be a parameterless function that returns an
+ -- access to subprogram. in which case this is an indirect call.
+
elsif Is_Access_Type (Subp_Type)
and then Ekind (Designated_Type (Subp_Type)) = E_Subprogram_Type
then
end if;
if Report and not Is_Indexed then
+
+ -- Ada 2005 (AI-251): Complete the error notification
+ -- to help new Ada 2005 users
+
+ if Is_Class_Wide_Type (Etype (Formal))
+ and then Is_Interface (Etype (Etype (Formal)))
+ and then not Interface_Present_In_Ancestor
+ (Typ => Etype (Actual),
+ Iface => Etype (Etype (Formal)))
+ then
+ Error_Msg_Name_1 := Chars (Actual);
+ Error_Msg_Name_2 := Chars (Etype (Etype (Formal)));
+ Error_Msg_NE
+ ("(Ada 2005) % does not implement interface %",
+ Actual, Etype (Etype (Formal)));
+ end if;
+
Wrong_Type (Actual, Etype (Formal));
if Nkind (Actual) = N_Op_Eq
end if;
+ -- Before analysis, the function call appears as an
+ -- indexed component.
+
+ elsif Nkind (Parent_Node) = N_Indexed_Component then
+ Node_To_Replace := Parent_Node;
+
+ declare
+ Actual : Node_Id;
+ New_Act : Node_Id;
+ begin
+ Actual := First (Expressions (Parent_Node));
+ while Present (Actual) loop
+ New_Act := New_Copy_Tree (Actual);
+ Analyze (New_Act);
+ Append (New_Act, Actuals);
+ Next (Actual);
+ end loop;
+ end;
+
+ Call_Node :=
+ Make_Function_Call (Loc,
+ Name => New_Copy_Tree (Subprog),
+ Parameter_Associations => Actuals);
+
-- Parameterless call
else
Make_Function_Call (Loc,
Name => New_Copy_Tree (Subprog),
Parameter_Associations => Actuals);
-
end if;
end Transform_Object_Operation;
-- --
-- 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- --
-- against a formal access-to-subprogram type so Get_Instance_Of must
-- be called.
- procedure Check_Overriding_Operation
- (N : Node_Id;
- Subp : Entity_Id);
- -- Check that a subprogram with a pragma Overriding or Optional_Overriding
- -- is legal. This check is performed here rather than in Sem_Prag because
- -- the pragma must follow immediately the declaration, and can be treated
- -- as part of the declaration itself, as described in AI-218.
+ procedure Check_Overriding_Indicator
+ (Subp : Entity_Id;
+ Does_Override : Boolean);
+ -- Verify the consistency of an overriding_indicator given for subprogram
+ -- declaration, body, renaming, or instantiation. The flag Does_Override
+ -- is set if the scope into which we are introducing the subprogram
+ -- contains a type-conformant subprogram that becomes hidden by the new
+ -- subprogram.
procedure Check_Subprogram_Order (N : Node_Id);
-- N is the N_Subprogram_Body node for a subprogram. This routine applies
Analyze (P);
+ -- If this is a call of the form Obj.Op, the call may have been
+ -- analyzed and possibly rewritten into a block, in which case
+ -- we are done.
+
+ if Analyzed (N) then
+ return;
+ end if;
+
-- If error analyzing prefix, then set Any_Type as result and return
if Etype (P) = Any_Type then
-- Anything else is an error
else
- Error_Msg_N ("Invalid procedure or entry call", N);
+ Error_Msg_N ("invalid procedure or entry call", N);
end if;
end Analyze_Procedure_Call;
-- If front-end inlining is enabled, look ahead to recognize a pragma
-- that may appear after the body.
+ procedure Verify_Overriding_Indicator;
+ -- If there was a previous spec, the entity has been entered in the
+ -- current scope previously. If the body itself carries an overriding
+ -- indicator, check that it is consistent with the known status of the
+ -- entity.
+
+ ----------------------------
+ -- Check_Following_Pragma --
+ ----------------------------
+
procedure Check_Following_Pragma is
Prag : Node_Id;
end if;
end Check_Following_Pragma;
+ ---------------------------------
+ -- Verify_Overriding_Indicator --
+ ---------------------------------
+
+ procedure Verify_Overriding_Indicator is
+ begin
+ if Must_Override (Body_Spec)
+ and then not Is_Overriding_Operation (Spec_Id)
+ then
+ Error_Msg_NE
+ ("subprogram& is not overriding", Body_Spec, Spec_Id);
+
+ elsif Must_Not_Override (Body_Spec)
+ and then Is_Overriding_Operation (Spec_Id)
+ then
+ Error_Msg_NE
+ ("subprogram& overrides inherited operation",
+ Body_Spec, Spec_Id);
+ end if;
+ end Verify_Overriding_Indicator;
+
-- Start of processing for Analyze_Subprogram_Body
begin
elsif Present (Spec_Id) then
Spec_Decl := Unit_Declaration_Node (Spec_Id);
+ Verify_Overriding_Indicator;
end if;
-- Place subprogram on scope stack, and make formals visible. If there
if Present (Spec_Id) then
Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);
+
+ if Is_Child_Unit (Spec_Id) then
+ Generate_Reference (Spec_Id, Scope (Spec_Id), 'k', False);
+ end if;
+
if Style_Check then
Style.Check_Identifier (Body_Id, Spec_Id);
end if;
if Nkind (N) /= N_Subprogram_Body_Stub then
Set_Corresponding_Spec (N, Spec_Id);
+
+ -- Ada 2005 (AI-345): Restore the correct Etype: here we undo the
+ -- work done by Analyze_Subprogram_Specification to allow the
+ -- overriding of task, protected and interface primitives.
+
+ if Comes_From_Source (Spec_Id)
+ and then Present (First_Entity (Spec_Id))
+ and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type
+ and then Is_Tagged_Type (Etype (First_Entity (Spec_Id)))
+ and then Present (Abstract_Interfaces
+ (Etype (First_Entity (Spec_Id))))
+ and then Present (Corresponding_Concurrent_Type
+ (Etype (First_Entity (Spec_Id))))
+ then
+ Set_Etype (First_Entity (Spec_Id),
+ Corresponding_Concurrent_Type
+ (Etype (First_Entity (Spec_Id))));
+ end if;
+
+ -- Comment needed here, since this is not Ada 2005 stuff! ???
+
Install_Formals (Spec_Id);
Last_Formal := Last_Entity (Spec_Id);
New_Scope (Spec_Id);
if Nkind (Parent (N)) = N_Compilation_Unit then
Set_Body_Required (Parent (N), True);
+
+ if Ada_Version >= Ada_05
+ and then Nkind (Specification (N)) = N_Procedure_Specification
+ and then Null_Present (Specification (N))
+ then
+ Error_Msg_N
+ ("null procedure cannot be declared at library level", N);
+ end if;
end if;
Generate_Reference_To_Formals (Designator);
Check_Eliminated (Designator);
- if Comes_From_Source (N)
- and then Is_List_Member (N)
+ -- Ada 2005: if procedure is declared with "is null" qualifier,
+ -- it requires no body.
+
+ if Nkind (Specification (N)) = N_Procedure_Specification
+ and then Null_Present (Specification (N))
then
- Check_Overriding_Operation (N, Designator);
+ Set_Has_Completion (Designator);
+ Set_Is_Inlined (Designator);
end if;
end Analyze_Subprogram_Declaration;
Designator : constant Entity_Id := Defining_Entity (N);
Formals : constant List_Id := Parameter_Specifications (N);
+ function Has_Interface_Formals (T : List_Id) return Boolean;
+ -- Ada 2005 (AI-251): Returns true if some non class-wide interface
+ -- formal is found.
+
+ ---------------------------
+ -- Has_Interface_Formals --
+ ---------------------------
+
+ function Has_Interface_Formals (T : List_Id) return Boolean is
+ Param_Spec : Node_Id;
+ Formal : Entity_Id;
+
+ begin
+ Param_Spec := First (T);
+
+ while Present (Param_Spec) loop
+ Formal := Defining_Identifier (Param_Spec);
+
+ if Is_Class_Wide_Type (Etype (Formal)) then
+ null;
+
+ elsif Is_Interface (Etype (Formal)) then
+ return True;
+ end if;
+
+ Next (Param_Spec);
+ end loop;
+
+ return False;
+ end Has_Interface_Formals;
+
+ -- Start of processing for Analyze_Subprogram_Specification
+
begin
Generate_Definition (Designator);
if Present (Formals) then
New_Scope (Designator);
Process_Formals (Formals, N);
+
+ -- Ada 2005 (AI-345): Allow overriding primitives of protected
+ -- interfaces by means of normal subprograms. For this purpose
+ -- temporarily use the corresponding record type as the etype
+ -- of the first formal.
+
+ if Ada_Version >= Ada_05
+ and then Comes_From_Source (Designator)
+ and then Present (First_Entity (Designator))
+ and then (Ekind (Etype (First_Entity (Designator)))
+ = E_Protected_Type
+ or else
+ Ekind (Etype (First_Entity (Designator)))
+ = E_Task_Type)
+ and then Present (Corresponding_Record_Type
+ (Etype (First_Entity (Designator))))
+ and then Present (Abstract_Interfaces
+ (Corresponding_Record_Type
+ (Etype (First_Entity (Designator)))))
+ then
+ Set_Etype (First_Entity (Designator),
+ Corresponding_Record_Type (Etype (First_Entity (Designator))));
+ end if;
+
End_Scope;
elsif Nkind (N) = N_Function_Specification then
end if;
end if;
+ if Ada_Version >= Ada_05
+ and then Comes_From_Source (N)
+ and then Nkind (Parent (N)) /= N_Abstract_Subprogram_Declaration
+ and then (Nkind (N) /= N_Procedure_Specification
+ or else
+ not Null_Present (N))
+ and then Has_Interface_Formals (Formals)
+ then
+ Error_Msg_Name_1 := Chars (Defining_Unit_Name
+ (Specification (Parent (N))));
+ Error_Msg_N
+ ("(Ada 2005) interface subprogram % must be abstract or null", N);
+ end if;
+
return Designator;
end Analyze_Subprogram_Specification;
then
Conv := Current_Entity (Id);
- elsif Nkind (Id) = N_Selected_Component
+ elsif (Nkind (Id) = N_Selected_Component
+ or else Nkind (Id) = N_Expanded_Name)
and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
then
Conv := Current_Entity (Selector_Name (Id));
return False;
end if;
- return
- Present (Conv)
- and then Scope (Conv) = Standard_Standard
+ return Present (Conv)
+ and then Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Conv)))
and then Is_Intrinsic_Subprogram (Conv);
end Is_Unchecked_Conversion;
end Check_Mode_Conformant;
--------------------------------
- -- Check_Overriding_Operation --
+ -- Check_Overriding_Indicator --
--------------------------------
- procedure Check_Overriding_Operation
- (N : Node_Id;
- Subp : Entity_Id)
+ procedure Check_Overriding_Indicator
+ (Subp : Entity_Id;
+ Does_Override : Boolean)
is
- Arg1 : Node_Id;
- Decl : Node_Id;
- Has_Pragma : Boolean := False;
+ Decl : Node_Id;
+ Spec : Node_Id;
begin
- -- See whether there is an overriding pragma immediately following
- -- the declaration. Intervening pragmas, such as Inline, are allowed.
-
- Decl := Next (N);
- while Present (Decl)
- and then Nkind (Decl) = N_Pragma
- loop
- if Chars (Decl) = Name_Overriding
- or else Chars (Decl) = Name_Optional_Overriding
- then
- -- For now disable the use of these pragmas, until the ARG
- -- finalizes the design of this feature.
-
- Error_Msg_N ("?unrecognized pragma", Decl);
-
- if not Is_Overriding_Operation (Subp) then
-
- -- Before emitting an error message, check whether this
- -- may override an operation that is not yet visible, as
- -- in the case of a derivation of a private operation in
- -- a child unit. Such an operation is introduced with a
- -- different name, but its alias is the parent operation.
-
- declare
- E : Entity_Id;
-
- begin
- E := First_Entity (Current_Scope);
-
- while Present (E) loop
- if Ekind (E) = Ekind (Subp)
- and then not Comes_From_Source (E)
- and then Present (Alias (E))
- and then Chars (Alias (E)) = Chars (Subp)
- and then In_Open_Scopes (Scope (Alias (E)))
- then
- exit;
- else
- Next_Entity (E);
- end if;
- end loop;
-
- if No (E) then
- Error_Msg_NE
- ("& must override an inherited operation",
- Decl, Subp);
- end if;
- end;
- end if;
+ if Ekind (Subp) = E_Enumeration_Literal then
- -- Verify syntax of pragma
+ -- No overriding indicator for literals
- Arg1 := First (Pragma_Argument_Associations (Decl));
-
- if Present (Arg1) then
- if not Is_Entity_Name (Expression (Arg1)) then
- Error_Msg_N ("pragma applies to local subprogram", Decl);
+ return;
- elsif Chars (Expression (Arg1)) /= Chars (Subp) then
- Error_Msg_N
- ("pragma must apply to preceding subprogram", Decl);
+ else
+ Decl := Unit_Declaration_Node (Subp);
+ end if;
- elsif Present (Next (Arg1)) then
- Error_Msg_N ("illegal pragma format", Decl);
- end if;
- end if;
+ if Nkind (Decl) = N_Subprogram_Declaration
+ or else Nkind (Decl) = N_Subprogram_Body
+ or else Nkind (Decl) = N_Subprogram_Renaming_Declaration
+ or else Nkind (Decl) = N_Subprogram_Body_Stub
+ then
+ Spec := Specification (Decl);
+ else
+ return;
+ end if;
- Set_Analyzed (Decl);
- Has_Pragma := True;
- exit;
+ if not Does_Override then
+ if Must_Override (Spec) then
+ Error_Msg_NE ("subprogram& is not overriding", Spec, Subp);
end if;
- Next (Decl);
- end loop;
-
- if not Has_Pragma
- and then Explicit_Overriding
- and then Is_Overriding_Operation (Subp)
- then
- Error_Msg_NE ("Missing overriding pragma for&", Subp, Subp);
+ else
+ if Must_Not_Override (Spec) then
+ Error_Msg_NE
+ ("subprogram& overrides inherited operation", Spec, Subp);
+ end if;
end if;
- end Check_Overriding_Operation;
+ end Check_Overriding_Indicator;
-------------------
-- Check_Returns --
end if;
end Base_Types_Match;
+ -- Start of processing for Conforming_Types
+
begin
-- The context is an instance association for a formal
-- access-to-subprogram type; the formal parameter types require
or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
end if;
- -- Ada 2005 (AI-254): Detect anonymous access to subprogram types
+ -- Ada 2005 (AI-254): Anonymous access to subprogram types must be
+ -- treated recursively because they carry a signature.
Are_Anonymous_Access_To_Subprogram_Types :=
Etype (Base_Type (Desig_2)), Ctype);
elsif Are_Anonymous_Access_To_Subprogram_Types then
- return Ctype = Type_Conformant
- or else
+ if Ada_Version < Ada_05 then
+ return Ctype = Type_Conformant
+ or else
Subtypes_Statically_Match (Desig_1, Desig_2);
+ -- We must check the conformance of the signatures themselves
+
+ else
+ declare
+ Conformant : Boolean;
+ begin
+ Check_Conformance
+ (Desig_1, Desig_2, Ctype, False, Conformant);
+ return Conformant;
+ end;
+ end if;
+
else
return Base_Type (Desig_1) = Base_Type (Desig_2)
and then (Ctype = Type_Conformant
(S : Entity_Id;
Derived_Type : Entity_Id := Empty)
is
+ Does_Override : Boolean := False;
+ -- Set if the current scope has an operation that is type-conformant
+ -- with S, and becomes hidden by S.
+
E : Entity_Id;
-- Entity that S overrides
Prev_Vis : Entity_Id := Empty;
-- Needs comment ???
+ Is_Alias_Interface : Boolean := False;
+
function Is_Private_Declaration (E : Entity_Id) return Boolean;
-- Check that E is declared in the private part of the current package,
-- or in the package body, where it may hide a previous declaration.
and then Is_Abstract (S)
and then (not Is_Overriding or else not Is_Abstract (E))
then
- Error_Msg_N ("abstract subprograms must be visible "
- & "('R'M 3.9.3(10))!", S);
+ if not Is_Interface (T) then
+ Error_Msg_N ("abstract subprograms must be visible "
+ & "('R'M 3.9.3(10))!", S);
+
+ -- Ada 2005 (AI-251)
+
+ else
+ Error_Msg_N ("primitive subprograms of interface types "
+ & "declared in a visible part, must be declared in "
+ & "the visible part ('R'M 3.9.4)!", S);
+ end if;
elsif Ekind (S) = E_Function
and then Is_Tagged_Type (T)
Check_Dispatching_Operation (S, Empty);
Maybe_Primitive_Operation;
+ -- Ada 2005 (AI-397): Subprograms in the context of protected
+ -- types have their overriding indicators checked in Sem_Ch9.
+
+ if Ekind (S) not in Subprogram_Kind
+ or else Ekind (Scope (S)) /= E_Protected_Type
+ then
+ Check_Overriding_Indicator (S, False);
+ end if;
+
-- If there is a homonym that is not overloadable, then we have an
-- error, except for the special cases checked explicitly below.
Enter_Overloaded_Entity (S);
Set_Homonym (S, Homonym (E));
Check_Dispatching_Operation (S, Empty);
+ Check_Overriding_Indicator (S, False);
-- If the subprogram is implicit it is hidden by the previous
-- declaration. However if it is dispatching, it must appear in the
-- E exists and is overloadable
else
+ Is_Alias_Interface :=
+ Present (Alias (S))
+ and then Is_Dispatching_Operation (Alias (S))
+ and then Present (DTC_Entity (Alias (S)))
+ and then Is_Interface (Scope (DTC_Entity (Alias (S))));
+
-- Loop through E and its homonyms to determine if any of them is
-- the candidate for overriding by S.
-- Check if we have type conformance
- elsif Type_Conformant (E, S) then
+ -- Ada 2005 (AI-251): In case of overriding an interface
+ -- subprogram it is not an error that the old and new entities
+ -- have the same profile, and hence we skip this code.
+ elsif not Is_Alias_Interface
+ and then Type_Conformant (E, S)
+ then
-- If the old and new entities have the same profile and one
-- is not the body of the other, then this is an error, unless
-- one of them is implicitly declared.
-- the existing declaration, which is overriding.
Set_Is_Overriding_Operation (E);
+
+ if Comes_From_Source (E) then
+ Check_Overriding_Indicator (E, True);
+ end if;
+
return;
-- Within an instance, the renaming declarations for
-- replaced in the list of primitive operations of its type
-- (see Override_Dispatching_Operation).
+ Does_Override := True;
+
declare
Prev : Entity_Id;
Enter_Overloaded_Entity (S);
Set_Is_Overriding_Operation (S);
+ Check_Overriding_Indicator (S, True);
if Is_Dispatching_Operation (E) then
Set_Convention (S, Convention (E));
- Check_Dispatching_Operation (S, E);
+ -- AI-251: If the subprogram implements an interface,
+ -- check if this subprogram covers other interface
+ -- subprograms available in the same scope.
+
+ if Present (Alias (E))
+ and then Ekind (Alias (E)) /= E_Operator
+ and then Present (DTC_Entity (Alias (E)))
+ and then Is_Interface (Scope (DTC_Entity
+ (Alias (E))))
+ then
+ Check_Dispatching_Operation (S, E);
+
+ declare
+ E1 : Entity_Id;
+
+ begin
+ E1 := Homonym (E);
+ while Present (E1) loop
+ if Present (Alias (E1))
+ and then Ekind (Alias (E1)) /= E_Operator
+ and then Present (DTC_Entity (Alias (E1)))
+ and then Is_Interface
+ (Scope (DTC_Entity (Alias (E1))))
+ and then Type_Conformant (E1, S)
+ then
+ Check_Dispatching_Operation (S, E1);
+ end if;
+
+ E1 := Homonym (E1);
+ end loop;
+ end;
+ else
+ Check_Dispatching_Operation (S, E);
+ end if;
+
else
Check_Dispatching_Operation (S, Empty);
end if;
Enter_Overloaded_Entity (S);
Maybe_Primitive_Operation;
+ Check_Overriding_Indicator (S, Does_Override);
-- If S is a derived operation for an untagged type then by
-- definition it's not a dispatching operation (even if the parent
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Errout; use Errout;
with Exp_Ch9;
with Elists; use Elists;
+with Freeze; use Freeze;
with Itypes; use Itypes;
with Lib.Xref; use Lib.Xref;
with Nlists; use Nlists;
-- count the entries (checking the static requirement), and compare with
-- the given maximum.
+ procedure Check_Overriding_Indicator (Def : Node_Id);
+ -- Ada 2005 (AI-397): Check the overriding indicator of entries and
+ -- subprograms of protected or task types. Def is the definition of
+ -- the protected or task type.
+
function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
-- Find entity in corresponding task or protected declaration. Use full
-- view if first declaration was for an incomplete type.
Check_Max_Entries (N, Max_Protected_Entries);
Process_End_Label (N, 'e', Current_Scope);
+ Check_Overriding_Indicator (N);
end Analyze_Protected_Definition;
----------------------------
----------------------------
procedure Analyze_Protected_Type (N : Node_Id) is
- E : Entity_Id;
- T : Entity_Id;
- Def_Id : constant Entity_Id := Defining_Identifier (N);
+ E : Entity_Id;
+ T : Entity_Id;
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
+ Iface : Node_Id;
+ Iface_Def : Node_Id;
+ Iface_Typ : Entity_Id;
begin
if No_Run_Time_Mode then
end if;
Set_Ekind (T, E_Protected_Type);
+ Set_Is_First_Subtype (T, True);
Init_Size_Align (T);
Set_Etype (T, T);
- Set_Is_First_Subtype (T, True);
Set_Has_Delayed_Freeze (T, True);
Set_Stored_Constraint (T, No_Elist);
New_Scope (T);
+ -- Ada 2005 (AI-345)
+
+ if Present (Interface_List (N)) then
+ Iface := First (Interface_List (N));
+
+ while Present (Iface) loop
+ Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
+ Iface_Def := Type_Definition (Parent (Iface_Typ));
+
+ if not Is_Interface (Iface_Typ) then
+ Error_Msg_NE ("(Ada 2005) & must be an interface",
+ Iface, Iface_Typ);
+
+ else
+ -- Ada 2005 (AI-251): "The declaration of a specific
+ -- descendant of an interface type freezes the interface
+ -- type" RM 13.14
+
+ Freeze_Before (N, Etype (Iface));
+
+ -- Ada 2005 (AI-345): Protected types can only implement
+ -- limited, synchronized or protected interfaces.
+
+ if Limited_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def)
+ or else Protected_Present (Iface_Def)
+ then
+ null;
+
+ elsif Task_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) protected type cannot implement a "
+ & "task interface", Iface);
+
+ else
+ Error_Msg_N ("(Ada 2005) protected type cannot implement a "
+ & "non-limited interface", Iface);
+ end if;
+ end if;
+
+ Next (Iface);
+ end loop;
+ end if;
+
if Present (Discriminant_Specifications (N)) then
if Has_Discriminants (T) then
end if;
end if;
+ Set_Is_Constrained (T, not Has_Discriminants (T));
+
Analyze (Protected_Definition (N));
-- Protected types with entries are controlled (because of the
---------------------
procedure Analyze_Requeue (N : Node_Id) is
+ Count : Natural := 0;
Entry_Name : Node_Id := Name (N);
Entry_Id : Entity_Id;
- Found : Boolean;
I : Interp_Index;
It : Interp;
Enclosing : Entity_Id;
if Is_Overloaded (Entry_Name) then
Get_First_Interp (Entry_Name, I, It);
- Found := False;
Entry_Id := Empty;
while Present (It.Nam) loop
if No (First_Formal (It.Nam))
or else Subtype_Conformant (Enclosing, It.Nam)
then
- if not Found then
- Found := True;
+
+ -- Ada 2005 (AI-345): Since protected and task types have
+ -- primitive entry wrappers, we only consider source entries.
+
+ if Comes_From_Source (It.Nam) then
+ Count := Count + 1;
Entry_Id := It.Nam;
else
- Error_Msg_N ("ambiguous entry name in requeue", N);
- return;
+ Remove_Interp (I);
end if;
end if;
Get_Next_Interp (I, It);
end loop;
- if not Found then
- Error_Msg_N ("no entry matches context", N);
+ if Count = 0 then
+ Error_Msg_N ("no entry matches context", N);
+ return;
+
+ elsif Count > 1 then
+ Error_Msg_N ("ambiguous entry name in requeue", N);
return;
+
else
+ Set_Is_Overloaded (Entry_Name, False);
Set_Entity (Entry_Name, Entry_Id);
end if;
elsif Nkind (Alt) = N_Terminate_Alternative then
if Terminate_Present then
- Error_Msg_N ("Only one terminate alternative allowed", N);
+ Error_Msg_N ("only one terminate alternative allowed", N);
else
Terminate_Present := True;
Check_Restriction (No_Terminate_Alternatives, N);
T_Decl :=
Make_Protected_Type_Declaration (Loc,
Defining_Identifier => T,
- Protected_Definition => Relocate_Node (Protected_Definition (N)));
+ Protected_Definition => Relocate_Node (Protected_Definition (N)),
+ Interface_List => Interface_List (N));
+
+ -- Ada 2005 (AI-399): Mark the object as aliased. Required to use
+ -- the attribute 'access
O_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => O_Name,
+ Aliased_Present => Ada_Version >= Ada_05,
Object_Definition => Make_Identifier (Loc, Chars (T)));
Rewrite (N, T_Decl);
-- expanded twice, with disastrous result.
Analyze_Protected_Type (N);
-
end Analyze_Single_Protected;
-------------------------
T_Decl :=
Make_Task_Type_Declaration (Loc,
Defining_Identifier => T,
- Task_Definition => Relocate_Node (Task_Definition (N)));
+ Task_Definition => Relocate_Node (Task_Definition (N)),
+ Interface_List => Interface_List (N));
+
+ -- Ada 2005 (AI-399): Mark the object as aliased. Required to use
+ -- the attribute 'access
O_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => O_Name,
+ Aliased_Present => Ada_Version >= Ada_05,
Object_Definition => Make_Identifier (Loc, Chars (T)));
Rewrite (N, T_Decl);
Check_Max_Entries (N, Max_Task_Entries);
Process_End_Label (N, 'e', Current_Scope);
+ Check_Overriding_Indicator (N);
end Analyze_Task_Definition;
-----------------------
-----------------------
procedure Analyze_Task_Type (N : Node_Id) is
- T : Entity_Id;
- Def_Id : constant Entity_Id := Defining_Identifier (N);
+ T : Entity_Id;
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
+ Iface : Node_Id;
+ Iface_Def : Node_Id;
+ Iface_Typ : Entity_Id;
begin
Check_Restriction (No_Tasking, N);
Set_Stored_Constraint (T, No_Elist);
New_Scope (T);
+ -- Ada 2005 (AI-345)
+
+ if Present (Interface_List (N)) then
+ Iface := First (Interface_List (N));
+ while Present (Iface) loop
+ Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
+ Iface_Def := Type_Definition (Parent (Iface_Typ));
+
+ if not Is_Interface (Iface_Typ) then
+ Error_Msg_NE ("(Ada 2005) & must be an interface",
+ Iface, Iface_Typ);
+
+ else
+ -- Ada 2005 (AI-251): The declaration of a specific descendant
+ -- of an interface type freezes the interface type (RM 13.14).
+
+ Freeze_Before (N, Etype (Iface));
+
+ -- Ada 2005 (AI-345): Task types can only implement limited,
+ -- synchronized or task interfaces.
+
+ if Limited_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def)
+ or else Task_Present (Iface_Def)
+ then
+ null;
+
+ elsif Protected_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) task type cannot implement a " &
+ "protected interface", Iface);
+
+ else
+ Error_Msg_N ("(Ada 2005) task type cannot implement a " &
+ "non-limited interface", Iface);
+ end if;
+ end if;
+
+ Next (Iface);
+ end loop;
+ end if;
+
if Present (Discriminant_Specifications (N)) then
if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
end if;
end if;
+ Set_Is_Constrained (T, not Has_Discriminants (T));
+
if Present (Task_Definition (N)) then
Analyze_Task_Definition (Task_Definition (N));
end if;
end if;
end Check_Max_Entries;
+ --------------------------------
+ -- Check_Overriding_Indicator --
+ --------------------------------
+
+ procedure Check_Overriding_Indicator (Def : Node_Id) is
+ Aliased_Hom : Entity_Id;
+ Decl : Node_Id;
+ Def_Id : Entity_Id;
+ Hom : Entity_Id;
+ Ifaces : constant List_Id := Interface_List (Parent (Def));
+ Overrides : Boolean;
+ Spec : Node_Id;
+ Vis_Decls : constant List_Id := Visible_Declarations (Def);
+
+ function Matches_Prefixed_View_Profile
+ (Ifaces : List_Id;
+ Entry_Params : List_Id;
+ Proc_Params : List_Id) return Boolean;
+ -- Ada 2005 (AI-397): Determine if an entry parameter profile matches
+ -- the prefixed view profile of an abstract procedure. Also determine
+ -- whether the abstract procedure belongs to an implemented interface.
+
+ -----------------------------------
+ -- Matches_Prefixed_View_Profile --
+ -----------------------------------
+
+ function Matches_Prefixed_View_Profile
+ (Ifaces : List_Id;
+ Entry_Params : List_Id;
+ Proc_Params : List_Id) return Boolean
+ is
+ Entry_Param : Node_Id;
+ Proc_Param : Node_Id;
+ Proc_Param_Typ : Entity_Id;
+
+ function Includes_Interface
+ (Iface : Entity_Id;
+ Ifaces : List_Id) return Boolean;
+ -- Determine if an interface is contained in a list of interfaces
+
+ ------------------------
+ -- Includes_Interface --
+ ------------------------
+
+ function Includes_Interface
+ (Iface : Entity_Id;
+ Ifaces : List_Id) return Boolean
+ is
+ Ent : Entity_Id;
+
+ begin
+ Ent := First (Ifaces);
+
+ while Present (Ent) loop
+ if Etype (Ent) = Iface then
+ return True;
+ end if;
+
+ Next (Ent);
+ end loop;
+
+ return False;
+ end Includes_Interface;
+
+ -- Start of processing for Matches_Prefixed_View_Profile
+
+ begin
+ Proc_Param := First (Proc_Params);
+ Proc_Param_Typ := Etype (Parameter_Type (Proc_Param));
+
+ -- The first parameter of the abstract procedure must be of an
+ -- interface type. The task or protected type must also implement
+ -- that interface.
+
+ if not Is_Interface (Proc_Param_Typ)
+ or else not Includes_Interface (Proc_Param_Typ, Ifaces)
+ then
+ return False;
+ end if;
+
+ Entry_Param := First (Entry_Params);
+ Proc_Param := Next (Proc_Param);
+ 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)
+ or else Etype (Parameter_Type (Entry_Param)) /=
+ Etype (Parameter_Type (Proc_Param))
+ then
+ return False;
+ end if;
+
+ Next (Entry_Param);
+ Next (Proc_Param);
+ end loop;
+
+ -- One of the lists is longer than the other
+
+ if Present (Entry_Param) or else Present (Proc_Param) then
+ return False;
+ end if;
+
+ return True;
+ end Matches_Prefixed_View_Profile;
+
+ -- Start of processing for Check_Overriding_Indicator
+
+ begin
+ if Present (Ifaces) then
+ Decl := First (Vis_Decls);
+ while Present (Decl) loop
+
+ -- Consider entries with either "overriding" or "not overriding"
+ -- indicator present.
+
+ if Nkind (Decl) = N_Entry_Declaration
+ and then (Must_Override (Decl)
+ or else
+ Must_Not_Override (Decl))
+ then
+ Def_Id := Defining_Identifier (Decl);
+
+ Overrides := False;
+
+ Hom := Homonym (Def_Id);
+ while Present (Hom) loop
+
+ -- The current entry may override a procedure from an
+ -- implemented interface.
+
+ if Ekind (Hom) = E_Procedure
+ and then (Is_Abstract (Hom)
+ or else
+ Null_Present (Parent (Hom)))
+ then
+ Aliased_Hom := Hom;
+
+ while Present (Alias (Aliased_Hom)) loop
+ Aliased_Hom := Alias (Aliased_Hom);
+ end loop;
+
+ if Matches_Prefixed_View_Profile (Ifaces,
+ Parameter_Specifications (Decl),
+ Parameter_Specifications (Parent (Aliased_Hom)))
+ then
+ Overrides := True;
+ exit;
+ end if;
+ end if;
+
+ Hom := Homonym (Hom);
+ end loop;
+
+ if Overrides then
+ if Must_Not_Override (Decl) then
+ Error_Msg_NE ("entry& is overriding", Def_Id, Def_Id);
+ end if;
+ else
+ if Must_Override (Decl) then
+ Error_Msg_NE ("entry& is not overriding", Def_Id, Def_Id);
+ end if;
+ end if;
+
+ -- Consider subprograms with either "overriding" or "not
+ -- overriding" indicator present.
+
+ elsif Nkind (Decl) = N_Subprogram_Declaration
+ and then (Must_Override (Specification (Decl))
+ or else
+ Must_Not_Override (Specification (Decl)))
+ then
+ Spec := Specification (Decl);
+ Def_Id := Defining_Unit_Name (Spec);
+
+ Overrides := False;
+
+ Hom := Homonym (Def_Id);
+ while Present (Hom) loop
+
+ -- Function
+
+ if Ekind (Def_Id) = E_Function
+ and then Ekind (Hom) = E_Function
+ and then Is_Abstract (Hom)
+ and then Matches_Prefixed_View_Profile (Ifaces,
+ Parameter_Specifications (Spec),
+ Parameter_Specifications (Parent (Hom)))
+ and then Etype (Subtype_Mark (Spec)) =
+ Etype (Subtype_Mark (Parent (Hom)))
+ then
+ Overrides := True;
+ exit;
+
+ -- Procedure
+
+ elsif Ekind (Def_Id) = E_Procedure
+ and then Ekind (Hom) = E_Procedure
+ and then (Is_Abstract (Hom)
+ or else
+ Null_Present (Parent (Hom)))
+ and then Matches_Prefixed_View_Profile (Ifaces,
+ Parameter_Specifications (Spec),
+ Parameter_Specifications (Parent (Hom)))
+ then
+ Overrides := True;
+ exit;
+ end if;
+
+ Hom := Homonym (Hom);
+ end loop;
+
+ if Overrides then
+ if Must_Not_Override (Spec) then
+ Error_Msg_NE
+ ("subprogram& is overriding", Def_Id, Def_Id);
+ end if;
+ else
+ if Must_Override (Spec) then
+ Error_Msg_NE
+ ("subprogram& is not overriding", Def_Id, Def_Id);
+ end if;
+ end if;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ -- The protected or task type is not implementing an interface,
+ -- we need to check for the presence of "overriding" entries or
+ -- subprograms and flag them as erroneous.
+
+ else
+ Decl := First (Vis_Decls);
+
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Entry_Declaration
+ and then Must_Override (Decl)
+ then
+ Def_Id := Defining_Identifier (Decl);
+ Error_Msg_NE ("entry& is not overriding", Def_Id, Def_Id);
+
+ elsif Nkind (Decl) = N_Subprogram_Declaration
+ and then Must_Override (Specification (Decl))
+ then
+ Def_Id := Defining_Identifier (Specification (Decl));
+ Error_Msg_NE ("subprogram& is not overriding", Def_Id, Def_Id);
+ end if;
+
+ Next (Decl);
+ end loop;
+ end if;
+ end Check_Overriding_Indicator;
+
--------------------------
-- Find_Concurrent_Spec --
--------------------------
with Exp_Disp; use Exp_Disp;
with Exp_Ch7; use Exp_Ch7;
with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
with Errout; use Errout;
with Hostparm; use Hostparm;
with Nlists; use Nlists;
elsif Ekind (T) = E_Anonymous_Access_Type
and then Is_Tagged_Type (Designated_Type (T))
- and then Ekind (Designated_Type (T)) /= E_Incomplete_Type
then
- if Is_First_Subtype (Designated_Type (T)) then
- Tagged_Type := Designated_Type (T);
- else
- Tagged_Type := Base_Type (Designated_Type (T));
+ if Ekind (Designated_Type (T)) /= E_Incomplete_Type then
+ if Is_First_Subtype (Designated_Type (T)) then
+ Tagged_Type := Designated_Type (T);
+ else
+ Tagged_Type := Base_Type (Designated_Type (T));
+ end if;
+
+ -- Ada 2005 (AI-50217)
+
+ elsif From_With_Type (Designated_Type (T))
+ and then Present (Non_Limited_View (Designated_Type (T)))
+ then
+ if Is_First_Subtype (Non_Limited_View (Designated_Type (T))) then
+ Tagged_Type := Non_Limited_View (Designated_Type (T));
+ else
+ Tagged_Type := Base_Type (Non_Limited_View
+ (Designated_Type (T)));
+ end if;
end if;
end if;
Set_Is_Dispatching_Operation (Subp, False);
Tagged_Type := Find_Dispatching_Type (Subp);
+ -- Ada 2005 (AI-345)
+
+ if Ada_Version = Ada_05
+ and then Present (Tagged_Type)
+ and then Is_Concurrent_Type (Tagged_Type)
+ and then not Is_Empty_Elmt_List
+ (Abstract_Interfaces
+ (Corresponding_Record_Type (Tagged_Type)))
+ then
+ Tagged_Type := Corresponding_Record_Type (Tagged_Type);
+ end if;
+
-- If Subp is derived from a dispatching operation then it should
-- always be treated as dispatching. In this case various checks
-- below will be bypassed. Makes sure that late declarations for
elsif Present (Old_Subp)
and then Is_Dispatching_Operation (Old_Subp)
then
- if Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body
- and then Comes_From_Source (Subp)
+ if Comes_From_Source (Subp)
+ and then
+ (Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body
+ or else Nkind (Unit_Declaration_Node (Subp)) in N_Body_Stub)
then
declare
Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
Set_Alias (Old_Subp, Alias (Subp));
-- The derived subprogram should inherit the abstractness
-
-- of the parent subprogram (except in the case of a function
-- returning the type). This sets the abstractness properly
-- for cases where a private extension may have inherited
New_Op : Entity_Id)
is
Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
+ Elmt : Elmt_Id;
+ Found : Boolean;
+
+ function Is_Interface_Subprogram (Op : Entity_Id) return Boolean;
+ -- Comment requjired ???
+
+ -----------------------------
+ -- Is_Interface_Subprogram --
+ -----------------------------
+
+ function Is_Interface_Subprogram (Op : Entity_Id) return Boolean is
+ Aux : Entity_Id;
+
+ begin
+ Aux := Op;
+ while Present (Alias (Aux))
+ and then Present (DTC_Entity (Alias (Aux)))
+ loop
+ if Is_Interface (Scope (DTC_Entity (Alias (Aux)))) then
+ return True;
+ end if;
+ Aux := Alias (Aux);
+ end loop;
+
+ return False;
+ end Is_Interface_Subprogram;
+
+ -- Start of processing for Override_Dispatching_Operation
begin
-- Patch the primitive operation list
return;
end if;
- Replace_Elmt (Op_Elmt, New_Op);
+ -- Ada 2005 (AI-251): Do not replace subprograms corresponding to
+ -- abstract interfaces. They will be used later to generate the
+ -- corresponding thunks to initialize the Vtable (see subprogram
+ -- Freeze_Subprogram)
+
+ if Is_Interface_Subprogram (Prev_Op) then
+ Set_DT_Position (Prev_Op, DT_Position (Alias (Prev_Op)));
+ Set_Is_Abstract (Prev_Op, Is_Abstract (New_Op));
+ Set_Is_Overriding_Operation (Prev_Op);
+ Set_Abstract_Interface_Alias (Prev_Op, Alias (Prev_Op));
+ Set_Alias (Prev_Op, New_Op);
+ Set_Is_Internal (Prev_Op);
+
+ -- Override predefined primitive operations
+
+ if Is_Predefined_Dispatching_Operation (Prev_Op) then
+ Replace_Elmt (Op_Elmt, New_Op);
+ return;
+ end if;
+
+ -- Check if this primitive operation was previously added for another
+ -- interface.
+
+ Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
+ Found := False;
+ while Present (Elmt) loop
+ if Node (Elmt) = New_Op then
+ Found := True;
+ exit;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ if not Found then
+ Append_Elmt (New_Op, Primitive_Operations (Tagged_Type));
+ -- Replace_Elmt (Op_Elmt, New_Op); -- why is this commented out???
+ end if;
+ return;
+
+ else
+ Replace_Elmt (Op_Elmt, New_Op);
+ end if;
if (not Is_Package (Current_Scope))
or else not In_Private_Part (Current_Scope)
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Einfo; use Einfo;
with Errout; use Errout;
with Expander; use Expander;
+with Exp_Disp; use Exp_Disp;
with Exp_Ch7; use Exp_Ch7;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
procedure Check_Direct_Boolean_Op (N : Node_Id) is
begin
- if Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean then
+ if Nkind (N) in N_Op
+ and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean
+ then
Check_Restriction (No_Direct_Boolean_Operators, N);
end if;
end Check_Direct_Boolean_Op;
if Paren_Count (N) > 0 then
Error_Msg_N
("discriminant in constraint must appear alone", N);
+
+ elsif Nkind (N) = N_Expanded_Name
+ and then Comes_From_Source (N)
+ then
+ Error_Msg_N
+ ("discriminant must appear alone as a direct name", N);
end if;
return;
if Typ = Any_Real
and then Expr_Type = Any_Fixed
then
- Error_Msg_N ("Illegal context for mixed mode operation", N);
+ Error_Msg_N ("illegal context for mixed mode operation", N);
Set_Etype (N, Universal_Real);
Ctx_Type := Universal_Real;
end if;
if Has_Aliased_Components (Etype (Expression (A)))
/= Has_Aliased_Components (Etype (F))
then
- Error_Msg_N
- ("both component types in a view conversion must be"
- & " aliased, or neither", A);
+ if Ada_Version < Ada_05 then
+ Error_Msg_N
+ ("both component types in a view conversion must be"
+ & " aliased, or neither", A);
+
+ -- Ada 2005: rule is relaxed (see AI-363)
+
+ elsif Has_Aliased_Components (Etype (F))
+ and then
+ not Has_Aliased_Components (Etype (Expression (A)))
+ then
+ Error_Msg_N
+ ("view conversion operand must have aliased " &
+ "components", N);
+ Error_Msg_N
+ ("\since target type has aliased components", N);
+ end if;
elsif not Same_Ancestor (Etype (F), Etype (Expression (A)))
and then
or else Is_By_Reference_Type (Etype (Expression (A))))
then
Error_Msg_N
- ("view conversion between unrelated by_reference "
- & "array types not allowed (\A\I-00246)?", A);
+ ("view conversion between unrelated by reference " &
+ "array types not allowed (\'A'I-00246)", A);
end if;
end if;
or else Is_Limited_Type (Etype (Expression (A))))
then
Error_Msg_N
- ("Conversion between unrelated limited array types "
- & "not allowed (\A\I-00246)?", A);
-
- -- Disable explanation (which produces additional errors)
- -- until AI is approved and warning becomes an error.
+ ("conversion between unrelated limited array types " &
+ "not allowed (\A\I-00246)", A);
- -- if Is_Limited_Type (Etype (F)) then
- -- Explain_Limited_Type (Etype (F), A);
- -- end if;
+ if Is_Limited_Type (Etype (F)) then
+ Explain_Limited_Type (Etype (F), A);
+ end if;
- -- if Is_Limited_Type (Etype (Expression (A))) then
- -- Explain_Limited_Type (Etype (Expression (A)), A);
- -- end if;
+ if Is_Limited_Type (Etype (Expression (A))) then
+ Explain_Limited_Type (Etype (Expression (A)), A);
+ end if;
end if;
Resolve (A, Etype (F));
Check_Unset_Reference (A);
end if;
- -- In Ada 83 we cannot pass an OUT parameter as an IN
- -- or IN OUT actual to a nested call, since this is a
- -- case of reading an out parameter, which is not allowed.
+ -- In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT
+ -- actual to a nested call, since this is case of reading an
+ -- out parameter, which is not allowed.
if Ada_Version = Ada_83
and then Is_Entity_Name (A)
end if;
end if;
+ -- Ada 2005 (AI-344): A class-wide allocator requires an accessibility
+ -- check that the level of the type of the created object is not deeper
+ -- than the level of the allocator's access type, since extensions can
+ -- now occur at deeper levels than their ancestor types. This is a
+ -- static accessibility level check; a run-time check is also needed in
+ -- the case of an initialized allocator with a class-wide argument (see
+ -- Expand_Allocator_Expression).
+
+ if Ada_Version >= Ada_05
+ and then Is_Class_Wide_Type (Designated_Type (Typ))
+ then
+ declare
+ Exp_Typ : Entity_Id;
+
+ begin
+ if Nkind (E) = N_Qualified_Expression then
+ Exp_Typ := Etype (E);
+ elsif Nkind (E) = N_Subtype_Indication then
+ Exp_Typ := Entity (Subtype_Mark (Original_Node (E)));
+ else
+ Exp_Typ := Entity (E);
+ end if;
+
+ if Type_Access_Level (Exp_Typ) > Type_Access_Level (Typ) then
+ if In_Instance_Body then
+ Error_Msg_N ("?type in allocator has deeper level than" &
+ " designated class-wide type", E);
+ Error_Msg_N ("?Program_Error will be raised at run time", E);
+ Rewrite (N,
+ Make_Raise_Program_Error (Sloc (N),
+ Reason => PE_Accessibility_Check_Failed));
+ Set_Etype (N, Typ);
+ else
+ Error_Msg_N ("type in allocator has deeper level than" &
+ " designated class-wide type", E);
+ end if;
+ end if;
+ end;
+ end if;
+
-- Check for allocation from an empty storage pool
if No_Pool_Assigned (Typ) then
if Universal_Interpretation (N) = Universal_Integer then
-- A universal integer literal is resolved as standard integer
- -- except in the case of a fixed-point result, where we leave
- -- it as universal (to be handled by Exp_Fixd later on)
+ -- except in the case of a fixed-point result, where we leave it
+ -- as universal (to be handled by Exp_Fixd later on)
if Is_Fixed_Point_Type (T) then
Resolve (N, Universal_Integer);
Get_Next_Interp (Index, It);
end loop;
- -- Reanalyze the literal with the fixed type of the context.
- -- If context is Universal_Fixed, we are within a conversion,
- -- leave the literal as a universal real because there is no
- -- usable fixed type, and the target of the conversion plays
- -- no role in the resolution.
+ -- Reanalyze the literal with the fixed type of the context. If
+ -- context is Universal_Fixed, we are within a conversion, leave
+ -- the literal as a universal real because there is no usable
+ -- fixed type, and the target of the conversion plays no role in
+ -- the resolution.
declare
Op2 : Node_Id;
W : Node_Id;
begin
- -- The context imposes a unique interpretation with type Typ on
- -- a procedure or function call. Find the entity of the subprogram
- -- that yields the expected type, and propagate the corresponding
- -- formal constraints on the actuals. The caller has established
- -- that an interpretation exists, and emitted an error if not unique.
+ -- The context imposes a unique interpretation with type Typ on a
+ -- procedure or function call. Find the entity of the subprogram that
+ -- yields the expected type, and propagate the corresponding formal
+ -- constraints on the actuals. The caller has established that an
+ -- interpretation exists, and emitted an error if not unique.
-- First deal with the case of a call to an access-to-subprogram,
-- dereference made explicit in Analyze_Call.
Nam := Etype (Subp);
else
- -- Find the interpretation whose type (a subprogram type)
- -- has a return type that is compatible with the context.
- -- Analysis of the node has established that one exists.
+ -- Find the interpretation whose type (a subprogram type) has a
+ -- return type that is compatible with the context. Analysis of
+ -- the node has established that one exists.
Get_First_Interp (Subp, I, It);
Nam := Empty;
Resolve (Subp, Nam);
end if;
- -- For an indirect call, we always invalidate checks, since we
- -- do not know whether the subprogram is local or global. Yes
- -- we could do better here, e.g. by knowing that there are no
- -- local subprograms, but it does not seem worth the effort.
- -- Similarly, we kill al knowledge of current constant values.
+ -- For an indirect call, we always invalidate checks, since we do not
+ -- know whether the subprogram is local or global. Yes we could do
+ -- better here, e.g. by knowing that there are no local subprograms,
+ -- but it does not seem worth the effort. Similarly, we kill al
+ -- knowledge of current constant values.
Kill_Current_Values;
- -- If this is a procedure call which is really an entry call, do
- -- the conversion of the procedure call to an entry call. Protected
- -- operations use the same circuitry because the name in the call
- -- can be an arbitrary expression with special resolution rules.
+ -- If this is a procedure call which is really an entry call, do the
+ -- conversion of the procedure call to an entry call. Protected
+ -- operations use the same circuitry because the name in the call can be
+ -- an arbitrary expression with special resolution rules.
elsif Nkind (Subp) = N_Selected_Component
or else Nkind (Subp) = N_Indexed_Component
Error_Msg_N ("cannot call thread body directly", N);
end if;
- -- If the subprogram is not global, then kill all checks. This is
- -- a bit conservative, since in many cases we could do better, but
- -- it is not worth the effort. Similarly, we kill constant values.
- -- However we do not need to do this for internal entities (unless
- -- they are inherited user-defined subprograms), since they are not
- -- in the business of molesting global values.
+ -- If the subprogram is not global, then kill all checks. This is a bit
+ -- conservative, since in many cases we could do better, but it is not
+ -- worth the effort. Similarly, we kill constant values. However we do
+ -- not need to do this for internal entities (unless they are inherited
+ -- user-defined subprograms), since they are not in the business of
+ -- molesting global values.
if not Is_Library_Level_Entity (Nam)
and then (Comes_From_Source (Nam)
Kill_Current_Values;
end if;
- -- Check for call to obsolescent subprogram
+ -- Deal with call to obsolescent subprogram. Note that we always allow
+ -- such calls in the compiler itself and the run-time, since we assume
+ -- that we know what we are doing in such cases. For example, the calls
+ -- in Ada.Characters.Handling to its own obsolescent subprograms are
+ -- just fine.
- if Warn_On_Obsolescent_Feature
- and then Is_Subprogram (Nam)
- and then Is_Obsolescent (Nam)
- then
- Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam);
+ if Is_Obsolescent (Nam) and then not GNAT_Mode then
+ Check_Restriction (No_Obsolescent_Features, N);
- -- Output additional warning if present
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam);
- W := Obsolescent_Warning (Nam);
+ -- Output additional warning if present
- if Present (W) then
- Name_Buffer (1) := '|';
- Name_Buffer (2) := '?';
- Name_Len := 2;
+ W := Obsolescent_Warning (Nam);
- -- Add characters to message, protecting all of them
+ if Present (W) then
+ Name_Buffer (1) := '|';
+ Name_Buffer (2) := '?';
+ Name_Len := 2;
- for J in 1 .. String_Length (Strval (W)) loop
- Add_Char_To_Name_Buffer (''');
- Add_Char_To_Name_Buffer
- (Get_Character (Get_String_Char (Strval (W), J)));
- end loop;
+ -- Add characters to message, and output message
+
+ for J in 1 .. String_Length (Strval (W)) loop
+ Add_Char_To_Name_Buffer (''');
+ Add_Char_To_Name_Buffer
+ (Get_Character (Get_String_Char (Strval (W), J)));
+ end loop;
- Error_Msg_N (Name_Buffer (1 .. Name_Len), N);
+ Error_Msg_N (Name_Buffer (1 .. Name_Len), N);
+ end if;
end if;
end if;
- -- Check that a procedure call does not occur in the context
- -- of the entry call statement of a conditional or timed
- -- entry call. Note that the case of a call to a subprogram
- -- renaming of an entry will also be rejected. The test
- -- for N not being an N_Entry_Call_Statement is defensive,
- -- covering the possibility that the processing of entry
- -- calls might reach this point due to later modifications
- -- of the code above.
+ -- Check that a procedure call does not occur in the context of the
+ -- entry call statement of a conditional or timed entry call. Note that
+ -- the case of a call to a subprogram renaming of an entry will also be
+ -- rejected. The test for N not being an N_Entry_Call_Statement is
+ -- defensive, covering the possibility that the processing of entry
+ -- calls might reach this point due to later modifications of the code
+ -- above.
if Nkind (Parent (N)) = N_Entry_Call_Alternative
and then Nkind (N) /= N_Entry_Call_Statement
Error_Msg_N ("\cannot call operation that may modify it", N);
end if;
- -- Freeze the subprogram name if not in default expression. Note
- -- that we freeze procedure calls as well as function calls.
- -- Procedure calls are not frozen according to the rules (RM
- -- 13.14(14)) because it is impossible to have a procedure call to
- -- a non-frozen procedure in pure Ada, but in the code that we
- -- generate in the expander, this rule needs extending because we
- -- can generate procedure calls that need freezing.
+ -- Freeze the subprogram name if not in default expression. Note that we
+ -- freeze procedure calls as well as function calls. Procedure calls are
+ -- not frozen according to the rules (RM 13.14(14)) because it is
+ -- impossible to have a procedure call to a non-frozen procedure in pure
+ -- Ada, but in the code that we generate in the expander, this rule
+ -- needs extending because we can generate procedure calls that need
+ -- freezing.
if Is_Entity_Name (Subp) and then not In_Default_Expression then
Freeze_Expression (Subp);
end if;
- -- For a predefined operator, the type of the result is the type
- -- imposed by context, except for a predefined operation on universal
- -- fixed. Otherwise The type of the call is the type returned by the
- -- subprogram being called.
+ -- For a predefined operator, the type of the result is the type imposed
+ -- by context, except for a predefined operation on universal fixed.
+ -- Otherwise The type of the call is the type returned by the subprogram
+ -- being called.
if Is_Predefined_Op (Nam) then
if Etype (N) /= Universal_Fixed then
Set_Etype (N, Typ);
end if;
- -- If the subprogram returns an array type, and the context
- -- requires the component type of that array type, the node is
- -- really an indexing of the parameterless call. Resolve as such.
- -- A pathological case occurs when the type of the component is
- -- an access to the array type. In this case the call is truly
- -- ambiguous.
+ -- If the subprogram returns an array type, and the context requires the
+ -- component type of that array type, the node is really an indexing of
+ -- the parameterless call. Resolve as such. A pathological case occurs
+ -- when the type of the component is an access to the array type. In
+ -- this case the call is truly ambiguous.
elsif Needs_No_Actuals (Nam)
and then
Set_Is_Overloaded (Subp, False);
Set_Is_Overloaded (N, False);
- -- If we are calling the current subprogram from immediately within
- -- its body, then that is the case where we can sometimes detect
- -- cases of infinite recursion statically. Do not try this in case
- -- restriction No_Recursion is in effect anyway.
+ -- If we are calling the current subprogram from immediately within its
+ -- body, then that is the case where we can sometimes detect cases of
+ -- infinite recursion statically. Do not try this in case restriction
+ -- No_Recursion is in effect anyway.
Scop := Current_Scope;
T : Entity_Id;
begin
- Check_Direct_Boolean_Op (N);
-
-- If this is an intrinsic operation which is not predefined, use
-- the types of its declared arguments to resolve the possibly
-- overloaded operands. Otherwise the operands are unambiguous and
Check_Unset_Reference (R);
Generate_Operator_Reference (N, T);
Eval_Relational_Op (N);
+ Check_Direct_Boolean_Op (N);
end if;
end if;
end Resolve_Comparison_Op;
null;
else
Error_Msg_N
- ("Invalid use of subtype mark in expression or call", N);
+ ("invalid use of subtype mark in expression or call", N);
end if;
-- Check discriminant use if entity is discriminant in current scope,
elsif Ekind (Scope (Nam)) = E_Task_Type
and then not In_Open_Scopes (Scope (Nam))
then
- Error_Msg_N ("Task has no entry with this name", Entry_Name);
+ Error_Msg_N ("task has no entry with this name", Entry_Name);
end if;
end if;
-- Start of processing for Resolve_Equality_Op
begin
- Check_Direct_Boolean_Op (N);
-
Set_Etype (N, Base_Type (Typ));
Generate_Reference (T, N, ' ');
then
Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
end if;
+
+ Check_Direct_Boolean_Op (N);
end if;
end Resolve_Equality_Op;
It : Interp;
begin
- -- Now that we know the type, check that this is not a
- -- dereference of an uncompleted type. Note that this
- -- is not entirely correct, because dereferences of
- -- private types are legal in default expressions.
- -- This consideration also applies to similar checks
- -- for allocators, qualified expressions, and type
- -- conversions. ???
-
- Check_Fully_Declared (Typ, N);
+ -- Now that we know the type, check that this is not dereference of an
+ -- uncompleted type. Note that this is not entirely correct, because
+ -- dereferences of private types are legal in default expressions. This
+ -- exception is taken care of in Check_Fully_Declared.
+
+ -- This consideration also applies to similar checks for allocators,
+ -- qualified expressions, and type conversions.
+
+ -- An additional exception concerns other per-object expressions that
+ -- are not directly related to component declarations, in particular
+ -- representation pragmas for tasks. These will be per-object
+ -- expressions if they depend on discriminants or some global entity.
+ -- If the task has access discriminants, the designated type may be
+ -- incomplete at the point the expression is resolved. This resolution
+ -- takes place within the body of the initialization procedure, where
+ -- the discriminant is replaced by its discriminal.
+
+ if Is_Entity_Name (Prefix (N))
+ and then Ekind (Entity (Prefix (N))) = E_In_Parameter
+ then
+ null;
+ else
+ Check_Fully_Declared (Typ, N);
+ end if;
if Is_Overloaded (P) then
- -- Use the context type to select the prefix that has the
- -- correct designated type.
+ -- Use the context type to select the prefix that has the correct
+ -- designated type.
Get_First_Interp (P, I, It);
while Present (It.Typ) loop
if Present (It.Typ) then
Resolve (P, It.Typ);
else
- -- If no interpretation covers the designated type of the
- -- prefix, this is the pathological case where not all
- -- implementations of the prefix allow the interpretation
- -- of the node as a call. Now that the expected type is known,
- -- Remove other interpretations from prefix, rewrite it as
- -- a call, and resolve again, so that the proper call node
- -- is generated.
+ -- If no interpretation covers the designated type of the prefix,
+ -- this is the pathological case where not all implementations of
+ -- the prefix allow the interpretation of the node as a call. Now
+ -- that the expected type is known, Remove other interpretations
+ -- from prefix, rewrite it as a call, and resolve again, so that
+ -- the proper call node is generated.
Get_First_Interp (P, I, It);
while Present (It.Typ) loop
Apply_Access_Check (N);
end if;
- -- If the designated type is a packed unconstrained array type,
- -- and the explicit dereference is not in the context of an
- -- attribute reference, then we must compute and set the actual
- -- subtype, since it is needed by Gigi. The reason we exclude
- -- the attribute case is that this is handled fine by Gigi, and
- -- in fact we use such attributes to build the actual subtype.
- -- We also exclude generated code (which builds actual subtypes
- -- directly if they are needed).
+ -- If the designated type is a packed unconstrained array type, and the
+ -- explicit dereference is not in the context of an attribute reference,
+ -- then we must compute and set the actual subtype, since it is needed
+ -- by Gigi. The reason we exclude the attribute case is that this is
+ -- handled fine by Gigi, and in fact we use such attributes to build the
+ -- actual subtype. We also exclude generated code (which builds actual
+ -- subtypes directly if they are needed).
if Is_Array_Type (Etype (N))
and then Is_Packed (Etype (N))
Set_Etype (N, Get_Actual_Subtype (N));
end if;
- -- Note: there is no Eval processing required for an explicit
- -- deference, because the type is known to be an allocators, and
- -- allocator expressions can never be static.
+ -- Note: there is no Eval processing required for an explicit deference,
+ -- because the type is known to be an allocators, and allocator
+ -- expressions can never be static.
end Resolve_Explicit_Dereference;
begin
if Is_Overloaded (Name) then
- -- Use the context type to select the prefix that yields the
- -- correct component type.
+ -- Use the context type to select the prefix that yields the correct
+ -- component type.
declare
I : Interp_Index;
begin
Get_First_Interp (P, I, It);
+ -- the task has access discriminants, the designated type may be
+ -- incomplete at the point the expression is resolved. This resolution
+ -- takes place within the body of the initialization proc
while Present (It.Typ) loop
if (Is_Array_Type (It.Typ)
Index := First_Index (Array_Type);
Expr := First (Expressions (N));
- -- The prefix may have resolved to a string literal, in which case
- -- its etype has a special representation. This is only possible
- -- currently if the prefix is a static concatenation, written in
- -- functional notation.
+ -- The prefix may have resolved to a string literal, in which case its
+ -- etype has a special representation. This is only possible currently
+ -- if the prefix is a static concatenation, written in functional
+ -- notation.
if Ekind (Array_Type) = E_String_Literal_Subtype then
Resolve (Expr, Standard_Positive);
Set_Entity (N, Op);
Set_Is_Overloaded (N, False);
- -- If the operand type is private, rewrite with suitable
- -- conversions on the operands and the result, to expose
- -- the proper underlying numeric type.
+ -- If the operand type is private, rewrite with suitable conversions on
+ -- the operands and the result, to expose the proper underlying numeric
+ -- type.
if Is_Private_Type (Typ) then
Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd (N));
B_Typ : Entity_Id;
begin
- Check_Direct_Boolean_Op (N);
-
- -- Predefined operations on scalar types yield the base type. On
- -- the other hand, logical operations on arrays yield the type of
- -- the arguments (and the context).
+ -- Predefined operations on scalar types yield the base type. On the
+ -- other hand, logical operations on arrays yield the type of the
+ -- arguments (and the context).
if Is_Array_Type (Typ) then
B_Typ := Typ;
Set_Etype (N, B_Typ);
Generate_Operator_Reference (N, B_Typ);
Eval_Logical_Op (N);
+ Check_Direct_Boolean_Op (N);
end Resolve_Logical_Op;
---------------------------
procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
begin
- -- Handle restriction against anonymous null access values
- -- This restriction can be turned off using -gnatdh.
+ -- Handle restriction against anonymous null access values This
+ -- restriction can be turned off using -gnatdh.
-- Ada 2005 (AI-231): Remove restriction
Explain_Limited_Type (Btyp, N);
end if;
- -- If the operands are themselves concatenations, resolve them as
- -- such directly. This removes several layers of recursion and allows
- -- GNAT to handle larger multiple concatenations.
+ -- If the operands are themselves concatenations, resolve them as such
+ -- directly. This removes several layers of recursion and allows GNAT to
+ -- handle larger multiple concatenations.
if Nkind (Op1) = N_Op_Concat
and then not Is_Array_Type (Component_Type (Typ))
begin
-- Catch attempts to do fixed-point exponentation with universal
- -- operands, which is a case where the illegality is not caught
- -- during normal operator analysis.
+ -- operands, which is a case where the illegality is not caught during
+ -- normal operator analysis.
if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then
Error_Msg_N ("exponentiation not available for fixed point", N);
-- Start of processing for Resolve_Op_Not
begin
- -- Predefined operations on scalar types yield the base type. On
- -- the other hand, logical operations on arrays yield the type of
- -- the arguments (and the context).
+ -- Predefined operations on scalar types yield the base type. On the
+ -- other hand, logical operations on arrays yield the type of the
+ -- arguments (and the context).
if Is_Array_Type (Typ) then
B_Typ := Typ;
Check_Unset_Reference (H);
-- We have to check the bounds for being within the base range as
- -- required for a non-static context. Normally this is automatic
- -- and done as part of evaluating expressions, but the N_Range
- -- node is an exception, since in GNAT we consider this node to
- -- be a subexpression, even though in Ada it is not. The circuit
- -- in Sem_Eval could check for this, but that would put the test
- -- on the main evaluation path for expressions.
+ -- required for a non-static context. Normally this is automatic and
+ -- done as part of evaluating expressions, but the N_Range node is an
+ -- exception, since in GNAT we consider this node to be a subexpression,
+ -- even though in Ada it is not. The circuit in Sem_Eval could check for
+ -- this, but that would put the test on the main evaluation path for
+ -- expressions.
Check_Non_Static_Context (L);
Check_Non_Static_Context (H);
Realval => Small_Value (Typ) * Cint));
Set_Is_Static_Expression (N, Stat);
-
-
end if;
-- In all cases, set the corresponding integer field
-----------------------------
procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is
- Target_Type : constant Entity_Id := Etype (N);
- Conv_OK : constant Boolean := Conversion_OK (N);
+ Conv_OK : constant Boolean := Conversion_OK (N);
+ Target_Type : Entity_Id := Etype (N);
Operand : Node_Id;
Opnd_Type : Entity_Id;
Rop : Node_Id;
("?useless conversion, & has this type", N, Entity (Orig_N));
end if;
end if;
+
+ -- Ada 2005 (AI-251): Handle conversions to abstract interface types
+
+ if Ada_Version >= Ada_05 then
+ if Is_Access_Type (Target_Type) then
+ Target_Type := Directly_Designated_Type (Target_Type);
+ end if;
+
+ if Is_Class_Wide_Type (Target_Type) then
+ Target_Type := Etype (Target_Type);
+ end if;
+
+ if Is_Interface (Target_Type) then
+ if Is_Class_Wide_Type (Opnd_Type) then
+ Opnd_Type := Etype (Opnd_Type);
+ end if;
+
+ if not Interface_Present_In_Ancestor
+ (Typ => Opnd_Type,
+ Iface => Target_Type)
+ then
+ if Nkind (Operand) = N_Attribute_Reference then
+ Error_Msg_Name_1 := Chars (Prefix (Operand));
+ else
+ Error_Msg_Name_1 := Chars (Operand);
+ end if;
+
+ Error_Msg_Name_2 := Chars (Target_Type);
+ Error_Msg_NE
+ ("(Ada 2005) % does not implement interface %",
+ Operand, Target_Type);
+
+ else
+ Expand_Interface_Conversion (N);
+ end if;
+ end if;
+ end if;
end Resolve_Type_Conversion;
----------------------
return
Conversion_Check (False,
"downward conversion of tagged objects not allowed");
+
+ -- Ada 2005 (AI-251): The conversion of a tagged type to an
+ -- abstract interface type is always valid
+
+ elsif Is_Interface (Target_Type) then
+ return True;
+
else
Error_Msg_NE
("invalid tagged conversion, not compatible with}",
return True;
+ -- Ada 2005 (AI-251)
+
+ elsif (Ekind (Target_Type) = E_General_Access_Type
+ or else Ekind (Target_Type) = E_Anonymous_Access_Type)
+ and then Is_Interface (Directly_Designated_Type (Target_Type))
+ then
+ -- Check the static accessibility rule of 4.6(17). Note that the
+ -- check is not enforced when within an instance body, since the RM
+ -- requires such cases to be caught at run time.
+
+ if Ekind (Target_Type) /= E_Anonymous_Access_Type then
+ if Type_Access_Level (Opnd_Type) >
+ Type_Access_Level (Target_Type)
+ then
+ -- In an instance, this is a run-time check, but one we know
+ -- will fail, so generate an appropriate warning. The raise
+ -- will be generated by Expand_N_Type_Conversion.
+
+ if In_Instance_Body then
+ Error_Msg_N
+ ("?cannot convert local pointer to non-local access type",
+ Operand);
+ Error_Msg_N
+ ("?Program_Error will be raised at run time", Operand);
+
+ else
+ Error_Msg_N
+ ("cannot convert local pointer to non-local access type",
+ Operand);
+ return False;
+ end if;
+
+ -- Special accessibility checks are needed in the case of access
+ -- discriminants declared for a limited type.
+
+ elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
+ and then not Is_Local_Anonymous_Access (Opnd_Type)
+ then
+ -- When the operand is a selected access discriminant the check
+ -- needs to be made against the level of the object denoted by
+ -- the prefix of the selected name. (Object_Access_Level
+ -- handles checking the prefix of the operand for this case.)
+
+ if Nkind (Operand) = N_Selected_Component
+ and then Object_Access_Level (Operand)
+ > Type_Access_Level (Target_Type)
+ then
+ -- In an instance, this is a run-time check, but one we
+ -- know will fail, so generate an appropriate warning.
+ -- The raise will be generated by Expand_N_Type_Conversion.
+
+ if In_Instance_Body then
+ Error_Msg_N
+ ("?cannot convert access discriminant to non-local" &
+ " access type", Operand);
+ Error_Msg_N
+ ("?Program_Error will be raised at run time", Operand);
+
+ else
+ Error_Msg_N
+ ("cannot convert access discriminant to non-local" &
+ " access type", Operand);
+ return False;
+ end if;
+ end if;
+
+ -- The case of a reference to an access discriminant from
+ -- within a limited type declaration (which will appear as
+ -- a discriminal) is always illegal because the level of the
+ -- discriminant is considered to be deeper than any (namable)
+ -- access type.
+
+ if Is_Entity_Name (Operand)
+ and then not Is_Local_Anonymous_Access (Opnd_Type)
+ and then (Ekind (Entity (Operand)) = E_In_Parameter
+ or else Ekind (Entity (Operand)) = E_Constant)
+ and then Present (Discriminal_Link (Entity (Operand)))
+ then
+ Error_Msg_N
+ ("discriminant has deeper accessibility level than target",
+ Operand);
+ return False;
+ end if;
+ end if;
+ end if;
+
+ return True;
+
elsif (Ekind (Target_Type) = E_General_Access_Type
or else Ekind (Target_Type) = E_Anonymous_Access_Type)
and then
return False;
end if;
- -- Check the static accessibility rule of 4.6(17). Note that
- -- the check is not enforced when within an instance body, since
- -- the RM requires such cases to be caught at run time.
+ -- Check the static accessibility rule of 4.6(17). Note that the
+ -- check is not enforced when within an instance body, since the RM
+ -- requires such cases to be caught at run time.
- if Ekind (Target_Type) /= E_Anonymous_Access_Type then
+ if Ekind (Target_Type) /= E_Anonymous_Access_Type
+ or else Is_Local_Anonymous_Access (Target_Type)
+ then
if Type_Access_Level (Opnd_Type)
> Type_Access_Level (Target_Type)
then
return False;
end if;
- elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type then
+ -- Special accessibility checks are needed in the case of access
+ -- discriminants declared for a limited type.
+
+ elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
+ and then not Is_Local_Anonymous_Access (Opnd_Type)
+ then
- -- When the operand is a selected access discriminant
- -- the check needs to be made against the level of the
- -- object denoted by the prefix of the selected name.
- -- (Object_Access_Level handles checking the prefix
- -- of the operand for this case.)
+ -- When the operand is a selected access discriminant the check
+ -- needs to be made against the level of the object denoted by
+ -- the prefix of the selected name. (Object_Access_Level
+ -- handles checking the prefix of the operand for this case.)
if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand)
end if;
end if;
- -- The case of a reference to an access discriminant
- -- from within a type declaration (which will appear
- -- as a discriminal) is always illegal because the
- -- level of the discriminant is considered to be
- -- deeper than any (namable) access type.
+ -- The case of a reference to an access discriminant from
+ -- within a limited type declaration (which will appear as
+ -- a discriminal) is always illegal because the level of the
+ -- discriminant is considered to be deeper than any (namable)
+ -- access type.
if Is_Entity_Name (Operand)
and then (Ekind (Entity (Operand)) = E_In_Parameter
with Alloc;
with Debug; use Debug;
with Einfo; use Einfo;
+with Elists; use Elists;
with Errout; use Errout;
with Lib; use Lib;
with Opt; use Opt;
end if;
end loop;
- -- On exit, we know that current homograph is not hidden.
+ -- On exit, we know that current homograph is not hidden
Add_One_Interp (N, H, Etype (H));
then
return True;
+ -- Ada 2005 (AI-345): A class-wide abstract interface type T1 covers a
+ -- task_type or protected_type implementing T1
+
+ elsif Ada_Version >= Ada_05
+ and then Is_Class_Wide_Type (T1)
+ and then Is_Interface (Etype (T1))
+ and then Is_Concurrent_Type (T2)
+ and then Interface_Present_In_Ancestor (
+ Typ => Corresponding_Record_Type (Base_Type (T2)),
+ Iface => Etype (T1))
+ then
+ return True;
+
+ -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
+ -- object T2 implementing T1
+
+ elsif Ada_Version >= Ada_05
+ and then Is_Class_Wide_Type (T1)
+ and then Is_Interface (Etype (T1))
+ and then Is_Tagged_Type (T2)
+ then
+ if Interface_Present_In_Ancestor (Typ => T2,
+ Iface => Etype (T1))
+ then
+ return True;
+
+ elsif Present (Abstract_Interfaces (T2)) then
+
+ -- Ada 2005 (AI-251): A class-wide abstract interface type T1
+ -- covers an object T2 that implements a direct derivation of T1.
+
+ declare
+ E : Elmt_Id := First_Elmt (Abstract_Interfaces (T2));
+ begin
+ while Present (E) loop
+ if Is_Ancestor (Etype (T1), Node (E)) then
+ return True;
+ end if;
+
+ Next_Elmt (E);
+ end loop;
+ end;
+
+ -- We should also check the case in which T1 is an ancestor of
+ -- some implemented interface???
+
+ return False;
+
+ else
+ return False;
+ end if;
+
-- In a dispatching call the actual may be class-wide
elsif Is_Class_Wide_Type (T2)
then
return
Covers (Typ, Etype (N))
+
+ -- Ada 2005 (AI-345)
+
+ or else
+ (Is_Concurrent_Type (Etype (N))
+ and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
+
or else
(not Is_Tagged_Type (Typ)
and then Ekind (Typ) /= E_Anonymous_Access_Type
and then
(Scope (It.Nam) /= Standard_Standard
or else not Is_Invisible_Operator (N, Base_Type (Typ))))
+
+ -- Ada 2005 (AI-345)
+
+ or else
+ (Is_Concurrent_Type (It.Typ)
+ and then Covers (Typ, Corresponding_Record_Type
+ (Etype (It.Typ))))
+
or else (not Is_Tagged_Type (Typ)
and then Ekind (Typ) /= E_Anonymous_Access_Type
and then Covers (It.Typ, Typ))
Headers := (others => No_Entry);
end Init_Interp_Tables;
+ -----------------------------------
+ -- Interface_Present_In_Ancestor --
+ -----------------------------------
+
+ function Interface_Present_In_Ancestor
+ (Typ : Entity_Id;
+ Iface : Entity_Id) return Boolean
+ is
+ AI : Entity_Id;
+ E : Entity_Id;
+ Elmt : Elmt_Id;
+
+ begin
+ if Is_Access_Type (Typ) then
+ E := Etype (Directly_Designated_Type (Typ));
+ else
+ E := Typ;
+ end if;
+
+ if Is_Concurrent_Type (E) then
+ E := Corresponding_Record_Type (E);
+ end if;
+
+ if Is_Class_Wide_Type (E) then
+ E := Etype (E);
+ end if;
+
+ if E = Iface then
+ return True;
+ end if;
+
+ loop
+ if Present (Abstract_Interfaces (E))
+ and then Abstract_Interfaces (E) /= Empty_List_Or_Node -- ????
+ and then not Is_Empty_Elmt_List (Abstract_Interfaces (E))
+ then
+ Elmt := First_Elmt (Abstract_Interfaces (E));
+
+ while Present (Elmt) loop
+ AI := Node (Elmt);
+
+ if AI = Iface or else Is_Ancestor (Iface, AI) then
+ return True;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ exit when Etype (E) = E;
+
+ -- Check if the current type is a direct derivation of the
+ -- interface
+
+ if Etype (E) = Iface then
+ return True;
+ end if;
+
+ -- Climb to the immediate ancestor
+
+ E := Etype (E);
+ end loop;
+
+ return False;
+ end Interface_Present_In_Ancestor;
+
---------------------
-- Intersect_Types --
---------------------
elsif Nkind (Parent (L)) = N_Range then
Error_Msg_N ("incompatible types given in constraint", Parent (L));
+ -- Ada 2005 (AI-251): Complete the error notification
+
+ elsif Is_Class_Wide_Type (Etype (R))
+ and then Is_Interface (Etype (Class_Wide_Type (Etype (R))))
+ then
+ Error_Msg_Name_1 := Chars (L);
+ Error_Msg_Name_2 := Chars (Etype (Class_Wide_Type (Etype (R))));
+ Error_Msg_NE ("(Ada 2005) % does not implement interface %",
+ L, Etype (Class_Wide_Type (Etype (R))));
+
else
Error_Msg_N ("incompatible types", Parent (L));
end if;
Headers (Hash (N)) := Interp_Map.Last;
else
- -- Place node at end of chain, or locate its previous entry.
+ -- Place node at end of chain, or locate its previous entry
loop
if Interp_Map.Table (Map_Ptr).Node = N then
end if;
end loop;
- -- Chain the new node.
+ -- Chain the new node
Interp_Map.Increment_Last;
Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last;
elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
return T1;
+ -- ----------------------------------------------------------
-- Special cases for equality operators (all other predefined
-- operators can never apply to tagged types)
+ -- ----------------------------------------------------------
+
+ -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
+ -- interface
+
+ elsif Is_Class_Wide_Type (T1)
+ and then Is_Class_Wide_Type (T2)
+ and then Is_Interface (Etype (T2))
+ then
+ return T1;
+
+ -- Ada 2005 (AI-251): T1 is a concrete type that implements the
+ -- class-wide interface T2
+
+ elsif Is_Class_Wide_Type (T2)
+ and then Is_Interface (Etype (T2))
+ and then Interface_Present_In_Ancestor (Typ => T1,
+ Iface => Etype (T2))
+ then
+ return T1;
elsif Is_Class_Wide_Type (T1)
and then Is_Ancestor (Root_Type (T1), T2)
then
return T1;
- -- If none of the above cases applies, types are not compatible.
+ -- If none of the above cases applies, types are not compatible
else
return Any_Type;
-----------------------
-- In addition to booleans and arrays of booleans, we must include
- -- aggregates as valid boolean arguments, because in the first pass
- -- of resolution their components are not examined. If it turns out not
- -- to be an aggregate of booleans, this will be diagnosed in Resolve.
- -- Any_Composite must be checked for prior to the array type checks
- -- because Any_Composite does not have any associated indexes.
+ -- aggregates as valid boolean arguments, because in the first pass of
+ -- resolution their components are not examined. If it turns out not to be
+ -- an aggregate of booleans, this will be diagnosed in Resolve.
+ -- Any_Composite must be checked for prior to the array type checks because
+ -- Any_Composite does not have any associated indexes.
function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
begin
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2004 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- --
-- matches the signature of the operator, and is declared in an
-- open scope, or in the scope of the result type.
+ function Interface_Present_In_Ancestor
+ (Typ : Entity_Id;
+ Iface : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-251): Typ must be a tagged record type/subtype and Iface
+ -- must be an abstract interface type. This function is used to check if
+ -- some ancestor of Typ implements Iface.
+
function Intersect_Types (L, R : Node_Id) return Entity_Id;
-- Find the common interpretation to two analyzed nodes. If one of the
-- interpretations is universal, choose the non-universal one. If either
git://gcc.gnu.org / gcc.git / commitdiff