-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 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- --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
-with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch4; use Exp_Ch4;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+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;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Stand; use Stand;
-with Stringt; use Stringt;
with Snames; use Snames;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
-with Uintp; use Uintp;
with Validsw; use Validsw;
package body Exp_Ch3 is
function Build_Discriminant_Formals
(Rec_Id : Entity_Id;
- Use_Dl : Boolean)
- return List_Id;
+ Use_Dl : Boolean) return List_Id;
-- This function uses the discriminants of a type to build a list of
-- formal parameters, used in the following function. If the flag Use_Dl
-- is set, the list is built using the already defined discriminals
-- Build record initialization procedure. N is the type declaration
-- node, and Pe is the corresponding entity for the record type.
+ procedure Build_Slice_Assignment (Typ : Entity_Id);
+ -- Build assignment procedure for one-dimensional arrays of controlled
+ -- types. Other array and slice assignments are expanded in-line, but
+ -- the code expansion for controlled components (when control actions
+ -- are active) can lead to very large blocks that GCC3 handles poorly.
+
procedure Build_Variant_Record_Equality (Typ : Entity_Id);
-- Create An Equality function for the non-tagged variant record 'Typ'
-- and attach it to the TSS list
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
-- Check if E is defined in the RTL (in a child of Ada or System). Used
-- to avoid to bring in the overhead of _Input, _Output for tagged types.
- function Make_Eq_Case (Node : Node_Id; CL : Node_Id) return List_Id;
+ function Make_Eq_Case
+ (E : Entity_Id;
+ CL : Node_Id;
+ Discr : Entity_Id := Empty) return List_Id;
-- Building block for variant record equality. Defined to share the
-- code between the tagged and non-tagged case. Given a Component_List
-- node CL, it generates an 'if' followed by a 'case' statement that
-- compares all components of local temporaries named X and Y (that
- -- are declared as formals at some upper level). Node provides the
- -- Sloc to be used for the generated code.
+ -- are declared as formals at some upper level). E provides the Sloc to be
+ -- used for the generated code. Discr is used as the case statement switch
+ -- in the case of Unchecked_Union equality.
- function Make_Eq_If (Node : Node_Id; L : List_Id) return Node_Id;
+ function Make_Eq_If
+ (E : Entity_Id;
+ L : List_Id) return Node_Id;
-- Building block for variant record equality. Defined to share the
-- code between the tagged and non-tagged case. Given the list of
-- components (or discriminants) L, it generates a return statement
-- that compares all components of local temporaries named X and Y
- -- (that are declared as formals at some upper level). Node provides
- -- the Sloc to be used for the generated code.
+ -- (that are declared as formals at some upper level). E provides the Sloc
+ -- to be used for the generated code.
procedure Make_Predefined_Primitive_Specs
(Tag_Typ : Entity_Id;
Name : Name_Id;
Profile : List_Id;
Ret_Type : Entity_Id := Empty;
- For_Body : Boolean := False)
- return Node_Id;
+ For_Body : Boolean := False) return Node_Id;
-- This function generates the appropriate expansion for a predefined
-- primitive operation specified by its name, parameter profile and
-- return type (Empty means this is a procedure). If For_Body is false,
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : TSS_Name_Type;
- For_Body : Boolean := False)
- return Node_Id;
+ For_Body : Boolean := False) return Node_Id;
-- Specialized version of Predef_Spec_Or_Body that apply to read, write,
-- input and output attribute whose specs are constructed in Exp_Strm.
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : TSS_Name_Type;
- For_Body : Boolean := False)
- return Node_Id;
+ For_Body : Boolean := False) return Node_Id;
-- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
-- and _deep_finalize
function Predefined_Primitive_Bodies
(Tag_Typ : Entity_Id;
- Renamed_Eq : Node_Id)
- return List_Id;
+ Renamed_Eq : Node_Id) return List_Id;
-- Create the bodies of the predefined primitives that are described in
-- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
-- the defining unit name of the type's predefined equality as returned
-- Freeze entities of all predefined primitive operations. This is needed
-- because the bodies of these operations do not normally do any freezeing.
+ function Stream_Operation_OK
+ (Typ : Entity_Id;
+ Operation : TSS_Name_Type) return Boolean;
+ -- Check whether the named stream operation must be emitted for a given
+ -- type. The rules for inheritance of stream attributes by type extensions
+ -- are enforced by this function. Furthermore, various restrictions prevent
+ -- the generation of these operations, as a useful optimization or for
+ -- certification purposes.
+
--------------------------
-- Adjust_Discriminants --
--------------------------
return New_List (
Make_Assignment_Statement (Loc,
Name => Comp,
- Expression => Get_Simple_Init_Val (Comp_Type, Loc)));
+ Expression =>
+ Get_Simple_Init_Val
+ (Comp_Type, Loc, Component_Size (A_Type))));
else
return
-- apply in this case), and we must generate a procedure (even if it is
-- null) to satisfy the call in this case.
- -- Exception: do not build an array init_proc for a type whose root type
- -- is Standard.String or Standard.Wide_String, since there is no place
- -- to put the code, and in any case we handle initialization of such
- -- types (in the Initialize_Scalars case, that's the only time the issue
- -- arises) in a special manner anyway which does not need an init_proc.
+ -- Exception: do not build an array init_proc for a type whose root
+ -- type is Standard.String or Standard.Wide_[Wide_]String, since there
+ -- is no place to put the code, and in any case we handle initialization
+ -- of such types (in the Initialize_Scalars case, that's the only time
+ -- the issue arises) in a special manner anyway which does not need an
+ -- init_proc.
if Has_Non_Null_Base_Init_Proc (Comp_Type)
or else Needs_Simple_Initialization (Comp_Type)
or else Has_Task (Comp_Type)
- or else (not Restrictions (No_Initialize_Scalars)
+ or else (not Restriction_Active (No_Initialize_Scalars)
and then Is_Public (A_Type)
and then Root_Type (A_Type) /= Standard_String
- and then Root_Type (A_Type) /= Standard_Wide_String)
+ and then Root_Type (A_Type) /= Standard_Wide_String
+ and then Root_Type (A_Type) /= Standard_Wide_Wide_String)
then
Proc_Id :=
Make_Defining_Identifier (Loc, Make_Init_Proc_Name (A_Type));
P : Node_Id;
begin
- -- Nothing to do if there is no task hierarchy.
+ -- Nothing to do if there is no task hierarchy
- if Restrictions (No_Task_Hierarchy) then
+ if Restriction_Active (No_Task_Hierarchy) then
return;
end if;
-- Nothing to do if we already built a master entity for this scope
if not Has_Master_Entity (Scope (T)) then
+
-- first build the master entity
-- _Master : constant Master_Id := Current_Master.all;
-- and insert it just before the current declaration
end loop;
end if;
- -- Now define the renaming of the master_id.
+ -- Now define the renaming of the master_id
M_Id :=
Make_Defining_Identifier (Loc,
function Build_Case_Statement
(Case_Id : Entity_Id;
- Variant : Node_Id)
- return Node_Id;
+ Variant : Node_Id) return Node_Id;
-- Build a case statement containing only two alternatives. The
-- first alternative corresponds exactly to the discrete choices
-- given on the variant with contains the components that we are
function Build_Dcheck_Function
(Case_Id : Entity_Id;
- Variant : Node_Id)
- return Entity_Id;
+ Variant : Node_Id) return Entity_Id;
-- Build the discriminant checking function for a given variant
procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id);
function Build_Case_Statement
(Case_Id : Entity_Id;
- Variant : Node_Id)
- return Node_Id
+ Variant : Node_Id) return Node_Id
is
Alt_List : constant List_Id := New_List;
Actuals_List : List_Id;
function Build_Dcheck_Function
(Case_Id : Entity_Id;
- Variant : Node_Id)
- return Entity_Id
+ Variant : Node_Id) return Entity_Id
is
Body_Node : Node_Id;
Func_Id : Entity_Id;
Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
Set_Parameter_Specifications (Spec_Node, Parameter_List);
- Set_Subtype_Mark (Spec_Node,
- New_Reference_To (Standard_Boolean, Loc));
+ Set_Result_Definition (Spec_Node,
+ New_Reference_To (Standard_Boolean, Loc));
Set_Specification (Body_Node, Spec_Node);
Set_Declarations (Body_Node, New_List);
function Build_Discriminant_Formals
(Rec_Id : Entity_Id;
- Use_Dl : Boolean)
- return List_Id
+ Use_Dl : Boolean) return List_Id
is
Loc : Source_Ptr := Sloc (Rec_Id);
Parameter_List : constant List_Id := New_List;
In_Init_Proc : Boolean := False;
Enclos_Type : Entity_Id := Empty;
Discr_Map : Elist_Id := New_Elmt_List;
- With_Default_Init : Boolean := False)
- return List_Id
+ With_Default_Init : Boolean := False) return List_Id
is
First_Arg : Node_Id;
Args : List_Id;
Controller_Typ : Entity_Id;
begin
- -- Nothing to do if the Init_Proc is null, unless Initialize_Sclalars
+ -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars
-- is active (in which case we make the call anyway, since in the
-- actual compiled client it may be non null).
-- through the outer routines.
if Has_Task (Full_Type) then
- if Restrictions (No_Task_Hierarchy) then
+ if Restriction_Active (No_Task_Hierarchy) then
-- See comments in System.Tasking.Initialization.Init_RTS
-- for the value 3 (should be rtsfindable constant ???)
Append_To (Args, Make_Identifier (Loc, Name_uChain));
- -- Ada0Y (AI-287): In case of default initialized components
+ -- Ada 2005 (AI-287): In case of default initialized components
-- with tasks, we generate a null string actual parameter.
-- This is just a workaround that must be improved later???
if With_Default_Init then
- declare
- S : String_Id;
- Null_String : Node_Id;
- begin
- Start_String;
- S := End_String;
- Null_String := Make_String_Literal (Loc, Strval => S);
- Append_To (Args, Null_String);
- end;
+ Append_To (Args,
+ Make_String_Literal (Loc,
+ Strval => ""));
+
else
Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type);
Decl := Last (Decls);
end if;
end if;
- -- Ada0Y (AI-287) In case of default initialized components, we
- -- need to generate the corresponding selected component node
+ -- Ada 2005 (AI-287) In case of default initialized components,
+ -- we need to generate the corresponding selected component node
-- to access the discriminant value. In other cases this is not
-- required because we are inside the init proc and we use the
-- corresponding formal.
Decl : Node_Id;
begin
- -- Nothing to do if there is no task hierarchy.
+ -- Nothing to do if there is no task hierarchy
- if Restrictions (No_Task_Hierarchy) then
+ if Restriction_Active (No_Task_Hierarchy) then
return;
end if;
-- components of the given component list. This may involve building
-- case statements for the variant parts.
- function Build_Init_Call_Thru
- (Parameters : List_Id)
- return List_Id;
+ function Build_Init_Call_Thru (Parameters : List_Id) return List_Id;
-- Given a non-tagged type-derivation that declares discriminants,
-- such as
--
-- to which the check actions are appended.
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 differences. The types Tag and Vtable_Ptr,
+ (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, 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. The other relaxation is for packed bit arrays that are
- -- associated with a modular type, which in some cases require
- -- zero initialization to properly support comparisons, except
- -- that comparison of such components always involves an explicit
- -- selection of only the component's specific bits (whether or not
- -- there are adjacent components or gaps), so zero initialization
- -- is never needed for components.
+ -- initialization to null, do not require initialization as components,
+ -- since they are explicitly initialized by other means.
procedure Constrain_Array
(SI : Node_Id;
Selector_Name => New_Occurrence_Of (Id, Loc));
Set_Assignment_OK (Lhs);
- -- Case of an access attribute applied to the current
- -- instance. Replace the reference to the type by a
- -- reference to the actual object. (Note that this
- -- handles the case of the top level of the expression
- -- being given by such an attribute, but doesn't cover
- -- uses nested within an initial value expression.
- -- Nested uses are unlikely to occur in practice,
- -- but theoretically possible. It's not clear how
- -- to handle them without fully traversing the
- -- expression. ???)
+ -- Case of an access attribute applied to the current instance.
+ -- Replace the reference to the type by a reference to the actual
+ -- object. (Note that this handles the case of the top level of
+ -- the expression being given by such an attribute, but does not
+ -- cover uses nested within an initial value expression. Nested
+ -- uses are unlikely to occur in practice, but are theoretically
+ -- possible. It is not clear how to handle them without fully
+ -- traversing the expression. ???
if Kind = N_Attribute_Reference
and then (Attribute_Name (N) = Name_Unchecked_Access
Attribute_Name => Name_Unrestricted_Access);
end if;
- -- For a derived type the default value is copied from the component
- -- declaration of the parent. In the analysis of the init_proc for
- -- the parent the default value may have been expanded into a local
- -- variable, which is of course not usable here. We must copy the
- -- original expression and reanalyze.
-
- if Nkind (Exp) = N_Identifier
- and then not Comes_From_Source (Exp)
- and then Analyzed (Exp)
- and then not In_Open_Scopes (Scope (Entity (Exp)))
- and then Nkind (Original_Node (Exp)) = N_Aggregate
+ -- Ada 2005 (AI-231): Add the run-time check if required
+
+ if Ada_Version >= Ada_05
+ and then Can_Never_Be_Null (Etype (Id)) -- Lhs
then
- Exp := New_Copy_Tree (Original_Node (Exp));
+ if Nkind (Exp) = N_Null then
+ return New_List (
+ Make_Raise_Constraint_Error (Sloc (Exp),
+ Reason => CE_Null_Not_Allowed));
+
+ elsif Present (Etype (Exp))
+ and then not Can_Never_Be_Null (Etype (Exp))
+ then
+ Install_Null_Excluding_Check (Exp);
+ end if;
end if;
+ -- Take a copy of Exp to ensure that later copies of this
+ -- component_declaration in derived types see the original tree,
+ -- not a node rewritten during expansion of the init_proc.
+
+ Exp := New_Copy_Tree (Exp);
+
Res := New_List (
Make_Assignment_Statement (Loc,
Name => Lhs,
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Lhs),
Selector_Name =>
- New_Reference_To (Tag_Component (Typ), Loc)),
+ New_Reference_To (First_Tag_Component (Typ), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (Access_Disp_Table (Typ), Loc))));
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))));
end if;
-- Adjust the component if controlled except if it is an
-- aggregate that will be expanded inline
if Kind = N_Qualified_Expression then
- Kind := Nkind (Parent (N));
+ Kind := Nkind (Expression (N));
end if;
if Controlled_Type (Typ)
-- Build_Init_Call_Thru --
--------------------------
- function Build_Init_Call_Thru
- (Parameters : List_Id)
- return List_Id
- is
- Parent_Proc : constant Entity_Id :=
- Base_Init_Proc (Etype (Rec_Type));
+ function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is
+ Parent_Proc : constant Entity_Id :=
+ Base_Init_Proc (Etype (Rec_Type));
- Parent_Type : constant Entity_Id :=
- Etype (First_Formal (Parent_Proc));
+ Parent_Type : constant Entity_Id :=
+ Etype (First_Formal (Parent_Proc));
- Uparent_Type : constant Entity_Id :=
- Underlying_Type (Parent_Type);
+ Uparent_Type : constant Entity_Id :=
+ Underlying_Type (Parent_Type);
First_Discr_Param : Node_Id;
First_Discr_Param := Next (First (Parameters));
if Has_Task (Rec_Type) then
- if Restrictions (No_Task_Hierarchy) then
+ if Restriction_Active (No_Task_Hierarchy) then
-- See comments in System.Tasking.Initialization.Init_RTS
-- for the value 3.
Record_Extension_Node : Node_Id;
Init_Tag : Node_Id;
+ procedure Init_Secondary_Tags (Typ : Entity_Id);
+ -- Ada 2005 (AI-251): Initialize the tags of all the secondary
+ -- tables associated with abstract interface types
+
+ -------------------------
+ -- Init_Secondary_Tags --
+ -------------------------
+
+ procedure Init_Secondary_Tags (Typ : Entity_Id) is
+ ADT : Elmt_Id;
+
+ procedure Init_Secondary_Tags_Internal (Typ : Entity_Id);
+ -- Internal subprogram used to recursively climb to the root type
+
+ ----------------------------------
+ -- Init_Secondary_Tags_Internal --
+ ----------------------------------
+
+ procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is
+ E : Entity_Id;
+ Aux_N : Node_Id;
+
+ begin
+ if not Is_Interface (Typ)
+ and then Etype (Typ) /= Typ
+ then
+ Init_Secondary_Tags_Internal (Etype (Typ));
+ end if;
+
+ if Present (Abstract_Interfaces (Typ))
+ and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
+ then
+ E := First_Entity (Typ);
+ while Present (E) loop
+ if Is_Tag (E)
+ and then Chars (E) /= Name_uTag
+ then
+ Aux_N := Node (ADT);
+ pragma Assert (Present (Aux_N));
+
+ -- 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 (E, 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
+ (E, Loc)),
+ Attribute_Name => Name_Position)))));
+
+ Next_Elmt (ADT);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end if;
+ end Init_Secondary_Tags_Internal;
+
+ -- Start of processing for Init_Secondary_Tags
+
+ begin
+ -- Skip the first _Tag, which is the main tag of the
+ -- tagged type. Following tags correspond with abstract
+ -- interfaces.
+
+ ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+ Init_Secondary_Tags_Internal (Typ);
+ end Init_Secondary_Tags;
+
+ -- Start of processing for Build_Init_Procedure
+
begin
Body_Stmts := New_List;
Body_Node := New_Node (N_Subprogram_Body, Loc);
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name =>
- New_Reference_To (Tag_Component (Rec_Type), Loc)),
+ New_Reference_To (First_Tag_Component (Rec_Type), Loc)),
Expression =>
- New_Reference_To (Access_Disp_Table (Rec_Type), Loc));
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc));
-- The tag must be inserted before the assignments to other
-- components, because the initial value of the component may
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 Ada_Version >= Ada_05
+ and then not Is_Interface (Rec_Type)
+ then
+ Init_Secondary_Tags (Rec_Type);
+ end if;
+
else
declare
Nod : Node_Id := First (Body_Stmts);
Id : Entity_Id;
Typ : Entity_Id;
+ function Has_Access_Constraint (E : Entity_Id) return Boolean;
+ -- Components with access discriminants that depend on the current
+ -- instance must be initialized after all other components.
+
+ ---------------------------
+ -- Has_Access_Constraint --
+ ---------------------------
+
+ function Has_Access_Constraint (E : Entity_Id) return Boolean is
+ Disc : Entity_Id;
+ T : constant Entity_Id := Etype (E);
+
+ begin
+ if Has_Per_Object_Constraint (E)
+ and then Has_Discriminants (T)
+ then
+ Disc := First_Discriminant (T);
+ while Present (Disc) loop
+ if Is_Access_Type (Etype (Disc)) then
+ return True;
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+
+ return False;
+ else
+ return False;
+ end if;
+ end Has_Access_Constraint;
+
+ -- Start of processing for Build_Init_Statements
+
begin
if Null_Present (Comp_List) then
return New_List (Make_Null_Statement (Loc));
Per_Object_Constraint_Components := False;
- -- First step : regular components.
+ -- First step : regular components
Decl := First_Non_Pragma (Component_Items (Comp_List));
while Present (Decl) loop
Loc := Sloc (Decl);
- Build_Record_Checks (Subtype_Indication (Decl), Check_List);
+ Build_Record_Checks
+ (Subtype_Indication (Component_Definition (Decl)), Check_List);
Id := Defining_Identifier (Decl);
Typ := Etype (Id);
- if Has_Per_Object_Constraint (Id)
+ if Has_Access_Constraint (Id)
and then No (Expression (Decl))
then
-- Skip processing for now and ask for a second pass
elsif Component_Needs_Simple_Initialization (Typ) then
Stmts :=
- Build_Assignment (Id, Get_Simple_Init_Val (Typ, Loc));
+ Build_Assignment
+ (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id)));
-- Nothing needed for this case
Id := Defining_Identifier (Decl);
Typ := Etype (Id);
- if Has_Per_Object_Constraint (Id)
+ if Has_Access_Constraint (Id)
and then No (Expression (Decl))
then
if Has_Non_Null_Base_Init_Proc (Typ) then
elsif Component_Needs_Simple_Initialization (Typ) then
Append_List_To (Statement_List,
- Build_Assignment (Id, Get_Simple_Init_Val (Typ, Loc)));
+ Build_Assignment
+ (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id))));
end if;
end if;
-- to bind any interrupt (signal) entries.
if Is_Task_Record_Type (Rec_Type) then
+
+ -- In the case of the restricted run time the ATCB has already
+ -- been preallocated.
+
+ if Restricted_Profile then
+ Append_To (Statement_List,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
+ Expression => Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uATCB)),
+ Attribute_Name => Name_Unchecked_Access)));
+ end if;
+
Append_To (Statement_List, Make_Task_Create_Call (Rec_Type));
declare
-------------------------------------------
function Component_Needs_Simple_Initialization
- (T : Entity_Id)
- return Boolean
+ (T : Entity_Id) return Boolean
is
begin
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_Bit_Packed_Array (T);
+ 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
if Is_CPP_Class (Rec_Id) then
return False;
- elsif not Restrictions (No_Initialize_Scalars)
+ elsif not Restriction_Active (No_Initialize_Scalars)
and then Is_Public (Rec_Id)
then
return True;
if Is_Derived_Type (Rec_Type)
and then not Is_Tagged_Type (Rec_Type)
+ and then not Is_Unchecked_Union (Rec_Type)
and then not Has_New_Non_Standard_Rep (Rec_Type)
and then not Parent_Subtype_Renaming_Discrims
and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type))
-- Otherwise if we need an initialization procedure, then build one,
-- mark it as public and inlinable and as having a completion.
- elsif Requires_Init_Proc (Rec_Type) then
+ elsif Requires_Init_Proc (Rec_Type)
+ or else Is_Unchecked_Union (Rec_Type)
+ then
Build_Init_Procedure;
Set_Is_Public (Proc_Id, Is_Public (Pe));
end if;
end Build_Record_Init_Proc;
+ ----------------------------
+ -- Build_Slice_Assignment --
+ ----------------------------
+
+ -- Generates the following subprogram:
+
+ -- procedure Assign
+ -- (Source, Target : Array_Type,
+ -- Left_Lo, Left_Hi, Right_Lo, Right_Hi : Index;
+ -- Rev : Boolean)
+ -- is
+ -- Li1 : Index;
+ -- Ri1 : Index;
+
+ -- begin
+ -- if Rev then
+ -- Li1 := Left_Hi;
+ -- Ri1 := Right_Hi;
+ -- else
+ -- Li1 := Left_Lo;
+ -- Ri1 := Right_Lo;
+ -- end if;
+
+ -- loop
+ -- if Rev then
+ -- exit when Li1 < Left_Lo;
+ -- else
+ -- exit when Li1 > Left_Hi;
+ -- end if;
+
+ -- Target (Li1) := Source (Ri1);
+
+ -- if Rev then
+ -- Li1 := Index'pred (Li1);
+ -- Ri1 := Index'pred (Ri1);
+ -- else
+ -- Li1 := Index'succ (Li1);
+ -- Ri1 := Index'succ (Ri1);
+ -- end if;
+ -- end loop;
+ -- end Assign;
+
+ procedure Build_Slice_Assignment (Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
+
+ -- Build formal parameters of procedure
+
+ Larray : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars => New_Internal_Name ('A'));
+ Rarray : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars => New_Internal_Name ('R'));
+ Left_Lo : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars => New_Internal_Name ('L'));
+ Left_Hi : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars => New_Internal_Name ('L'));
+ Right_Lo : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars => New_Internal_Name ('R'));
+ Right_Hi : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars => New_Internal_Name ('R'));
+ Rev : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars => New_Internal_Name ('D'));
+ Proc_Name : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name (Typ, TSS_Slice_Assign));
+
+ Lnn : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
+ Rnn : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ -- Subscripts for left and right sides
+
+ Decls : List_Id;
+ Loops : Node_Id;
+ Stats : List_Id;
+
+ begin
+ -- Build declarations for indices
+
+ Decls := New_List;
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Lnn,
+ Object_Definition =>
+ New_Occurrence_Of (Index, Loc)));
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Rnn,
+ Object_Definition =>
+ New_Occurrence_Of (Index, Loc)));
+
+ Stats := New_List;
+
+ -- Build initializations for indices
+
+ declare
+ F_Init : constant List_Id := New_List;
+ B_Init : constant List_Id := New_List;
+
+ begin
+ Append_To (F_Init,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Lnn, Loc),
+ Expression => New_Occurrence_Of (Left_Lo, Loc)));
+
+ Append_To (F_Init,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Rnn, Loc),
+ Expression => New_Occurrence_Of (Right_Lo, Loc)));
+
+ Append_To (B_Init,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Lnn, Loc),
+ Expression => New_Occurrence_Of (Left_Hi, Loc)));
+
+ Append_To (B_Init,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Rnn, Loc),
+ Expression => New_Occurrence_Of (Right_Hi, Loc)));
+
+ Append_To (Stats,
+ Make_If_Statement (Loc,
+ Condition => New_Occurrence_Of (Rev, Loc),
+ Then_Statements => B_Init,
+ Else_Statements => F_Init));
+ end;
+
+ -- Now construct the assignment statement
+
+ Loops :=
+ Make_Loop_Statement (Loc,
+ Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (Larray, Loc),
+ Expressions => New_List (New_Occurrence_Of (Lnn, Loc))),
+ Expression =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (Rarray, Loc),
+ Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
+ End_Label => Empty);
+
+ -- Build exit condition
+
+ declare
+ F_Ass : constant List_Id := New_List;
+ B_Ass : constant List_Id := New_List;
+
+ begin
+ Append_To (F_Ass,
+ Make_Exit_Statement (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => New_Occurrence_Of (Lnn, Loc),
+ Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
+
+ Append_To (B_Ass,
+ Make_Exit_Statement (Loc,
+ Condition =>
+ Make_Op_Lt (Loc,
+ Left_Opnd => New_Occurrence_Of (Lnn, Loc),
+ Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
+
+ Prepend_To (Statements (Loops),
+ Make_If_Statement (Loc,
+ Condition => New_Occurrence_Of (Rev, Loc),
+ Then_Statements => B_Ass,
+ Else_Statements => F_Ass));
+ end;
+
+ -- Build the increment/decrement statements
+
+ declare
+ F_Ass : constant List_Id := New_List;
+ B_Ass : constant List_Id := New_List;
+
+ begin
+ Append_To (F_Ass,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Lnn, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Index, Loc),
+ Attribute_Name => Name_Succ,
+ Expressions => New_List (
+ New_Occurrence_Of (Lnn, Loc)))));
+
+ Append_To (F_Ass,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Rnn, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Index, Loc),
+ Attribute_Name => Name_Succ,
+ Expressions => New_List (
+ New_Occurrence_Of (Rnn, Loc)))));
+
+ Append_To (B_Ass,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Lnn, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Index, Loc),
+ Attribute_Name => Name_Pred,
+ Expressions => New_List (
+ New_Occurrence_Of (Lnn, Loc)))));
+
+ Append_To (B_Ass,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Rnn, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Index, Loc),
+ Attribute_Name => Name_Pred,
+ Expressions => New_List (
+ New_Occurrence_Of (Rnn, Loc)))));
+
+ Append_To (Statements (Loops),
+ Make_If_Statement (Loc,
+ Condition => New_Occurrence_Of (Rev, Loc),
+ Then_Statements => B_Ass,
+ Else_Statements => F_Ass));
+ end;
+
+ Append_To (Stats, Loops);
+
+ declare
+ Spec : Node_Id;
+ Formals : List_Id := New_List;
+
+ begin
+ Formals := New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Larray,
+ Out_Present => True,
+ Parameter_Type =>
+ New_Reference_To (Base_Type (Typ), Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Rarray,
+ Parameter_Type =>
+ New_Reference_To (Base_Type (Typ), Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Left_Lo,
+ Parameter_Type =>
+ New_Reference_To (Index, Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Left_Hi,
+ Parameter_Type =>
+ New_Reference_To (Index, Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Right_Lo,
+ Parameter_Type =>
+ New_Reference_To (Index, Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Right_Hi,
+ Parameter_Type =>
+ New_Reference_To (Index, Loc)));
+
+ Append_To (Formals,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Rev,
+ Parameter_Type =>
+ New_Reference_To (Standard_Boolean, Loc)));
+
+ Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Proc_Name,
+ Parameter_Specifications => Formals);
+
+ Discard_Node (
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+ Declarations => Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stats)));
+ end;
+
+ Set_TSS (Typ, Proc_Name);
+ Set_Is_Pure (Proc_Name);
+ end Build_Slice_Assignment;
+
------------------------------------
-- Build_Variant_Record_Equality --
------------------------------------
-- Generates:
- --
+
-- function _Equality (X, Y : T) return Boolean is
-- begin
-- -- Compare discriminants
Def : constant Node_Id := Parent (Typ);
Comps : constant Node_Id := Component_List (Type_Definition (Def));
Stmts : constant List_Id := New_List;
+ Pspecs : constant List_Id := New_List;
begin
+ -- Derived Unchecked_Union types no longer inherit the equality function
+ -- of their parent.
+
if Is_Derived_Type (Typ)
+ and then not Is_Unchecked_Union (Typ)
and then not Has_New_Non_Standard_Rep (Typ)
then
declare
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => F,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => X,
- Parameter_Type => New_Reference_To (Typ, Loc)),
-
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Y,
- Parameter_Type => New_Reference_To (Typ, Loc))),
-
- Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
-
+ Parameter_Specifications => Pspecs,
+ Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts)));
- -- For unchecked union case, raise program error. This will only
- -- happen in the case of dynamic dispatching for a tagged type,
- -- since in the static cases it is a compile time error.
+ Append_To (Pspecs,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => X,
+ Parameter_Type => New_Reference_To (Typ, Loc)));
+
+ Append_To (Pspecs,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Y,
+ Parameter_Type => New_Reference_To (Typ, Loc)));
+
+ -- Unchecked_Unions require additional machinery to support equality.
+ -- Two extra parameters (A and B) are added to the equality function
+ -- parameter list in order to capture the inferred values of the
+ -- discriminants in later calls.
+
+ if Is_Unchecked_Union (Typ) then
+ declare
+ Discr_Type : constant Node_Id := Etype (First_Discriminant (Typ));
+
+ A : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_A);
+
+ B : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_B);
+
+ begin
+ -- Add A and B to the parameter list
+
+ Append_To (Pspecs,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => A,
+ Parameter_Type => New_Reference_To (Discr_Type, Loc)));
+
+ Append_To (Pspecs,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => B,
+ Parameter_Type => New_Reference_To (Discr_Type, Loc)));
+
+ -- Generate the following header code to compare the inferred
+ -- discriminants:
+
+ -- if a /= b then
+ -- return False;
+ -- end if;
+
+ Append_To (Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => New_Reference_To (A, Loc),
+ Right_Opnd => New_Reference_To (B, Loc)),
+ Then_Statements => New_List (
+ Make_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (Standard_False, Loc)))));
+
+ -- Generate component-by-component comparison. Note that we must
+ -- propagate one of the inferred discriminant formals to act as
+ -- the case statement switch.
+
+ Append_List_To (Stmts,
+ Make_Eq_Case (Typ, Comps, A));
+
+ end;
+
+ -- Normal case (not unchecked union)
- if Has_Unchecked_Union (Typ) then
- Append_To (Stmts,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Unchecked_Union_Restriction));
else
Append_To (Stmts,
Make_Eq_If (Typ,
Discriminant_Specifications (Def)));
+
Append_List_To (Stmts,
Make_Eq_Case (Typ, Comps));
end if;
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 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);
while Present (Comp) loop
if Comes_From_Source (Comp)
- and then Original_Record_Component (Comp) = Comp
+ and then Original_Record_Component (Comp) = Comp
and then Is_Limited_Type (Etype (Comp))
then
- if (Par_Read and then
- No (TSS (Base_Type (Etype (Comp)), TSS_Stream_Read)))
- or else
- (Par_Write and then
- No (TSS (Base_Type (Etype (Comp)), TSS_Stream_Write)))
- then
- Error_Msg_N
- ("|component must have Stream attribute",
- Parent (Comp));
+ if Par_Read then
+ Check_Attr (Name_Read, TSS_Stream_Read);
+ end if;
+
+ if Par_Write then
+ Check_Attr (Name_Write, TSS_Stream_Write);
end if;
end if;
end if;
end Check_Stream_Attributes;
- ---------------------------
- -- Expand_Derived_Record --
- ---------------------------
+ -----------------------------
+ -- Expand_Record_Extension --
+ -----------------------------
-- Add a field _parent at the beginning of the record extension. This is
-- used to implement inheritance. Here are some examples of expansion:
-- D : Int;
-- end;
- procedure Expand_Derived_Record (T : Entity_Id; Def : Node_Id) is
+ procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
Indic : constant Node_Id := Subtype_Indication (Def);
Loc : constant Source_Ptr := Sloc (Def);
Rec_Ext_Part : Node_Id := Record_Extension_Part (Def);
List_Constr : constant List_Id := New_List;
begin
- -- Expand_Tagged_Extension is called directly from the semantics, so
+ -- Expand_Record_Extension is called directly from the semantics, so
-- we must check to see whether expansion is active before proceeding
if not Expander_Active then
Comp_Decl :=
Make_Component_Declaration (Loc,
Defining_Identifier => Parent_N,
- Subtype_Indication => New_Reference_To (Par_Subtype, Loc));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (Par_Subtype, Loc)));
if Null_Present (Rec_Ext_Part) then
Set_Component_List (Rec_Ext_Part,
end if;
Analyze (Comp_Decl);
- end Expand_Derived_Record;
+ end Expand_Record_Extension;
------------------------------------
-- Expand_N_Full_Type_Declaration --
Next_Elmt (Elmt);
end loop;
- -- If the derived type itself is private with a full view,
- -- then associate the full view with the inherited TSS_Elist
- -- as well.
+ -- If the derived type itself is private with a full view, then
+ -- associate the full view with the inherited TSS_Elist as well.
if Ekind (B_Id) in Private_Kind
and then Present (Full_View (B_Id))
-- 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));
+ 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
end;
end if;
- -- For tagged types, when an init value is given, the tag has
- -- to be re-initialized separately in order to avoid the
- -- propagation of a wrong tag coming from a view conversion
- -- unless the type is class wide (in this case the tag comes
- -- from the init value). Suppress the tag assignment when
- -- Java_VM because JVM tags are represented implicitly
- -- in objects. Ditto for types that are CPP_CLASS.
+ -- For tagged types, when an init value is given, the tag has to
+ -- be re-initialized separately in order to avoid the propagation
+ -- of a wrong tag coming from a view conversion unless the type
+ -- is class wide (in this case the tag comes from the init
+ -- value). Suppress the tag assignment when Java_VM because JVM
+ -- tags are represented implicitly in objects. Ditto for types
+ -- that are CPP_CLASS, and for initializations that are
+ -- aggregates, because they have to have the right tag.
if Is_Tagged_Type (Typ)
and then not Is_Class_Wide_Type (Typ)
and then not Is_CPP_Class (Typ)
and then not Java_VM
+ and then Nkind (Expr) /= N_Aggregate
then
-- The re-assignment of the tag has to be done even if
-- the object is a constant
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Def_Id, Loc),
Selector_Name =>
- New_Reference_To (Tag_Component (Typ), Loc));
+ New_Reference_To (First_Tag_Component (Typ), Loc));
Set_Assignment_OK (New_Ref);
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
- (Access_Disp_Table (Base_Type (Typ)), Loc))));
+ (Node
+ (First_Elmt
+ (Access_Disp_Table (Base_Type (Typ)))),
+ Loc))));
-- For discrete types, set the Is_Known_Valid flag if the
-- initializing value is known to be valid.
then
Set_Is_Known_Valid (Def_Id);
- -- For access types set the Is_Known_Non_Null flag if the
- -- initializing value is known to be non-null. We can also
- -- set Can_Never_Be_Null if this is a constant.
+ elsif Is_Access_Type (Typ) then
- elsif Is_Access_Type (Typ)
- and then Known_Non_Null (Expr)
- then
- Set_Is_Known_Non_Null (Def_Id);
+ -- For access types set the Is_Known_Non_Null flag if the
+ -- initializing value is known to be non-null. We can also set
+ -- Can_Never_Be_Null if this is a constant.
+
+ if Known_Non_Null (Expr) then
+ Set_Is_Known_Non_Null (Def_Id);
- if Constant_Present (N) then
- Set_Can_Never_Be_Null (Def_Id);
+ if Constant_Present (N) then
+ Set_Can_Never_Be_Null (Def_Id);
+ end if;
end if;
end if;
end if;
end if;
- if Is_Possibly_Unaligned_Slice (Expr) then
+ -- Cases where the back end cannot handle the initialization
+ -- directly. In such cases, we expand an assignment that will
+ -- be appropriately handled by Expand_N_Assignment_Statement.
+
+ -- The exclusion of the unconstrained case is wrong, but for
+ -- now it is too much trouble ???
+
+ if (Is_Possibly_Unaligned_Slice (Expr)
+ or else (Is_Possibly_Unaligned_Object (Expr)
+ and then not Represented_As_Scalar (Etype (Expr))))
- -- Make a separate assignment that will be expanded into a
- -- loop, to bypass back-end problems with misaligned arrays.
+ -- The exclusion of the unconstrained case is wrong, but for
+ -- now it is too much trouble ???
+ and then not (Is_Array_Type (Etype (Expr))
+ and then not Is_Constrained (Etype (Expr)))
+ then
declare
Stat : constant Node_Id :=
Make_Assignment_Statement (Loc,
- Name => New_Reference_To (Def_Id, Loc),
+ Name => New_Reference_To (Def_Id, Loc),
Expression => Relocate_Node (Expr));
-
begin
Set_Expression (N, Empty);
Set_No_Initialization (N);
Set_Assignment_OK (Name (Stat));
+ Set_No_Ctrl_Actions (Stat);
Insert_After (N, Stat);
Analyze (Stat);
end;
-- Expand_N_Subtype_Indication --
---------------------------------
- -- Add a check on the range of the subtype. The static case is
- -- partially duplicated by Process_Range_Expr_In_Decl in Sem_Ch3,
- -- but we still need to check here for the static case in order to
- -- avoid generating extraneous expanded code.
+ -- Add a check on the range of the subtype. The static case is partially
+ -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
+ -- to check here for the static case in order to avoid generating
+ -- extraneous expanded code.
procedure Expand_N_Subtype_Indication (N : Node_Id) is
Ran : constant Node_Id := Range_Expression (Constraint (N));
-- Expand_N_Variant_Part --
---------------------------
- -- If the last variant does not contain the Others choice, replace
- -- it with an N_Others_Choice node since Gigi always wants an Others.
- -- Note that we do not bother to call Analyze on the modified variant
- -- part, since it's only effect would be to compute the contents of
- -- the Others_Discrete_Choices node laboriously, and of course we
- -- already know the list of choices that corresponds to the others
- -- choice (it's the list we are replacing!)
+ -- If the last variant does not contain the Others choice, replace it with
+ -- an N_Others_Choice node since Gigi always wants an Others. Note that we
+ -- do not bother to call Analyze on the modified variant part, since it's
+ -- only effect would be to compute the contents of the
+ -- Others_Discrete_Choices node laboriously, and of course we already know
+ -- the list of choices that corresponds to the others choice (it's the
+ -- list we are replacing!)
procedure Expand_N_Variant_Part (N : Node_Id) is
Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N));
Others_Node : Node_Id;
-
begin
if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then
Others_Node := Make_Others_Choice (Sloc (Last_Var));
Comp_Decl :=
Make_Component_Declaration (Loc,
Defining_Identifier => Ent,
- Subtype_Indication => New_Reference_To (Controller_Type, Loc));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (Controller_Type, Loc)));
if Null_Present (Comp_List)
or else Is_Empty_List (Component_Items (Comp_List))
Set_Null_Present (Comp_List, False);
else
- -- The controller cannot be placed before the _Parent field
- -- since gigi lays out field in order and _parent must be
- -- first to preserve the polymorphism of tagged types.
+ -- The controller cannot be placed before the _Parent field since
+ -- gigi lays out field in order and _parent must be first to
+ -- preserve the polymorphism of tagged types.
First_Comp := First (Component_Items (Comp_List));
Set_Ekind (Ent, E_Component);
Init_Component_Location (Ent);
- -- Move the _controller entity ahead in the list of internal
- -- entities of the enclosing record so that it is selected
- -- instead of a potentially inherited one.
+ -- Move the _controller entity ahead in the list of internal entities
+ -- of the enclosing record so that it is selected instead of a
+ -- potentially inherited one.
declare
E : constant Entity_Id := Last_Entity (T);
Comp_Decl :=
Make_Component_Declaration (Sloc_N,
- Defining_Identifier => Tag_Component (T),
- Subtype_Indication =>
- New_Reference_To (RTE (RE_Tag), Sloc_N));
+ Defining_Identifier => First_Tag_Component (T),
+ Component_Definition =>
+ Make_Component_Definition (Sloc_N,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (RTE (RE_Tag), Sloc_N)));
if Null_Present (Comp_List)
or else Is_Empty_List (Component_Items (Comp_List))
end if;
-- We don't Analyze the whole expansion because the tag component has
- -- already been analyzed previously. Here we just insure that the
- -- tree is coherent with the semantic decoration
+ -- already been analyzed previously. Here we just insure that the tree
+ -- is coherent with the semantic decoration
- Find_Type (Subtype_Indication (Comp_Decl));
+ Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
exception
when RE_Not_Available =>
begin
if not Is_Bit_Packed_Array (Typ) then
- -- If the component contains tasks, so does the array type.
- -- This may not be indicated in the array type because the
- -- component may have been a private type at the point of
- -- definition. Same if component type is controlled.
+ -- If the component contains tasks, so does the array type. This may
+ -- not be indicated in the array type because the component may have
+ -- been a private type at the point of definition. Same if component
+ -- type is controlled.
Set_Has_Task (Base, Has_Task (Component_Type (Typ)));
Set_Has_Controlled_Component (Base,
if No (Init_Proc (Base)) then
- -- If this is an anonymous array created for a declaration
- -- with an initial value, its init_proc will never be called.
- -- The initial value itself may have been expanded into assign-
+ -- If this is an anonymous array created for a declaration with
+ -- an initial value, its init_proc will never be called. The
+ -- initial value itself may have been expanded into assign-
-- ments, in which case the object declaration is carries the
-- No_Initialization flag.
then
null;
- -- We do not need an init proc for string or wide string, since
- -- the only time these need initialization in normalize or
+ -- We do not need an init proc for string or wide [wide] string,
+ -- since the only time these need initialization in normalize or
-- initialize scalars mode, and these types are treated specially
-- and do not need initialization procedures.
elsif Root_Type (Base) = Standard_String
or else Root_Type (Base) = Standard_Wide_String
+ or else Root_Type (Base) = Standard_Wide_Wide_String
then
null;
if Typ = Base and then Has_Controlled_Component (Base) then
Build_Controlling_Procs (Base);
+
+ if not Is_Limited_Type (Component_Type (Typ))
+ and then Number_Dimensions (Typ) = 1
+ then
+ Build_Slice_Assignment (Typ);
+ end if;
end if;
- -- For packed case, there is a default initialization, except
- -- if the component type is itself a packed structure with an
- -- initialization procedure.
+ -- For packed case, there is a default initialization, except if the
+ -- component type is itself a packed structure with an initialization
+ -- procedure.
elsif Present (Init_Proc (Component_Type (Base)))
and then No (Base_Init_Proc (Base))
pragma Warnings (Off, Func);
begin
- -- Various optimization are possible if the given representation
- -- is contiguous.
+ -- Various optimization are possible if the given representation is
+ -- contiguous.
Is_Contiguous := True;
Ent := First_Literal (Typ);
end loop;
end if;
- -- Now build an array declaration.
+ -- Now build an array declaration
-- typA : array (Natural range 0 .. num - 1) of ctype :=
-- (v, v, v, v, v, ....)
- -- where ctype is the corresponding integer type. If the
- -- representation is contiguous, we only keep the first literal,
- -- which provides the offset for Pos_To_Rep computations.
+ -- where ctype is the corresponding integer type. If the representation
+ -- is contiguous, we only keep the first literal, which provides the
+ -- offset for Pos_To_Rep computations.
Arr :=
Make_Defining_Identifier (Loc,
High_Bound =>
Make_Integer_Literal (Loc, Num - 1))))),
- Subtype_Indication => New_Reference_To (Typ, Loc)),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (Typ, Loc))),
Expression =>
Make_Aggregate (Loc,
-- representation) raises Constraint_Error or returns a unique value
-- of minus one. The latter case is used, e.g. in 'Valid code.
- -- Note: the reason we use Enum_Rep values in the case here is to
- -- avoid the code generator making inappropriate assumptions about
- -- the range of the values in the case where the value is invalid.
- -- ityp is a signed or unsigned integer type of appropriate width.
+ -- Note: the reason we use Enum_Rep values in the case here is to avoid
+ -- the code generator making inappropriate assumptions about the range
+ -- of the values in the case where the value is invalid. ityp is a
+ -- signed or unsigned integer type of appropriate width.
-- Note: if exceptions are not supported, then we suppress the raise
-- and return -1 unconditionally (this is an erroneous program in any
- -- case and there is no obligation to raise Constraint_Error here!)
- -- We also do this if pragma Restrictions (No_Exceptions) is active.
+ -- case and there is no obligation to raise Constraint_Error here!) We
+ -- also do this if pragma Restrictions (No_Exceptions) is active.
-- Representations are signed
if Enumeration_Rep (First_Literal (Typ)) < 0 then
-- The underlying type is signed. Reset the Is_Unsigned_Type
- -- explicitly, because it might have been inherited from a
+ -- explicitly, because it might have been inherited from
-- parent type.
Set_Is_Unsigned_Type (Typ, False);
end if;
end if;
- -- The body of the function is a case statement. First collect
- -- case alternatives, or optimize the contiguous case.
+ -- The body of the function is a case statement. First collect case
+ -- alternatives, or optimize the contiguous case.
Lst := New_List;
if Enumeration_Rep (Ent) = Last_Repval then
- -- Another special case: for a single literal, Pos is zero.
+ -- Another special case: for a single literal, Pos is zero
Pos_Expr := Make_Integer_Literal (Loc, Uint_0);
-- In normal mode, add the others clause with the test
- if not Restrictions (No_Exception_Handlers) then
+ if not Restriction_Active (No_Exception_Handlers) then
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
Make_Defining_Identifier (Loc, Name_uF),
Parameter_Type => New_Reference_To (Standard_Boolean, Loc))),
- Subtype_Mark => New_Reference_To (Standard_Integer, Loc)),
+ Result_Definition => New_Reference_To (Standard_Integer, Loc)),
Declarations => Empty_List,
------------------------
procedure Freeze_Record_Type (N : Node_Id) is
- Def_Id : constant Node_Id := Entity (N);
Comp : Entity_Id;
- Type_Decl : constant Node_Id := Parent (Def_Id);
+ Def_Id : constant Node_Id := Entity (N);
Predef_List : List_Id;
+ Type_Decl : constant Node_Id := Parent (Def_Id);
Renamed_Eq : Node_Id := Empty;
-- Could use some comments ???
elsif Is_Derived_Type (Def_Id)
and then not Is_Tagged_Type (Def_Id)
+
+ -- If we have a derived Unchecked_Union, we do not inherit the
+ -- discriminant checking functions from the parent type since the
+ -- discriminants are non existent.
+
+ and then not Is_Unchecked_Union (Def_Id)
and then Has_Discriminants (Def_Id)
then
declare
end loop;
-- Creation of the Dispatch Table. Note that a Dispatch Table is
- -- created for regular tagged types as well as for Ada types
- -- deriving from a C++ Class, but not for tagged types directly
- -- corresponding to the C++ classes. In the later case we assume
- -- that the Vtable is created in the C++ side and we just use it.
+ -- created for regular tagged types as well as for Ada types deriving
+ -- from a C++ Class, but not for tagged types directly corresponding to
+ -- the C++ classes. In the later case we assume that the Vtable is
+ -- 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);
else
- -- Usually inherited primitives are not delayed but the first
- -- Ada extension of a CPP_Class is an exception since the
- -- address of the inherited subprogram has to be inserted in
- -- the new Ada Dispatch Table and this is a freezing action
- -- (usually the inherited primitive address is inserted in the
- -- DT by Inherit_DT)
-
- if Is_CPP_Class (Etype (Def_Id)) then
- declare
- Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id));
- Subp : Entity_Id;
+ -- Usually inherited primitives are not delayed but the first Ada
+ -- extension of a CPP_Class is an exception since the address of
+ -- the inherited subprogram has to be inserted in the new Ada
+ -- Dispatch Table and this is a freezing action (usually the
+ -- inherited primitive address is inserted in the DT by
+ -- Inherit_DT)
+
+ -- Similarly, if this is an inherited operation whose parent is
+ -- not frozen yet, it is not in the DT of the parent, and we
+ -- generate an explicit freeze node for the inherited operation,
+ -- so that it is properly inserted in the DT of the current type.
- begin
- while Present (Elmt) loop
- Subp := Node (Elmt);
+ declare
+ Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id));
+ Subp : Entity_Id;
+
+ begin
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
- if Present (Alias (Subp)) then
+ if Present (Alias (Subp)) then
+ if Is_CPP_Class (Etype (Def_Id)) then
+ Set_Has_Delayed_Freeze (Subp);
+
+ elsif Has_Delayed_Freeze (Alias (Subp))
+ and then not Is_Frozen (Alias (Subp))
+ then
+ Set_Is_Frozen (Subp, False);
Set_Has_Delayed_Freeze (Subp);
end if;
+ end if;
- Next_Elmt (Elmt);
- end loop;
- end;
- end if;
+ Next_Elmt (Elmt);
+ end loop;
+ end;
if Underlying_Type (Etype (Def_Id)) = Def_Id then
Expand_Tagged_Root (Def_Id);
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 must be before the
- -- freeze point).
+ -- 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
+ -- must be before the freeze point).
Set_Is_Frozen (Def_Id, False);
Make_Predefined_Primitive_Specs
(Def_Id, Predef_List, Renamed_Eq);
Insert_List_Before_And_Analyze (N, Predef_List);
+
Set_Is_Frozen (Def_Id, True);
Set_All_DT_Position (Def_Id);
-- Add the controlled component before the freezing actions
- -- it is referenced in those actions.
+ -- referenced in those actions.
if Has_New_Controlled_Component (Def_Id) then
Expand_Record_Controller (Def_Id);
end if;
- -- Suppress creation of a dispatch table when Java_VM because
- -- the dispatching mechanism is handled internally by the JVM.
+ -- Suppress creation of a dispatch table when Java_VM because the
+ -- dispatching mechanism is handled internally by the JVM.
if not Java_VM then
- Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
+
+ -- Ada 2005 (AI-251): Build the secondary dispatch tables
+
+ declare
+ ADT : Elist_Id := Access_Disp_Table (Def_Id);
+
+ procedure Add_Secondary_Tables (Typ : Entity_Id);
+ -- Comment required ???
+
+ --------------------------
+ -- Add_Secondary_Tables --
+ --------------------------
+
+ procedure Add_Secondary_Tables (Typ : Entity_Id) is
+ E : Entity_Id;
+ Result : List_Id;
+
+ begin
+ if Etype (Typ) /= Typ then
+ Add_Secondary_Tables (Etype (Typ));
+ end if;
+
+ if Present (Abstract_Interfaces (Typ))
+ and then not Is_Empty_Elmt_List
+ (Abstract_Interfaces (Typ))
+ then
+ E := First_Entity (Typ);
+ while Present (E) loop
+ if Is_Tag (E) and then Chars (E) /= Name_uTag then
+ Make_Abstract_Interface_DT
+ (AI_Tag => E,
+ Acc_Disp_Tables => ADT,
+ Result => Result);
+
+ Append_Freeze_Actions (Def_Id, Result);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end if;
+ end Add_Secondary_Tables;
+
+ -- Start of processing to build secondary dispatch tables
+
+ begin
+ Add_Secondary_Tables (Def_Id);
+ Set_Access_Disp_Table (Def_Id, ADT);
+ Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
+ end;
end if;
- -- Make sure that the primitives Initialize, Adjust and
- -- Finalize are Frozen before other TSS subprograms. We
- -- don't want them Frozen inside.
+ -- Make sure that the primitives Initialize, Adjust and Finalize
+ -- are Frozen before other TSS subprograms. We don't want them
+ -- Frozen inside.
if Is_Controlled (Def_Id) then
if not Is_Limited_Type (Def_Id) then
Append_Freeze_Actions
(Def_Id, Predefined_Primitive_Freeze (Def_Id));
+ Append_Freeze_Actions
+ (Def_Id, Init_Predefined_Interface_Primitives (Def_Id));
end if;
- -- In the non-tagged case, an equality function is provided only
- -- for variant records (that are not unchecked unions).
+ -- In the non-tagged case, an equality function is provided only for
+ -- variant records (that are not unchecked unions).
elsif Has_Discriminants (Def_Id)
and then not Is_Limited_Type (Def_Id)
begin
if Present (Comps)
and then Present (Variant_Part (Comps))
- and then not Is_Unchecked_Union (Def_Id)
then
Build_Variant_Record_Equality (Def_Id);
end if;
end if;
-- Before building the record initialization procedure, if we are
- -- dealing with a concurrent record value type, then we must go
- -- through the discriminants, exchanging discriminals between the
- -- concurrent type and the concurrent record value type. See the
- -- section "Handling of Discriminants" in the Einfo spec for details.
+ -- dealing with a concurrent record value type, then we must go through
+ -- the discriminants, exchanging discriminals between the concurrent
+ -- type and the concurrent record value type. See the section "Handling
+ -- of Discriminants" in the Einfo spec for details.
if Is_Concurrent_Record_Type (Def_Id)
and then Has_Discriminants (Def_Id)
Adjust_Discriminants (Def_Id);
Build_Record_Init_Proc (Type_Decl, Def_Id);
- -- For tagged type, build bodies of primitive operations. Note
- -- that we do this after building the record initialization
- -- experiment, since the primitive operations may need the
- -- initialization routine
+ -- For tagged type, build bodies of primitive operations. Note that we
+ -- do this after building the record initialization experiment, since
+ -- the primitive operations may need the initialization routine
if Is_Tagged_Type (Def_Id) then
Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
Append_Freeze_Actions (Def_Id, Predef_List);
- end if;
+ -- Populate the two auxiliary tables used for dispatching
+ -- asynchronous, conditional and timed selects for tagged
+ -- types that implement a limited interface.
+
+ if Ada_Version >= Ada_05
+ and then not Is_Interface (Def_Id)
+ and then not Is_Abstract (Def_Id)
+ and then not Is_Controlled (Def_Id)
+ and then Implements_Limited_Interface (Def_Id)
+ then
+ Append_Freeze_Actions (Def_Id, Make_Disp_Select_Tables (Def_Id));
+ end if;
+ end if;
end Freeze_Record_Type;
------------------------------
-- Freeze_Type --
-----------------
- -- 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
+ -- 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 Actions field list of the freeze
-- node using Append_Freeze_Actions.
- procedure Freeze_Type (N : Node_Id) is
+ function Freeze_Type (N : Node_Id) return Boolean is
Def_Id : constant Entity_Id := Entity (N);
RACW_Seen : Boolean := False;
+ Result : Boolean := False;
begin
-- Process associated access types needing special processing
if RACW_Seen then
- -- If there are RACWs designating this type, make stubs now.
+ -- If there are RACWs designating this type, make stubs now
Remote_Types_Tagged_Full_View_Encountered (Def_Id);
end if;
if Ekind (Def_Id) = E_Record_Type then
Freeze_Record_Type (N);
- -- The subtype may have been declared before the type was frozen.
- -- If the type has controlled components it is necessary to create
- -- the entity for the controller explicitly because it did not
- -- exist at the point of the subtype declaration. Only the entity is
- -- needed, the back-end will obtain the layout from the type.
- -- This is only necessary if this is constrained subtype whose
- -- component list is not shared with the base type.
+ -- The subtype may have been declared before the type was frozen. If
+ -- the type has controlled components it is necessary to create the
+ -- entity for the controller explicitly because it did not exist at
+ -- the point of the subtype declaration. Only the entity is needed,
+ -- the back-end will obtain the layout from the type. This is only
+ -- necessary if this is constrained subtype whose component list is
+ -- not shared with the base type.
elsif Ekind (Def_Id) = E_Record_Subtype
and then Has_Discriminants (Def_Id)
begin
if Scope (Old_C) = Base_Type (Def_Id) then
- -- The entity is the one in the parent. Create new one.
+ -- The entity is the one in the parent. Create new one
New_C := New_Copy (Old_C);
Set_Parent (New_C, Parent (Old_C));
end if;
end;
- -- Similar process if the controller of the subtype is not
- -- present but the parent has it. This can happen with constrained
+ if Is_Itype (Def_Id)
+ and then Is_Record_Type (Underlying_Type (Scope (Def_Id)))
+ then
+ -- The freeze node is only used to introduce the controller,
+ -- the back-end has no use for it for a discriminated
+ -- component.
+
+ Set_Freeze_Node (Def_Id, Empty);
+ Set_Has_Delayed_Freeze (Def_Id, False);
+ Result := True;
+ end if;
+
+ -- Similar process if the controller of the subtype is not present
+ -- but the parent has it. This can happen with constrained
-- record components where the subtype is an itype.
elsif Ekind (Def_Id) = E_Record_Subtype
Set_Freeze_Node (Def_Id, Empty);
Set_Has_Delayed_Freeze (Def_Id, False);
- Remove (N);
+ Result := True;
end;
end if;
DT_Align : Node_Id;
begin
- -- For unconstrained composite types we give a size of
- -- zero so that the pool knows that it needs a special
- -- algorithm for variable size object allocation.
+ -- For unconstrained composite types we give a size of zero
+ -- so that the pool knows that it needs a special algorithm
+ -- for variable size object allocation.
if Is_Composite_Type (Desig_Type)
and then not Is_Constrained (Desig_Type)
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Def_Id), 'P'));
- -- We put the code associated with the pools in the
- -- entity that has the later freeze node, usually the
- -- acces type but it can also be the designated_type;
- -- because the pool code requires both those types to be
- -- frozen
+ -- We put the code associated with the pools in the entity
+ -- that has the later freeze node, usually the acces type
+ -- but it can also be the designated_type; because the pool
+ -- code requires both those types to be frozen
if Is_Frozen (Desig_Type)
and then (not Present (Freeze_Node (Desig_Type))
null;
end if;
- -- For access-to-controlled types (including class-wide types
- -- and Taft-amendment types which potentially have controlled
- -- components), expand the list controller object that will
- -- store the dynamically allocated objects. Do not do this
+ -- For access-to-controlled types (including class-wide types and
+ -- Taft-amendment types which potentially have controlled
+ -- components), expand the list controller object that will store
+ -- the dynamically allocated objects. Do not do this
-- transformation for expander-generated access types, but do it
-- for types that are the full view of types derived from other
-- private types. Also suppress the list controller in the case
-- of a designated type with convention Java, since this is used
- -- when binding to Java API specs, where there's no equivalent
- -- of a finalization list and we don't want to pull in the
+ -- when binding to Java API specs, where there's no equivalent of
+ -- a finalization list and we don't want to pull in the
-- finalization support if not needed.
if not Comes_From_Source (Def_Id)
(Is_Incomplete_Or_Private_Type (Desig_Type)
and then No (Full_View (Desig_Type))
- -- An exception is made for types defined in the run-time
- -- because Ada.Tags.Tag itself is such a type and cannot
- -- afford this unnecessary overhead that would generates a
- -- loop in the expansion scheme...
+ -- An exception is made for types defined in the run-time
+ -- because Ada.Tags.Tag itself is such a type and cannot
+ -- afford this unnecessary overhead that would generates a
+ -- loop in the expansion scheme...
- and then not In_Runtime (Def_Id)
+ and then not In_Runtime (Def_Id)
- -- Another exception is if Restrictions (No_Finalization)
- -- is active, since then we know nothing is controlled.
+ -- Another exception is if Restrictions (No_Finalization)
+ -- is active, since then we know nothing is controlled.
- and then not Restrictions (No_Finalization))
+ and then not Restriction_Active (No_Finalization))
-- If the designated type is not frozen yet, its controlled
-- status must be retrieved explicitly.
and then Freeze_Node (Full_View (Def_Id)) = N
then
Set_Entity (N, Full_View (Def_Id));
- Freeze_Type (N);
+ Result := Freeze_Type (N);
Set_Entity (N, Def_Id);
- -- All other types require no expander action. There are such
- -- cases (e.g. task types and protected types). In such cases,
- -- the freeze nodes are there for use by Gigi.
+ -- All other types require no expander action. There are such cases
+ -- (e.g. task types and protected types). In such cases, the freeze
+ -- nodes are there for use by Gigi.
end if;
Freeze_Stream_Operations (N, Def_Id);
+ return Result;
exception
when RE_Not_Available =>
- return;
+ return False;
end Freeze_Type;
-------------------------
function Get_Simple_Init_Val
(T : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id
+ Loc : Source_Ptr;
+ Size : Uint := No_Uint) return Node_Id
is
Val : Node_Id;
- Typ : Node_Id;
Result : Node_Id;
Val_RE : RE_Id;
+ Size_To_Use : Uint;
+ -- This is the size to be used for computation of the appropriate
+ -- initial value for the Normalize_Scalars and Initialize_Scalars case.
+
+ Lo_Bound : Uint;
+ Hi_Bound : Uint;
+ -- These are the values computed by the procedure Check_Subtype_Bounds
+
+ procedure Check_Subtype_Bounds;
+ -- This procedure examines the subtype T, and its ancestor subtypes and
+ -- derived types to determine the best known information about the
+ -- bounds of the subtype. After the call Lo_Bound is set either to
+ -- No_Uint if no information can be determined, or to a value which
+ -- represents a known low bound, i.e. a valid value of the subtype can
+ -- not be less than this value. Hi_Bound is similarly set to a known
+ -- high bound (valid value cannot be greater than this).
+
+ --------------------------
+ -- Check_Subtype_Bounds --
+ --------------------------
+
+ procedure Check_Subtype_Bounds is
+ ST1 : Entity_Id;
+ ST2 : Entity_Id;
+ Lo : Node_Id;
+ Hi : Node_Id;
+ Loval : Uint;
+ Hival : Uint;
+
+ begin
+ Lo_Bound := No_Uint;
+ Hi_Bound := No_Uint;
+
+ -- Loop to climb ancestor subtypes and derived types
+
+ ST1 := T;
+ loop
+ if not Is_Discrete_Type (ST1) then
+ return;
+ end if;
+
+ Lo := Type_Low_Bound (ST1);
+ Hi := Type_High_Bound (ST1);
+
+ if Compile_Time_Known_Value (Lo) then
+ Loval := Expr_Value (Lo);
+
+ if Lo_Bound = No_Uint or else Lo_Bound < Loval then
+ Lo_Bound := Loval;
+ end if;
+ end if;
+
+ if Compile_Time_Known_Value (Hi) then
+ Hival := Expr_Value (Hi);
+
+ if Hi_Bound = No_Uint or else Hi_Bound > Hival then
+ Hi_Bound := Hival;
+ end if;
+ end if;
+
+ ST2 := Ancestor_Subtype (ST1);
+
+ if No (ST2) then
+ ST2 := Etype (ST1);
+ end if;
+
+ exit when ST1 = ST2;
+ ST1 := ST2;
+ end loop;
+ end Check_Subtype_Bounds;
+
+ -- Start of processing for Get_Simple_Init_Val
+
begin
-- For a private type, we should always have an underlying type
-- (because this was already checked in Needs_Simple_Initialization).
- -- What we do is to get the value for the underlying type and then
- -- do an Unchecked_Convert to the private type.
+ -- What we do is to get the value for the underlying type and then do
+ -- an Unchecked_Convert to the private type.
if Is_Private_Type (T) then
- Val := Get_Simple_Init_Val (Underlying_Type (T), Loc);
+ Val := Get_Simple_Init_Val (Underlying_Type (T), Loc, Size);
- -- A special case, if the underlying value is null, then qualify
- -- it with the underlying type, so that the null is properly typed
- -- Similarly, if it is an aggregate it must be qualified, because
- -- an unchecked conversion does not provide a context for it.
+ -- A special case, if the underlying value is null, then qualify it
+ -- with the underlying type, so that the null is properly typed
+ -- Similarly, if it is an aggregate it must be qualified, because an
+ -- unchecked conversion does not provide a context for it.
if Nkind (Val) = N_Null
or else Nkind (Val) = N_Aggregate
elsif Is_Scalar_Type (T) then
pragma Assert (Init_Or_Norm_Scalars);
+ -- Compute size of object. If it is given by the caller, we can use
+ -- it directly, otherwise we use Esize (T) as an estimate. As far as
+ -- we know this covers all cases correctly.
+
+ if Size = No_Uint or else Size <= Uint_0 then
+ Size_To_Use := UI_Max (Uint_1, Esize (T));
+ else
+ Size_To_Use := Size;
+ end if;
+
+ -- Maximum size to use is 64 bits, since we will create values
+ -- of type Unsigned_64 and the range must fit this type.
+
+ if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then
+ Size_To_Use := Uint_64;
+ end if;
+
+ -- Check known bounds of subtype
+
+ Check_Subtype_Bounds;
+
-- Processing for Normalize_Scalars case
if Normalize_Scalars then
- -- First prepare a value (out of subtype range if possible)
+ -- If zero is invalid, it is a convenient value to use that is
+ -- for sure an appropriate invalid value in all situations.
- if Is_Real_Type (T) or else Is_Integer_Type (T) then
- Val :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Base_Type (T), Loc),
- Attribute_Name => Name_First);
+ if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
+ Val := Make_Integer_Literal (Loc, 0);
- elsif Is_Modular_Integer_Type (T) then
- Val :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Base_Type (T), Loc),
- Attribute_Name => Name_Last);
+ -- Cases where all one bits is the appropriate invalid value
+
+ -- For modular types, all 1 bits is either invalid or valid. If
+ -- it is valid, then there is nothing that can be done since there
+ -- are no invalid values (we ruled out zero already).
+
+ -- For signed integer types that have no negative values, either
+ -- there is room for negative values, or there is not. If there
+ -- is, then all 1 bits may be interpretecd as minus one, which is
+ -- certainly invalid. Alternatively it is treated as the largest
+ -- positive value, in which case the observation for modular types
+ -- still applies.
+
+ -- For float types, all 1-bits is a NaN (not a number), which is
+ -- certainly an appropriately invalid value.
+
+ elsif Is_Unsigned_Type (T)
+ or else Is_Floating_Point_Type (T)
+ or else Is_Enumeration_Type (T)
+ then
+ Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1);
+
+ -- Resolve as Unsigned_64, because the largest number we
+ -- can generate is out of range of universal integer.
+
+ Analyze_And_Resolve (Val, RTE (RE_Unsigned_64));
+
+ -- Case of signed types
else
- pragma Assert (Is_Enumeration_Type (T));
-
- if Esize (T) <= 8 then
- Typ := RTE (RE_Unsigned_8);
- elsif Esize (T) <= 16 then
- Typ := RTE (RE_Unsigned_16);
- elsif Esize (T) <= 32 then
- Typ := RTE (RE_Unsigned_32);
- else
- Typ := RTE (RE_Unsigned_64);
- end if;
+ declare
+ Signed_Size : constant Uint :=
+ UI_Min (Uint_63, Size_To_Use - 1);
+
+ begin
+ -- Normally we like to use the most negative number. The
+ -- one exception is when this number is in the known
+ -- subtype range and the largest positive number is not in
+ -- the known subtype range.
+
+ -- For this exceptional case, use largest positive value
- Val :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
- Attribute_Name => Name_Last);
+ if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint
+ and then Lo_Bound <= (-(2 ** Signed_Size))
+ and then Hi_Bound < 2 ** Signed_Size
+ then
+ Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1);
+
+ -- Normal case of largest negative value
+
+ else
+ Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size));
+ end if;
+ end;
end if;
-- Here for Initialize_Scalars case
else
+ -- For float types, use float values from System.Scalar_Values
+
if Is_Floating_Point_Type (T) then
if Root_Type (T) = Standard_Short_Float then
Val_RE := RE_IS_Isf;
Val_RE := RE_IS_Ill;
end if;
- elsif Is_Unsigned_Type (Base_Type (T)) then
- if Esize (T) = 8 then
+ -- If zero is invalid, use zero values from System.Scalar_Values
+
+ elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
+ if Size_To_Use <= 8 then
+ Val_RE := RE_IS_Iz1;
+ elsif Size_To_Use <= 16 then
+ Val_RE := RE_IS_Iz2;
+ elsif Size_To_Use <= 32 then
+ Val_RE := RE_IS_Iz4;
+ else
+ Val_RE := RE_IS_Iz8;
+ end if;
+
+ -- For unsigned, use unsigned values from System.Scalar_Values
+
+ elsif Is_Unsigned_Type (T) then
+ if Size_To_Use <= 8 then
Val_RE := RE_IS_Iu1;
- elsif Esize (T) = 16 then
+ elsif Size_To_Use <= 16 then
Val_RE := RE_IS_Iu2;
- elsif Esize (T) = 32 then
+ elsif Size_To_Use <= 32 then
Val_RE := RE_IS_Iu4;
- else pragma Assert (Esize (T) = 64);
+ else
Val_RE := RE_IS_Iu8;
end if;
- else -- signed type
- if Esize (T) = 8 then
+ -- For signed, use signed values from System.Scalar_Values
+
+ else
+ if Size_To_Use <= 8 then
Val_RE := RE_IS_Is1;
- elsif Esize (T) = 16 then
+ elsif Size_To_Use <= 16 then
Val_RE := RE_IS_Is2;
- elsif Esize (T) = 32 then
+ elsif Size_To_Use <= 32 then
Val_RE := RE_IS_Is4;
- else pragma Assert (Esize (T) = 64);
+ else
Val_RE := RE_IS_Is8;
end if;
end if;
Val := New_Occurrence_Of (RTE (Val_RE), Loc);
end if;
- -- The final expression is obtained by doing an unchecked
- -- conversion of this result to the base type of the
- -- required subtype. We use the base type to avoid the
- -- unchecked conversion from chopping bits, and then we
- -- set Kill_Range_Check to preserve the "bad" value.
+ -- The final expression is obtained by doing an unchecked conversion
+ -- of this result to the base type of the required subtype. We use
+ -- the base type to avoid the unchecked conversion from chopping
+ -- bits, and then we set Kill_Range_Check to preserve the "bad"
+ -- value.
Result := Unchecked_Convert_To (Base_Type (T), Val);
return Result;
- -- String or Wide_String (must have Initialize_Scalars set)
+ -- String or Wide_[Wide]_String (must have Initialize_Scalars set)
elsif Root_Type (T) = Standard_String
or else
Root_Type (T) = Standard_Wide_String
+ or else
+ Root_Type (T) = Standard_Wide_Wide_String
then
pragma Assert (Init_Or_Norm_Scalars);
Choices => New_List (
Make_Others_Choice (Loc)),
Expression =>
- Get_Simple_Init_Val (Component_Type (T), Loc))));
+ Get_Simple_Init_Val
+ (Component_Type (T), Loc, Esize (Root_Type (T))))));
-- Access type is initialized to null
return
Make_Null (Loc);
- -- We initialize modular packed bit arrays to zero, to make sure that
- -- unused bits are zero, as required (see spec of Exp_Pakd). Also note
- -- that this improves gigi code, since the value tracing knows that
- -- all bits of the variable start out at zero. The value of zero has
- -- to be unchecked converted to the proper array type.
-
- elsif Is_Bit_Packed_Array (T) then
- declare
- PAT : constant Entity_Id := Packed_Array_Type (T);
- Nod : Node_Id;
-
- begin
- pragma Assert (Is_Modular_Integer_Type (PAT));
-
- Nod :=
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (T, Loc),
- Expression => Make_Integer_Literal (Loc, 0));
-
- Set_Etype (Expression (Nod), PAT);
- return Nod;
- end;
-
-- No other possibilities should arise, since we should only be
-- calling Get_Simple_Init_Val if Needs_Simple_Initialization
-- returned True, indicating one of the above cases held.
-- when Vn => <Make_Eq_Case> on subcomponents
-- end case;
- function Make_Eq_Case (Node : Node_Id; CL : Node_Id) return List_Id is
- Loc : constant Source_Ptr := Sloc (Node);
+ function Make_Eq_Case
+ (E : Entity_Id;
+ CL : Node_Id;
+ Discr : Entity_Id := Empty) return List_Id
+ is
+ Loc : constant Source_Ptr := Sloc (E);
Result : constant List_Id := New_List;
Variant : Node_Id;
Alt_List : List_Id;
begin
- Append_To (Result, Make_Eq_If (Node, Component_Items (CL)));
+ Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
if No (Variant_Part (CL)) then
return Result;
Append_To (Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
- Statements => Make_Eq_Case (Node, Component_List (Variant))));
+ Statements => Make_Eq_Case (E, Component_List (Variant))));
Next_Non_Pragma (Variant);
end loop;
- Append_To (Result,
- Make_Case_Statement (Loc,
- Expression =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_X),
- Selector_Name => New_Copy (Name (Variant_Part (CL)))),
- Alternatives => Alt_List));
+ -- If we have an Unchecked_Union, use one of the parameters that
+ -- captures the discriminants.
+
+ if Is_Unchecked_Union (E) then
+ Append_To (Result,
+ Make_Case_Statement (Loc,
+ Expression => New_Reference_To (Discr, Loc),
+ Alternatives => Alt_List));
+
+ else
+ Append_To (Result,
+ Make_Case_Statement (Loc,
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_X),
+ Selector_Name => New_Copy (Name (Variant_Part (CL)))),
+ Alternatives => Alt_List));
+ end if;
return Result;
end Make_Eq_Case;
-- or a null statement if the list L is empty
- function Make_Eq_If (Node : Node_Id; L : List_Id) return Node_Id is
- Loc : constant Source_Ptr := Sloc (Node);
+ function Make_Eq_If
+ (E : Entity_Id;
+ L : List_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (E);
C : Node_Id;
Field_Name : Name_Id;
Cond : Node_Id;
else
return
- Make_Implicit_If_Statement (Node,
+ Make_Implicit_If_Statement (E,
Condition => Cond,
Then_Statements => New_List (
Make_Return_Statement (Loc,
begin
Renamed_Eq := Empty;
- -- Spec of _Alignment
+ -- Spec of _Size
Append_To (Res, Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
- Name => Name_uAlignment,
+ Name => Name_uSize,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
- Ret_Type => Standard_Integer));
+ Ret_Type => Standard_Long_Long_Integer));
- -- Spec of _Size
+ -- Spec of _Alignment
Append_To (Res, Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
- Name => Name_uSize,
+ Name => Name_uAlignment,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
- Ret_Type => Standard_Long_Long_Integer));
-
- -- Specs for dispatching stream attributes. We skip these for limited
- -- types, since there is no question of dispatching in the limited case.
+ Ret_Type => Standard_Integer));
- -- We also skip these operations if dispatching is not available
- -- or if streams are not available (since what's the point?)
+ -- Specs for dispatching stream attributes
- if not Is_Limited_Type (Tag_Typ)
- and then RTE_Available (RE_Tag)
- and then RTE_Available (RE_Root_Stream_Type)
- then
- Append_To (Res,
- Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Read));
- Append_To (Res,
- Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Write));
- Append_To (Res,
- Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Input));
- Append_To (Res,
- Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Output));
- end if;
+ declare
+ Stream_Op_TSS_Names :
+ constant array (Integer range <>) of TSS_Name_Type :=
+ (TSS_Stream_Read,
+ TSS_Stream_Write,
+ TSS_Stream_Input,
+ TSS_Stream_Output);
+ begin
+ for Op in Stream_Op_TSS_Names'Range loop
+ if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then
+ Append_To (Res,
+ Predef_Stream_Attr_Spec (Loc, Tag_Typ,
+ Stream_Op_TSS_Names (Op)));
+ end if;
+ end loop;
+ end;
-- Spec of "=" if expanded if the type is not limited and if a
-- user defined "=" was not already declared for the non-full
N_Subprogram_Renaming_Declaration)
and then Etype (First_Formal (Node (Prim))) =
Etype (Next_Formal (First_Formal (Node (Prim))))
+ and then Base_Type (Etype (Node (Prim))) = Standard_Boolean
then
Eq_Needed := False;
Parameter_Type => New_Reference_To (Tag_Typ, Loc)))));
end if;
+ -- Generate the declarations for the following primitive operations:
+ -- disp_asynchronous_select
+ -- disp_conditional_select
+ -- disp_get_prim_op_kind
+ -- disp_timed_select
+ -- for limited interfaces and tagged types that implement a limited
+ -- interface.
+
+ if Ada_Version >= Ada_05
+ and then
+ ((Is_Interface (Tag_Typ)
+ and then Is_Limited_Record (Tag_Typ))
+ or else
+ (not Is_Abstract (Tag_Typ)
+ and then not Is_Controlled (Tag_Typ)
+ and then Implements_Limited_Interface (Tag_Typ)))
+ then
+ if Is_Interface (Tag_Typ) then
+ Append_To (Res,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Conditional_Select_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Timed_Select_Spec (Tag_Typ)));
+
+ else
+ Append_To (Res,
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Conditional_Select_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Timed_Select_Spec (Tag_Typ)));
+ end if;
+ end if;
+
-- Specs for finalization actions that may be required in case a
-- future extension contain a controlled element. We generate those
-- only for root tagged types where they will get dummy bodies or
-- We also skip these if finalization is not available
- elsif Restrictions (No_Finalization) then
+ elsif Restriction_Active (No_Finalization) then
null;
elsif Etype (Tag_Typ) = Tag_Typ or else Controlled_Type (Tag_Typ) then
elsif Is_Access_Type (T)
or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T)))
-
- or else (Is_Bit_Packed_Array (T)
- and then Is_Modular_Integer_Type (Packed_Array_Type (T)))
then
return True;
elsif Init_Or_Norm_Scalars
and then
(Root_Type (T) = Standard_String
- or else Root_Type (T) = Standard_Wide_String)
+ or else Root_Type (T) = Standard_Wide_String
+ or else Root_Type (T) = Standard_Wide_Wide_String)
and then
(not Is_Itype (T)
or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate)
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : TSS_Name_Type;
- For_Body : Boolean := False)
- return Node_Id
+ For_Body : Boolean := False) return Node_Id
is
Prof : List_Id;
Type_B : Entity_Id;
Name : Name_Id;
Profile : List_Id;
Ret_Type : Entity_Id := Empty;
- For_Body : Boolean := False)
- return Node_Id
+ For_Body : Boolean := False) return Node_Id
is
Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name);
Spec : Node_Id;
Make_Function_Specification (Loc,
Defining_Unit_Name => Id,
Parameter_Specifications => Profile,
- Subtype_Mark =>
+ Result_Definition =>
New_Reference_To (Ret_Type, Loc));
end if;
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : TSS_Name_Type;
- For_Body : Boolean := False)
- return Node_Id
+ For_Body : Boolean := False) return Node_Id
is
Ret_Type : Entity_Id;
function Predefined_Primitive_Bodies
(Tag_Typ : Entity_Id;
- Renamed_Eq : Node_Id)
- return List_Id
+ Renamed_Eq : Node_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Tag_Typ);
Res : constant List_Id := New_List;
-- Bodies for Dispatching stream IO routines. We need these only for
-- non-limited types (in the limited case there is no dispatching).
- -- We also skip them if dispatching is not available.
+ -- We also skip them if dispatching or finalization are not available.
+
+ if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read)
+ and then No (TSS (Tag_Typ, TSS_Stream_Read))
+ then
+ Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
+ Append_To (Res, Decl);
+ end if;
- if not Is_Limited_Type (Tag_Typ)
- and then not Restrictions (No_Finalization)
+ if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write)
+ and then No (TSS (Tag_Typ, TSS_Stream_Write))
then
- if No (TSS (Tag_Typ, TSS_Stream_Read)) then
- Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
+ Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
+ Append_To (Res, Decl);
+ end if;
+
+ -- Skip bodies of _Input and _Output for the abstract case, since
+ -- the corresponding specs are abstract (see Predef_Spec_Or_Body)
+
+ if not Is_Abstract (Tag_Typ) then
+ if Stream_Operation_OK (Tag_Typ, TSS_Stream_Input)
+ and then No (TSS (Tag_Typ, TSS_Stream_Input))
+ then
+ Build_Record_Or_Elementary_Input_Function
+ (Loc, Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
- if No (TSS (Tag_Typ, TSS_Stream_Write)) then
- Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
+ if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
+ and then No (TSS (Tag_Typ, TSS_Stream_Output))
+ then
+ Build_Record_Or_Elementary_Output_Procedure
+ (Loc, Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
+ end if;
- -- Skip bodies of _Input and _Output for the abstract case, since
- -- the corresponding specs are abstract (see Predef_Spec_Or_Body)
-
- if not Is_Abstract (Tag_Typ) then
- if No (TSS (Tag_Typ, TSS_Stream_Input)) then
- Build_Record_Or_Elementary_Input_Function
- (Loc, Tag_Typ, Decl, Ent);
- Append_To (Res, Decl);
- end if;
-
- if No (TSS (Tag_Typ, TSS_Stream_Output)) then
- Build_Record_Or_Elementary_Output_Procedure
- (Loc, Tag_Typ, Decl, Ent);
- Append_To (Res, Decl);
- end if;
- end if;
+ -- Generate the bodies for the following primitive operations:
+ -- disp_asynchronous_select
+ -- disp_conditional_select
+ -- disp_get_prim_op_kind
+ -- disp_timed_select
+ -- for tagged types that implement a limited interface.
+
+ if Ada_Version >= Ada_05
+ and then not Is_Interface (Tag_Typ)
+ and then not Is_Abstract (Tag_Typ)
+ and then not Is_Controlled (Tag_Typ)
+ and then Implements_Limited_Interface (Tag_Typ)
+ then
+ Append_To (Res,
+ Make_Disp_Asynchronous_Select_Body (Tag_Typ));
+ Append_To (Res,
+ Make_Disp_Conditional_Select_Body (Tag_Typ));
+ Append_To (Res,
+ Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ));
+ Append_To (Res,
+ Make_Disp_Timed_Select_Body (Tag_Typ));
end if;
if not Is_Limited_Type (Tag_Typ) then
-- Skip this if finalization is not available
- elsif Restrictions (No_Finalization) then
+ elsif Restriction_Active (No_Finalization) then
null;
elsif (Etype (Tag_Typ) = Tag_Typ or else Is_Controlled (Tag_Typ))
return Res;
end Predefined_Primitive_Freeze;
+
+ -------------------------
+ -- Stream_Operation_OK --
+ -------------------------
+
+ function Stream_Operation_OK
+ (Typ : Entity_Id;
+ Operation : TSS_Name_Type) return Boolean
+ is
+ Has_Inheritable_Stream_Attribute : Boolean := False;
+
+ begin
+ if Is_Limited_Type (Typ)
+ and then Is_Tagged_Type (Typ)
+ and then Is_Derived_Type (Typ)
+ then
+ -- Special case of a limited type extension: a default implementation
+ -- of the stream attributes Read and Write exists if the attribute
+ -- has been specified for an ancestor type.
+
+ Has_Inheritable_Stream_Attribute :=
+ Present (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
+ end if;
+
+ return
+ not (Is_Limited_Type (Typ)
+ and then not Has_Inheritable_Stream_Attribute)
+ and then RTE_Available (RE_Tag)
+ and then RTE_Available (RE_Root_Stream_Type)
+ and then not Restriction_Active (No_Dispatch)
+ and then not Restriction_Active (No_Streams);
+ end Stream_Operation_OK;
end Exp_Ch3;
OSDN Git Service
