diff options
| author | Richard Kenner <kenner@gcc.gnu.org> | 2001-10-02 10:08:34 -0400 |
|---|---|---|
| committer | Richard Kenner <kenner@gcc.gnu.org> | 2001-10-02 10:08:34 -0400 |
| commit | 70482933d8f6a73b660f4cfa97b5c7c9deaf152e (patch) | |
| tree | 133a71d6793865f2028234c0125afcfa4c7afc76 /gcc/ada/exp_ch3.adb | |
| parent | d23b8f573b3dcbfc04d13387885059de809aec50 (diff) | |
| download | gcc-70482933d8f6a73b660f4cfa97b5c7c9deaf152e.zip gcc-70482933d8f6a73b660f4cfa97b5c7c9deaf152e.tar.gz gcc-70482933d8f6a73b660f4cfa97b5c7c9deaf152e.tar.bz2 | |
New Language: Ada
From-SVN: r45954
Diffstat (limited to 'gcc/ada/exp_ch3.adb')
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 5200 |
1 files changed, 5200 insertions, 0 deletions
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb new file mode 100644 index 0000000..76520cf --- /dev/null +++ b/gcc/ada/exp_ch3.adb @@ -0,0 +1,5200 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 3 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.481 $ +-- -- +-- Copyright (C) 1992-2001 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- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- 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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Elists; use Elists; +with Exp_Aggr; use Exp_Aggr; +with Exp_Ch4; use Exp_Ch4; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch9; use Exp_Ch9; +with Exp_Ch11; use Exp_Ch11; +with Exp_Disp; use Exp_Disp; +with Exp_Dist; use Exp_Dist; +with Exp_Smem; use Exp_Smem; +with Exp_Strm; use Exp_Strm; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Hostparm; use Hostparm; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch8; use Sem_Ch8; +with Sem_Eval; use Sem_Eval; +with Sem_Mech; use Sem_Mech; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Stand; use Stand; +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 + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Adjust_Discriminants (Rtype : Entity_Id); + -- This is used when freezing a record type. It attempts to construct + -- more restrictive subtypes for discriminants so that the max size of + -- the record can be calculated more accurately. See the body of this + -- procedure for details. + + procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id); + -- Build initialization procedure for given array type. Nod is a node + -- used for attachment of any actions required in its construction. + -- It also supplies the source location used for the procedure. + + procedure Build_Class_Wide_Master (T : Entity_Id); + -- for access to class-wide limited types we must build a task master + -- because some subsequent extension may add a task component. To avoid + -- bringing in the tasking run-time whenever an access-to-class-wide + -- limited type is used, we use the soft-link mechanism and add a level + -- of indirection to calls to routines that manipulate Master_Ids. + + function Build_Discriminant_Formals + (Rec_Id : Entity_Id; + Use_Dl : Boolean) + return List_Id; + -- 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 + -- of the type. Otherwise new identifiers are created, with the source + -- names of the discriminants. + + procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id); + -- If the designated type of an access type is a task type or contains + -- tasks, we make sure that a _Master variable is declared in the current + -- scope, and then declare a renaming for it: + -- + -- atypeM : Master_Id renames _Master; + -- + -- where atyp is the name of the access type. This declaration is + -- used when an allocator for the access type is expanded. The node N + -- is the full declaration of the designated type that contains tasks. + -- The renaming declaration is inserted before N, and after the Master + -- declaration. + + procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id); + -- Build record initialization procedure. N is the type declaration + -- node, and Pe is the corresponding entity for the record type. + + 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 Expand_Tagged_Root (T : Entity_Id); + -- Add a field _Tag at the beginning of the record. This field carries + -- the value of the access to the Dispatch table. This procedure is only + -- called on root (non CPP_Class) types, the _Tag field being inherited + -- by the descendants. + + procedure Expand_Record_Controller (T : Entity_Id); + -- T must be a record type that Has_Controlled_Component. Add a field _C + -- of type Record_Controller or Limited_Record_Controller in the record T. + + procedure Freeze_Array_Type (N : Node_Id); + -- Freeze an array type. Deals with building the initialization procedure, + -- creating the packed array type for a packed array and also with the + -- creation of the controlling procedures for the controlled case. The + -- argument N is the N_Freeze_Entity node for the type. + + procedure Freeze_Enumeration_Type (N : Node_Id); + -- Freeze enumeration type with non-standard representation. Builds the + -- array and function needed to convert between enumeration pos and + -- enumeration representation values. N is the N_Freeze_Entity node + -- for the type. + + procedure Freeze_Record_Type (N : Node_Id); + -- Freeze record type. Builds all necessary discriminant checking + -- and other ancillary functions, and builds dispatch tables where + -- needed. The argument N is the N_Freeze_Entity node. This processing + -- applies only to E_Record_Type entities, not to class wide types, + -- record subtypes, or private types. + + function Init_Formals (Typ : Entity_Id) return List_Id; + -- This function builds the list of formals for an initialization routine. + -- The first formal is always _Init with the given type. For task value + -- record types and types containing tasks, three additional formals are + -- added: + -- + -- _Master : Master_Id + -- _Chain : in out Activation_Chain + -- _Task_Id : Task_Image_Type + -- + -- The caller must append additional entries for discriminants if required. + + function In_Runtime (E : Entity_Id) return Boolean; + -- 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; + -- 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. + + function Make_Eq_If (Node : Node_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. + + procedure Make_Predefined_Primitive_Specs + (Tag_Typ : Entity_Id; + Predef_List : out List_Id; + Renamed_Eq : out Node_Id); + -- Create a list with the specs of the predefined primitive operations. + -- This list contains _Size, _Read, _Write, _Input and _Output for + -- every tagged types, plus _equality, _assign, _deep_finalize and + -- _deep_adjust for non limited tagged types. _Size, _Read, _Write, + -- _Input and _Output implement the corresponding attributes that need + -- to be dispatching when their arguments are classwide. _equality and + -- _assign, implement equality and assignment that also must be + -- dispatching. _Deep_Finalize and _Deep_Adjust are empty procedures + -- unless the type contains some controlled components that require + -- finalization actions. The list is returned in Predef_List. The + -- parameter Renamed_Eq either returns the value Empty, or else the + -- defining unit name for the predefined equality function in the + -- case where the type has a primitive operation that is a renaming + -- of predefined equality (but only if there is also an overriding + -- user-defined equality function). The returned Renamed_Eq will be + -- passed to the corresponding parameter of Predefined_Primitive_Bodies. + + function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean; + -- returns True if there are representation clauses for type T that + -- are not inherited. If the result is false, the init_proc and the + -- discriminant_checking functions of the parent can be reused by + -- a derived type. + + function Predef_Spec_Or_Body + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : Name_Id; + Profile : List_Id; + Ret_Type : Entity_Id := Empty; + 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, + -- then the returned node is a subprogram declaration. If For_Body is + -- true, then the returned node is a empty subprogram body containing + -- no declarations and no statements. + + function Predef_Stream_Attr_Spec + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : Name_Id; + For_Body : Boolean := False) + return Node_Id; + -- Specialized version of Predef_Spec_Or_Body that apply to _read, _write, + -- _input and _output whose specs are constructed in Exp_Strm. + + function Predef_Deep_Spec + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : Name_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; + -- 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 + -- by Make_Predefined_Primitive_Specs. + + function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id; + -- Freeze entities of all predefined primitive operations. This is needed + -- because the bodies of these operations do not normally do any freezeing. + + -------------------------- + -- Adjust_Discriminants -- + -------------------------- + + -- This procedure attempts to define subtypes for discriminants that + -- are more restrictive than those declared. Such a replacement is + -- possible if we can demonstrate that values outside the restricted + -- range would cause constraint errors in any case. The advantage of + -- restricting the discriminant types in this way is tha the maximum + -- size of the variant record can be calculated more conservatively. + + -- An example of a situation in which we can perform this type of + -- restriction is the following: + + -- subtype B is range 1 .. 10; + -- type Q is array (B range <>) of Integer; + + -- type V (N : Natural) is record + -- C : Q (1 .. N); + -- end record; + + -- In this situation, we can restrict the upper bound of N to 10, since + -- any larger value would cause a constraint error in any case. + + -- There are many situations in which such restriction is possible, but + -- for now, we just look for cases like the above, where the component + -- in question is a one dimensional array whose upper bound is one of + -- the record discriminants. Also the component must not be part of + -- any variant part, since then the component does not always exist. + + procedure Adjust_Discriminants (Rtype : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Rtype); + Comp : Entity_Id; + Ctyp : Entity_Id; + Ityp : Entity_Id; + Lo : Node_Id; + Hi : Node_Id; + P : Node_Id; + Loval : Uint; + Discr : Entity_Id; + Dtyp : Entity_Id; + Dhi : Node_Id; + Dhiv : Uint; + Ahi : Node_Id; + Ahiv : Uint; + Tnn : Entity_Id; + + begin + Comp := First_Component (Rtype); + while Present (Comp) loop + + -- If our parent is a variant, quit, we do not look at components + -- that are in variant parts, because they may not always exist. + + P := Parent (Comp); -- component declaration + P := Parent (P); -- component list + + exit when Nkind (Parent (P)) = N_Variant; + + -- We are looking for a one dimensional array type + + Ctyp := Etype (Comp); + + if not Is_Array_Type (Ctyp) + or else Number_Dimensions (Ctyp) > 1 + then + goto Continue; + end if; + + -- The lower bound must be constant, and the upper bound is a + -- discriminant (which is a discriminant of the current record). + + Ityp := Etype (First_Index (Ctyp)); + Lo := Type_Low_Bound (Ityp); + Hi := Type_High_Bound (Ityp); + + if not Compile_Time_Known_Value (Lo) + or else Nkind (Hi) /= N_Identifier + or else No (Entity (Hi)) + or else Ekind (Entity (Hi)) /= E_Discriminant + then + goto Continue; + end if; + + -- We have an array with appropriate bounds + + Loval := Expr_Value (Lo); + Discr := Entity (Hi); + Dtyp := Etype (Discr); + + -- See if the discriminant has a known upper bound + + Dhi := Type_High_Bound (Dtyp); + + if not Compile_Time_Known_Value (Dhi) then + goto Continue; + end if; + + Dhiv := Expr_Value (Dhi); + + -- See if base type of component array has known upper bound + + Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp)))); + + if not Compile_Time_Known_Value (Ahi) then + goto Continue; + end if; + + Ahiv := Expr_Value (Ahi); + + -- The condition for doing the restriction is that the high bound + -- of the discriminant is greater than the low bound of the array, + -- and is also greater than the high bound of the base type index. + + if Dhiv > Loval and then Dhiv > Ahiv then + + -- We can reset the upper bound of the discriminant type to + -- whichever is larger, the low bound of the component, or + -- the high bound of the base type array index. + + -- We build a subtype that is declared as + + -- subtype Tnn is discr_type range discr_type'First .. max; + + -- And insert this declaration into the tree. The type of the + -- discriminant is then reset to this more restricted subtype. + + Tnn := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + + Insert_Action (Declaration_Node (Rtype), + Make_Subtype_Declaration (Loc, + Defining_Identifier => Tnn, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Dtyp, Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => New_Occurrence_Of (Dtyp, Loc)), + High_Bound => + Make_Integer_Literal (Loc, + Intval => UI_Max (Loval, Ahiv))))))); + + Set_Etype (Discr, Tnn); + end if; + + <<Continue>> + Next_Component (Comp); + end loop; + + end Adjust_Discriminants; + + --------------------------- + -- Build_Array_Init_Proc -- + --------------------------- + + procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is + Loc : constant Source_Ptr := Sloc (Nod); + Comp_Type : constant Entity_Id := Component_Type (A_Type); + Index_List : List_Id; + Proc_Id : Entity_Id; + Proc_Body : Node_Id; + Body_Stmts : List_Id; + + function Init_Component return List_Id; + -- Create one statement to initialize one array component, designated + -- by a full set of indices. + + function Init_One_Dimension (N : Int) return List_Id; + -- Create loop to initialize one dimension of the array. The single + -- statement in the loop body initializes the inner dimensions if any, + -- or else the single component. Note that this procedure is called + -- recursively, with N being the dimension to be initialized. A call + -- with N greater than the number of dimensions simply generates the + -- component initialization, terminating the recursion. + + -------------------- + -- Init_Component -- + -------------------- + + function Init_Component return List_Id is + Comp : Node_Id; + + begin + Comp := + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Expressions => Index_List); + + if Needs_Simple_Initialization (Comp_Type) then + Set_Assignment_OK (Comp); + return New_List ( + Make_Assignment_Statement (Loc, + Name => Comp, + Expression => Get_Simple_Init_Val (Comp_Type, Loc))); + + else + return + Build_Initialization_Call (Loc, Comp, Comp_Type, True, A_Type); + end if; + end Init_Component; + + ------------------------ + -- Init_One_Dimension -- + ------------------------ + + function Init_One_Dimension (N : Int) return List_Id is + Index : Entity_Id; + + begin + -- If the component does not need initializing, then there is nothing + -- to do here, so we return a null body. This occurs when generating + -- the dummy Init_Proc needed for Initialize_Scalars processing. + + if not Has_Non_Null_Base_Init_Proc (Comp_Type) + and then not Needs_Simple_Initialization (Comp_Type) + and then not Has_Task (Comp_Type) + then + return New_List (Make_Null_Statement (Loc)); + + -- If all dimensions dealt with, we simply initialize the component + + elsif N > Number_Dimensions (A_Type) then + return Init_Component; + + -- Here we generate the required loop + + else + Index := + Make_Defining_Identifier (Loc, New_External_Name ('J', N)); + + Append (New_Reference_To (Index, Loc), Index_List); + + return New_List ( + Make_Implicit_Loop_Statement (Nod, + Identifier => Empty, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Index, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, N))))), + Statements => Init_One_Dimension (N + 1))); + end if; + end Init_One_Dimension; + + -- Start of processing for Build_Array_Init_Proc + + begin + if Suppress_Init_Proc (A_Type) then + return; + end if; + + Index_List := New_List; + + -- We need an initialization procedure if any of the following is true: + + -- 1. The component type has an initialization procedure + -- 2. The component type needs simple initialization + -- 3. Tasks are present + -- 4. The type is marked as a publc entity + + -- The reason for the public entity test is to deal properly with the + -- Initialize_Scalars pragma. This pragma can be set in the client and + -- not in the declaring package, this means the client will make a call + -- to the initialization procedure (because one of conditions 1-3 must + -- 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. + + if Has_Non_Null_Base_Init_Proc (Comp_Type) + or else Needs_Simple_Initialization (Comp_Type) + or else Has_Task (Comp_Type) + or else (Is_Public (A_Type) + and then Root_Type (A_Type) /= Standard_String + and then Root_Type (A_Type) /= Standard_Wide_String) + then + Proc_Id := + Make_Defining_Identifier (Loc, Name_uInit_Proc); + + Body_Stmts := Init_One_Dimension (1); + + Proc_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Id, + Parameter_Specifications => Init_Formals (A_Type)), + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Body_Stmts)); + + Set_Ekind (Proc_Id, E_Procedure); + Set_Is_Public (Proc_Id, Is_Public (A_Type)); + Set_Is_Inlined (Proc_Id); + Set_Is_Internal (Proc_Id); + Set_Has_Completion (Proc_Id); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Proc_Id); + end if; + + -- Associate Init_Proc with type, and determine if the procedure + -- is null (happens because of the Initialize_Scalars pragma case, + -- where we have to generate a null procedure in case it is called + -- by a client with Initialize_Scalars set). Such procedures have + -- to be generated, but do not have to be called, so we mark them + -- as null to suppress the call. + + Set_Init_Proc (A_Type, Proc_Id); + + if List_Length (Body_Stmts) = 1 + and then Nkind (First (Body_Stmts)) = N_Null_Statement + then + Set_Is_Null_Init_Proc (Proc_Id); + end if; + end if; + + end Build_Array_Init_Proc; + + ----------------------------- + -- Build_Class_Wide_Master -- + ----------------------------- + + procedure Build_Class_Wide_Master (T : Entity_Id) is + Loc : constant Source_Ptr := Sloc (T); + M_Id : Entity_Id; + Decl : Node_Id; + P : Node_Id; + + begin + -- Nothing to do if there is no task hierarchy. + + if Restrictions (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 + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uMaster), + Constant_Present => True, + Object_Definition => New_Reference_To (Standard_Integer, Loc), + Expression => + Make_Explicit_Dereference (Loc, + New_Reference_To (RTE (RE_Current_Master), Loc))); + + P := Parent (T); + Insert_Before (P, Decl); + Analyze (Decl); + Set_Has_Master_Entity (Scope (T)); + + -- Now mark the containing scope as a task master + + while Nkind (P) /= N_Compilation_Unit loop + P := Parent (P); + + -- If we fall off the top, we are at the outer level, and the + -- environment task is our effective master, so nothing to mark. + + if Nkind (P) = N_Task_Body + or else Nkind (P) = N_Block_Statement + or else Nkind (P) = N_Subprogram_Body + then + Set_Is_Task_Master (P, True); + exit; + end if; + end loop; + end if; + + -- Now define the renaming of the master_id. + + M_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (T), 'M')); + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => M_Id, + Subtype_Mark => New_Reference_To (Standard_Integer, Loc), + Name => Make_Identifier (Loc, Name_uMaster)); + Insert_Before (Parent (T), Decl); + Analyze (Decl); + + Set_Master_Id (T, M_Id); + end Build_Class_Wide_Master; + + -------------------------------- + -- Build_Discr_Checking_Funcs -- + -------------------------------- + + procedure Build_Discr_Checking_Funcs (N : Node_Id) is + Rec_Id : Entity_Id; + Loc : Source_Ptr; + Enclosing_Func_Id : Entity_Id; + Sequence : Nat := 1; + Type_Def : Node_Id; + V : Node_Id; + + function Build_Case_Statement + (Case_Id : Entity_Id; + Variant : Node_Id) + return Node_Id; + -- Need documentation for this spec ??? + + function Build_Dcheck_Function + (Case_Id : 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); + -- Builds the discriminant checking function for each variant of the + -- given variant part of the record type. + + -------------------------- + -- Build_Case_Statement -- + -------------------------- + + function Build_Case_Statement + (Case_Id : Entity_Id; + Variant : Node_Id) + return Node_Id + is + Actuals_List : List_Id; + Alt_List : List_Id := New_List; + Case_Node : Node_Id; + Case_Alt_Node : Node_Id; + Choice : Node_Id; + Choice_List : List_Id; + D : Entity_Id; + Return_Node : Node_Id; + + begin + -- 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 + -- generating the checks for. If the discriminant is one of these + -- return False. The other alternative consists of the choice + -- "Others" and will return True indicating the discriminant did + -- not match. + + Case_Node := New_Node (N_Case_Statement, Loc); + + -- Replace the discriminant which controls the variant, with the + -- name of the formal of the checking function. + + Set_Expression (Case_Node, + Make_Identifier (Loc, Chars (Case_Id))); + + Choice := First (Discrete_Choices (Variant)); + + if Nkind (Choice) = N_Others_Choice then + Choice_List := New_Copy_List (Others_Discrete_Choices (Choice)); + else + Choice_List := New_Copy_List (Discrete_Choices (Variant)); + end if; + + if not Is_Empty_List (Choice_List) then + Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); + Set_Discrete_Choices (Case_Alt_Node, Choice_List); + + -- In case this is a nested variant, we need to return the result + -- of the discriminant checking function for the immediately + -- enclosing variant. + + if Present (Enclosing_Func_Id) then + Actuals_List := New_List; + + D := First_Discriminant (Rec_Id); + while Present (D) loop + Append (Make_Identifier (Loc, Chars (D)), Actuals_List); + Next_Discriminant (D); + end loop; + + Return_Node := + Make_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + New_Reference_To (Enclosing_Func_Id, Loc), + Parameter_Associations => + Actuals_List)); + + else + Return_Node := + Make_Return_Statement (Loc, + Expression => + New_Reference_To (Standard_False, Loc)); + end if; + + Set_Statements (Case_Alt_Node, New_List (Return_Node)); + Append (Case_Alt_Node, Alt_List); + end if; + + Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); + Choice_List := New_List (New_Node (N_Others_Choice, Loc)); + Set_Discrete_Choices (Case_Alt_Node, Choice_List); + + Return_Node := + Make_Return_Statement (Loc, + Expression => + New_Reference_To (Standard_True, Loc)); + + Set_Statements (Case_Alt_Node, New_List (Return_Node)); + Append (Case_Alt_Node, Alt_List); + + Set_Alternatives (Case_Node, Alt_List); + return Case_Node; + end Build_Case_Statement; + + --------------------------- + -- Build_Dcheck_Function -- + --------------------------- + + function Build_Dcheck_Function + (Case_Id : Entity_Id; + Variant : Node_Id) + return Entity_Id + is + Body_Node : Node_Id; + Func_Id : Entity_Id; + Parameter_List : List_Id; + Spec_Node : Node_Id; + + begin + Body_Node := New_Node (N_Subprogram_Body, Loc); + Sequence := Sequence + 1; + + Func_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence)); + + Spec_Node := New_Node (N_Function_Specification, Loc); + Set_Defining_Unit_Name (Spec_Node, Func_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_Specification (Body_Node, Spec_Node); + Set_Declarations (Body_Node, New_List); + + Set_Handled_Statement_Sequence (Body_Node, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Build_Case_Statement (Case_Id, Variant)))); + + Set_Ekind (Func_Id, E_Function); + Set_Mechanism (Func_Id, Default_Mechanism); + Set_Is_Inlined (Func_Id, True); + Set_Is_Pure (Func_Id, True); + Set_Is_Public (Func_Id, Is_Public (Rec_Id)); + Set_Is_Internal (Func_Id, True); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Func_Id); + end if; + + Append_Freeze_Action (Rec_Id, Body_Node); + Set_Dcheck_Function (Variant, Func_Id); + return Func_Id; + end Build_Dcheck_Function; + + ---------------------------- + -- Build_Dcheck_Functions -- + ---------------------------- + + procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is + Component_List_Node : Node_Id; + Decl : Entity_Id; + Discr_Name : Entity_Id; + Func_Id : Entity_Id; + Variant : Node_Id; + Saved_Enclosing_Func_Id : Entity_Id; + + begin + -- Build the discriminant checking function for each variant, label + -- all components of that variant with the function's name. + + Discr_Name := Entity (Name (Variant_Part_Node)); + Variant := First_Non_Pragma (Variants (Variant_Part_Node)); + + while Present (Variant) loop + Func_Id := Build_Dcheck_Function (Discr_Name, Variant); + Component_List_Node := Component_List (Variant); + + if not Null_Present (Component_List_Node) then + Decl := + First_Non_Pragma (Component_Items (Component_List_Node)); + + while Present (Decl) loop + Set_Discriminant_Checking_Func + (Defining_Identifier (Decl), Func_Id); + + Next_Non_Pragma (Decl); + end loop; + + if Present (Variant_Part (Component_List_Node)) then + Saved_Enclosing_Func_Id := Enclosing_Func_Id; + Enclosing_Func_Id := Func_Id; + Build_Dcheck_Functions (Variant_Part (Component_List_Node)); + Enclosing_Func_Id := Saved_Enclosing_Func_Id; + end if; + end if; + + Next_Non_Pragma (Variant); + end loop; + end Build_Dcheck_Functions; + + -- Start of processing for Build_Discr_Checking_Funcs + + begin + -- Only build if not done already + + if not Discr_Check_Funcs_Built (N) then + Type_Def := Type_Definition (N); + + if Nkind (Type_Def) = N_Record_Definition then + if No (Component_List (Type_Def)) then -- null record. + return; + else + V := Variant_Part (Component_List (Type_Def)); + end if; + + else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition); + if No (Component_List (Record_Extension_Part (Type_Def))) then + return; + else + V := Variant_Part + (Component_List (Record_Extension_Part (Type_Def))); + end if; + end if; + + Rec_Id := Defining_Identifier (N); + + if Present (V) and then not Is_Unchecked_Union (Rec_Id) then + Loc := Sloc (N); + Enclosing_Func_Id := Empty; + Build_Dcheck_Functions (V); + end if; + + Set_Discr_Check_Funcs_Built (N); + end if; + end Build_Discr_Checking_Funcs; + + -------------------------------- + -- Build_Discriminant_Formals -- + -------------------------------- + + function Build_Discriminant_Formals + (Rec_Id : Entity_Id; + Use_Dl : Boolean) + return List_Id + is + D : Entity_Id; + Formal : Entity_Id; + Loc : Source_Ptr := Sloc (Rec_Id); + Param_Spec_Node : Node_Id; + Parameter_List : List_Id := New_List; + + begin + if Has_Discriminants (Rec_Id) then + D := First_Discriminant (Rec_Id); + + while Present (D) loop + Loc := Sloc (D); + + if Use_Dl then + Formal := Discriminal (D); + else + Formal := Make_Defining_Identifier (Loc, Chars (D)); + end if; + + Param_Spec_Node := + Make_Parameter_Specification (Loc, + Defining_Identifier => Formal, + Parameter_Type => + New_Reference_To (Etype (D), Loc)); + Append (Param_Spec_Node, Parameter_List); + Next_Discriminant (D); + end loop; + end if; + + return Parameter_List; + end Build_Discriminant_Formals; + + ------------------------------- + -- Build_Initialization_Call -- + ------------------------------- + + -- References to a discriminant inside the record type declaration + -- can appear either in the subtype_indication to constrain a + -- record or an array, or as part of a larger expression given for + -- the initial value of a component. In both of these cases N appears + -- in the record initialization procedure and needs to be replaced by + -- the formal parameter of the initialization procedure which + -- corresponds to that discriminant. + + -- In the example below, references to discriminants D1 and D2 in proc_1 + -- are replaced by references to formals with the same name + -- (discriminals) + + -- A similar replacement is done for calls to any record + -- initialization procedure for any components that are themselves + -- of a record type. + + -- type R (D1, D2 : Integer) is record + -- X : Integer := F * D1; + -- Y : Integer := F * D2; + -- end record; + + -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is + -- begin + -- Out_2.D1 := D1; + -- Out_2.D2 := D2; + -- Out_2.X := F * D1; + -- Out_2.Y := F * D2; + -- end; + + function Build_Initialization_Call + (Loc : Source_Ptr; + Id_Ref : Node_Id; + Typ : Entity_Id; + In_Init_Proc : Boolean := False; + Enclos_Type : Entity_Id := Empty; + Discr_Map : Elist_Id := New_Elmt_List) + return List_Id + is + First_Arg : Node_Id; + Args : List_Id; + Decls : List_Id; + Decl : Node_Id; + Discr : Entity_Id; + Arg : Node_Id; + Proc : constant Entity_Id := Base_Init_Proc (Typ); + Init_Type : constant Entity_Id := Etype (First_Formal (Proc)); + Full_Init_Type : constant Entity_Id := Underlying_Type (Init_Type); + Res : List_Id := New_List; + Full_Type : Entity_Id := Typ; + Controller_Typ : Entity_Id; + + begin + -- Nothing to do if the Init_Proc is null, unless Initialize_Sclalars + -- is active (in which case we make the call anyway, since in the + -- actual compiled client it may be non null). + + if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then + return Empty_List; + end if; + + -- Go to full view if private type + + if Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + then + Full_Type := Full_View (Typ); + end if; + + -- If Typ is derived, the procedure is the initialization procedure for + -- the root type. Wrap the argument in an conversion to make it type + -- honest. Actually it isn't quite type honest, because there can be + -- conflicts of views in the private type case. That is why we set + -- Conversion_OK in the conversion node. + + if (Is_Record_Type (Typ) + or else Is_Array_Type (Typ) + or else Is_Private_Type (Typ)) + and then Init_Type /= Base_Type (Typ) + then + First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref); + Set_Etype (First_Arg, Init_Type); + + else + First_Arg := Id_Ref; + end if; + + Args := New_List (Convert_Concurrent (First_Arg, Typ)); + + -- In the tasks case, add _Master as the value of the _Master parameter + -- and _Chain as the value of the _Chain parameter. At the outer level, + -- these will be variables holding the corresponding values obtained + -- from GNARL. At inner levels, they will be the parameters passed down + -- through the outer routines. + + if Has_Task (Full_Type) then + if Restrictions (No_Task_Hierarchy) then + + -- See comments in System.Tasking.Initialization.Init_RTS + -- for the value 3. + + Append_To (Args, Make_Integer_Literal (Loc, 3)); + else + Append_To (Args, Make_Identifier (Loc, Name_uMaster)); + end if; + + Append_To (Args, Make_Identifier (Loc, Name_uChain)); + + Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type); + Decl := Last (Decls); + + Append_To (Args, + New_Occurrence_Of (Defining_Identifier (Decl), Loc)); + Append_List (Decls, Res); + + else + Decls := No_List; + Decl := Empty; + end if; + + -- Add discriminant values if discriminants are present + + if Has_Discriminants (Full_Init_Type) then + Discr := First_Discriminant (Full_Init_Type); + + while Present (Discr) loop + + -- If this is a discriminated concurrent type, the init_proc + -- for the corresponding record is being called. Use that + -- type directly to find the discriminant value, to handle + -- properly intervening renamed discriminants. + + declare + T : Entity_Id := Full_Type; + + begin + if Is_Protected_Type (T) then + T := Corresponding_Record_Type (T); + end if; + + Arg := + Get_Discriminant_Value ( + Discr, + T, + Discriminant_Constraint (Full_Type)); + end; + + if In_Init_Proc then + + -- Replace any possible references to the discriminant in the + -- call to the record initialization procedure with references + -- to the appropriate formal parameter. + + if Nkind (Arg) = N_Identifier + and then Ekind (Entity (Arg)) = E_Discriminant + then + Arg := New_Reference_To (Discriminal (Entity (Arg)), Loc); + + -- Case of access discriminants. We replace the reference + -- to the type by a reference to the actual object + + elsif Nkind (Arg) = N_Attribute_Reference + and then Is_Access_Type (Etype (Arg)) + and then Is_Entity_Name (Prefix (Arg)) + and then Is_Type (Entity (Prefix (Arg))) + then + Arg := + Make_Attribute_Reference (Loc, + Prefix => New_Copy (Prefix (Id_Ref)), + Attribute_Name => Name_Unrestricted_Access); + + -- Otherwise make a copy of the default expression. Note + -- that we use the current Sloc for this, because we do not + -- want the call to appear to be at the declaration point. + -- Within the expression, replace discriminants with their + -- discriminals. + + else + Arg := + New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc); + end if; + + else + if Is_Constrained (Full_Type) then + Arg := Duplicate_Subexpr (Arg); + else + -- The constraints come from the discriminant default + -- exps, they must be reevaluated, so we use New_Copy_Tree + -- but we ensure the proper Sloc (for any embedded calls). + + Arg := New_Copy_Tree (Arg, New_Sloc => Loc); + end if; + end if; + + Append_To (Args, Arg); + + Next_Discriminant (Discr); + end loop; + end if; + + -- If this is a call to initialize the parent component of a derived + -- tagged type, indicate that the tag should not be set in the parent. + + if Is_Tagged_Type (Full_Init_Type) + and then not Is_CPP_Class (Full_Init_Type) + and then Nkind (Id_Ref) = N_Selected_Component + and then Chars (Selector_Name (Id_Ref)) = Name_uParent + then + Append_To (Args, New_Occurrence_Of (Standard_False, Loc)); + end if; + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Proc, Loc), + Parameter_Associations => Args)); + + if Controlled_Type (Typ) + and then Nkind (Id_Ref) = N_Selected_Component + then + if Chars (Selector_Name (Id_Ref)) /= Name_uParent then + Append_List_To (Res, + Make_Init_Call ( + Ref => New_Copy_Tree (First_Arg), + Typ => Typ, + Flist_Ref => + Find_Final_List (Typ, New_Copy_Tree (First_Arg)), + With_Attach => Make_Integer_Literal (Loc, 1))); + + -- If the enclosing type is an extension with new controlled + -- components, it has his own record controller. If the parent + -- also had a record controller, attach it to the new one. + -- Build_Init_Statements relies on the fact that in this specific + -- case the last statement of the result is the attach call to + -- the controller. If this is changed, it must be synchronized. + + elsif Present (Enclos_Type) + and then Has_New_Controlled_Component (Enclos_Type) + and then Has_Controlled_Component (Typ) + then + if Is_Return_By_Reference_Type (Typ) then + Controller_Typ := RTE (RE_Limited_Record_Controller); + else + Controller_Typ := RTE (RE_Record_Controller); + end if; + + Append_List_To (Res, + Make_Init_Call ( + Ref => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (First_Arg), + Selector_Name => Make_Identifier (Loc, Name_uController)), + Typ => Controller_Typ, + Flist_Ref => Find_Final_List (Typ, New_Copy_Tree (First_Arg)), + With_Attach => Make_Integer_Literal (Loc, 1))); + end if; + end if; + + -- Discard dynamic string allocated for name after call to init_proc, + -- to avoid storage leaks. This is done for composite types because + -- the allocated name is used as prefix for the id constructed at run- + -- time, and this allocated name is not released when the task itself + -- is freed. + + if Has_Task (Full_Type) + and then not Is_Task_Type (Full_Type) + then + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Free_Task_Image), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Defining_Identifier (Decl), Loc)))); + end if; + + return Res; + end Build_Initialization_Call; + + --------------------------- + -- Build_Master_Renaming -- + --------------------------- + + procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + M_Id : Entity_Id; + Decl : Node_Id; + + begin + -- Nothing to do if there is no task hierarchy. + + if Restrictions (No_Task_Hierarchy) then + return; + end if; + + M_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (T), 'M')); + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => M_Id, + Subtype_Mark => New_Reference_To (RTE (RE_Master_Id), Loc), + Name => Make_Identifier (Loc, Name_uMaster)); + Insert_Before (N, Decl); + Analyze (Decl); + + Set_Master_Id (T, M_Id); + + end Build_Master_Renaming; + + ---------------------------- + -- Build_Record_Init_Proc -- + ---------------------------- + + procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is + Loc : Source_Ptr := Sloc (N); + Proc_Id : Entity_Id; + Rec_Type : Entity_Id; + Discr_Map : Elist_Id := New_Elmt_List; + Set_Tag : Entity_Id := Empty; + + function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; + -- Build a assignment statement node which assigns to record + -- component its default expression if defined. The left hand side + -- of the assignment is marked Assignment_OK so that initialization + -- of limited private records works correctly, Return also the + -- adjustment call for controlled objects + + procedure Build_Discriminant_Assignments (Statement_List : List_Id); + -- If the record has discriminants, adds assignment statements to + -- statement list to initialize the discriminant values from the + -- arguments of the initialization procedure. + + function Build_Init_Statements (Comp_List : Node_Id) return List_Id; + -- Build a list representing a sequence of statements which initialize + -- 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; + -- Given a non-tagged type-derivation that declares discriminants, + -- such as + -- + -- type R (R1, R2 : Integer) is record ... end record; + -- + -- type D (D1 : Integer) is new R (1, D1); + -- + -- we make the _init_proc of D be + -- + -- procedure _init_proc(X : D; D1 : Integer) is + -- begin + -- _init_proc( R(X), 1, D1); + -- end _init_proc; + -- + -- This function builds the call statement in this _init_proc. + + procedure Build_Init_Procedure; + -- Build the tree corresponding to the procedure specification and body + -- of the initialization procedure (by calling all the preceding + -- auxiliary routines), and install it as the _init TSS. + + procedure Build_Record_Checks + (S : Node_Id; + Related_Nod : Node_Id; + Check_List : List_Id); + -- Add range checks to components of disciminated records. S is a + -- subtype indication of a record component. Related_Nod is passed + -- for compatibility with Process_Range_Expr_In_Decl. Check_List is + -- a list 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 identical to Needs_Simple_Initialization, except + -- that the types Tag and Vtable_Ptr, which are access types which + -- would normally require simple initialization to null, do not + -- require initialization as components, since they are explicitly + -- initialized by other means. + + procedure Constrain_Array + (SI : Node_Id; + Related_Nod : Node_Id; + Check_List : List_Id); + -- Called from Build_Record_Checks. + -- Apply a list of index constraints to an unconstrained array type. + -- The first parameter is the entity for the resulting subtype. + -- Related_Nod is passed for compatibility with Process_Range_Expr_In_ + -- Decl. Check_List is a list to which the check actions are appended. + + procedure Constrain_Index + (Index : Node_Id; + S : Node_Id; + Related_Nod : Node_Id; + Check_List : List_Id); + -- Called from Build_Record_Checks. + -- Process an index constraint in a constrained array declaration. + -- The constraint can be a subtype name, or a range with or without + -- an explicit subtype mark. The index is the corresponding index of the + -- unconstrained array. S is the range expression. Check_List is a list + -- to which the check actions are appended. + + function Parent_Subtype_Renaming_Discrims return Boolean; + -- Returns True for base types N that rename discriminants, else False + + function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean; + -- Determines whether a record initialization procedure needs to be + -- generated for the given record type. + + ---------------------- + -- Build_Assignment -- + ---------------------- + + function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is + Exp : Node_Id := N; + Lhs : Node_Id; + Typ : constant Entity_Id := Underlying_Type (Etype (Id)); + Kind : Node_Kind := Nkind (N); + Res : List_Id; + + begin + Loc := Sloc (N); + Lhs := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + 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. ???) + + if Kind = N_Attribute_Reference + and then (Attribute_Name (N) = Name_Unchecked_Access + or else + Attribute_Name (N) = Name_Unrestricted_Access) + and then Is_Entity_Name (Prefix (N)) + and then Is_Type (Entity (Prefix (N))) + and then Entity (Prefix (N)) = Rec_Type + then + Exp := + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + 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 + then + Exp := New_Copy_Tree (Original_Node (Exp)); + end if; + + Res := New_List ( + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Exp)); + + Set_No_Ctrl_Actions (First (Res)); + + -- Adjust the tag if tagged (because of possible view conversions). + -- Suppress the tag adjustment when Java_VM because JVM tags are + -- represented implicitly in objects. + + if Is_Tagged_Type (Typ) and then not Java_VM then + Append_To (Res, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Lhs), + Selector_Name => + New_Reference_To (Tag_Component (Typ), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (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)); + end if; + + if Controlled_Type (Typ) + and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate) + then + Append_List_To (Res, + Make_Adjust_Call ( + Ref => New_Copy_Tree (Lhs), + Typ => Etype (Id), + Flist_Ref => + Find_Final_List (Etype (Id), New_Copy_Tree (Lhs)), + With_Attach => Make_Integer_Literal (Loc, 1))); + end if; + + return Res; + end Build_Assignment; + + ------------------------------------ + -- Build_Discriminant_Assignments -- + ------------------------------------ + + procedure Build_Discriminant_Assignments (Statement_List : List_Id) is + D : Entity_Id; + Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type); + + begin + if Has_Discriminants (Rec_Type) + and then not Is_Unchecked_Union (Rec_Type) + then + D := First_Discriminant (Rec_Type); + + while Present (D) loop + -- Don't generate the assignment for discriminants in derived + -- tagged types if the discriminant is a renaming of some + -- ancestor discriminant. This initialization will be done + -- when initializing the _parent field of the derived record. + + if Is_Tagged and then + Present (Corresponding_Discriminant (D)) + then + null; + + else + Loc := Sloc (D); + Append_List_To (Statement_List, + Build_Assignment (D, + New_Reference_To (Discriminal (D), Loc))); + end if; + + Next_Discriminant (D); + end loop; + end if; + end Build_Discriminant_Assignments; + + -------------------------- + -- 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)); + + Parent_Type : constant Entity_Id := + Etype (First_Formal (Parent_Proc)); + + Uparent_Type : constant Entity_Id := + Underlying_Type (Parent_Type); + + First_Discr_Param : Node_Id; + + Parent_Discr : Entity_Id; + First_Arg : Node_Id; + Args : List_Id; + Arg : Node_Id; + Res : List_Id; + + begin + -- First argument (_Init) is the object to be initialized. + -- ??? not sure where to get a reasonable Loc for First_Arg + + First_Arg := + OK_Convert_To (Parent_Type, + New_Reference_To (Defining_Identifier (First (Parameters)), Loc)); + + Set_Etype (First_Arg, Parent_Type); + + Args := New_List (Convert_Concurrent (First_Arg, Rec_Type)); + + -- In the tasks case, + -- add _Master as the value of the _Master parameter + -- add _Chain as the value of the _Chain parameter. + -- add _Task_Id as the value of the _Task_Id parameter. + -- At the outer level, these will be variables holding the + -- corresponding values obtained from GNARL or the expander. + -- + -- At inner levels, they will be the parameters passed down through + -- the outer routines. + + First_Discr_Param := Next (First (Parameters)); + + if Has_Task (Rec_Type) then + if Restrictions (No_Task_Hierarchy) then + + -- See comments in System.Tasking.Initialization.Init_RTS + -- for the value 3. + + Append_To (Args, Make_Integer_Literal (Loc, 3)); + else + Append_To (Args, Make_Identifier (Loc, Name_uMaster)); + end if; + + Append_To (Args, Make_Identifier (Loc, Name_uChain)); + Append_To (Args, Make_Identifier (Loc, Name_uTask_Id)); + First_Discr_Param := Next (Next (Next (First_Discr_Param))); + end if; + + -- Append discriminant values + + if Has_Discriminants (Uparent_Type) then + pragma Assert (not Is_Tagged_Type (Uparent_Type)); + + Parent_Discr := First_Discriminant (Uparent_Type); + while Present (Parent_Discr) loop + + -- Get the initial value for this discriminant + -- ?????? needs to be cleaned up to use parent_Discr_Constr + -- directly. + + declare + Discr_Value : Elmt_Id := + First_Elmt + (Girder_Constraint (Rec_Type)); + + Discr : Entity_Id := + First_Girder_Discriminant (Uparent_Type); + begin + while Original_Record_Component (Parent_Discr) /= Discr loop + Next_Girder_Discriminant (Discr); + Next_Elmt (Discr_Value); + end loop; + + Arg := Node (Discr_Value); + end; + + -- Append it to the list + + if Nkind (Arg) = N_Identifier + and then Ekind (Entity (Arg)) = E_Discriminant + then + Append_To (Args, + New_Reference_To (Discriminal (Entity (Arg)), Loc)); + + -- Case of access discriminants. We replace the reference + -- to the type by a reference to the actual object + +-- ??? +-- elsif Nkind (Arg) = N_Attribute_Reference +-- and then Is_Entity_Name (Prefix (Arg)) +-- and then Is_Type (Entity (Prefix (Arg))) +-- then +-- Append_To (Args, +-- Make_Attribute_Reference (Loc, +-- Prefix => New_Copy (Prefix (Id_Ref)), +-- Attribute_Name => Name_Unrestricted_Access)); + + else + Append_To (Args, New_Copy (Arg)); + end if; + + Next_Discriminant (Parent_Discr); + end loop; + end if; + + Res := + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Parent_Proc, Loc), + Parameter_Associations => Args)); + + return Res; + end Build_Init_Call_Thru; + + -------------------------- + -- Build_Init_Procedure -- + -------------------------- + + procedure Build_Init_Procedure is + Body_Node : Node_Id; + Handled_Stmt_Node : Node_Id; + Parameters : List_Id; + Proc_Spec_Node : Node_Id; + Body_Stmts : List_Id; + Record_Extension_Node : Node_Id; + Init_Tag : Node_Id; + + begin + Body_Stmts := New_List; + Body_Node := New_Node (N_Subprogram_Body, Loc); + + Proc_Id := Make_Defining_Identifier (Loc, Name_uInit_Proc); + Set_Ekind (Proc_Id, E_Procedure); + + Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); + Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); + + Parameters := Init_Formals (Rec_Type); + Append_List_To (Parameters, + Build_Discriminant_Formals (Rec_Type, True)); + + -- For tagged types, we add a flag to indicate whether the routine + -- is called to initialize a parent component in the init_proc of + -- a type extension. If the flag is false, we do not set the tag + -- because it has been set already in the extension. + + if Is_Tagged_Type (Rec_Type) + and then not Is_CPP_Class (Rec_Type) + then + Set_Tag := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Append_To (Parameters, + Make_Parameter_Specification (Loc, + Defining_Identifier => Set_Tag, + Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), + Expression => New_Occurrence_Of (Standard_True, Loc))); + end if; + + Set_Parameter_Specifications (Proc_Spec_Node, Parameters); + Set_Specification (Body_Node, Proc_Spec_Node); + Set_Declarations (Body_Node, New_List); + + if Parent_Subtype_Renaming_Discrims then + + -- N is a Derived_Type_Definition that renames the parameters + -- of the ancestor type. We init it by expanding our discrims + -- and call the ancestor _init_proc with a type-converted object + + Append_List_To (Body_Stmts, + Build_Init_Call_Thru (Parameters)); + + elsif Nkind (Type_Definition (N)) = N_Record_Definition then + Build_Discriminant_Assignments (Body_Stmts); + + if not Null_Present (Type_Definition (N)) then + Append_List_To (Body_Stmts, + Build_Init_Statements ( + Component_List (Type_Definition (N)))); + end if; + + else + -- N is a Derived_Type_Definition with a possible non-empty + -- extension. The initialization of a type extension consists + -- in the initialization of the components in the extension. + + Build_Discriminant_Assignments (Body_Stmts); + + Record_Extension_Node := + Record_Extension_Part (Type_Definition (N)); + + if not Null_Present (Record_Extension_Node) then + declare + Stmts : List_Id := + Build_Init_Statements ( + Component_List (Record_Extension_Node)); + + begin + -- The parent field must be initialized first because + -- the offset of the new discriminants may depend on it + + Prepend_To (Body_Stmts, Remove_Head (Stmts)); + Append_List_To (Body_Stmts, Stmts); + end; + end if; + end if; + + -- Add here the assignment to instantiate the Tag + + -- The assignement corresponds to the code: + + -- _Init._Tag := Typ'Tag; + + -- Suppress the tag assignment when Java_VM because JVM tags are + -- represented implicitly in objects. + + if Is_Tagged_Type (Rec_Type) + and then not Is_CPP_Class (Rec_Type) + and then not Java_VM + then + Init_Tag := + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => + New_Reference_To (Tag_Component (Rec_Type), Loc)), + + Expression => + New_Reference_To (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 + -- depend ot the tag (eg. through a dispatching operation on + -- an access to the current type). The tag assignment is not done + -- when initializing the parent component of a type extension, + -- because in that case the tag is set in the extension. + -- Extensions of imported C++ classes add a final complication, + -- because we cannot inhibit tag setting in the constructor for + -- the parent. In that case we insert the tag initialization + -- after the calls to initialize the parent. + + Init_Tag := + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Set_Tag, Loc), + Then_Statements => New_List (Init_Tag)); + + if not Is_CPP_Class (Etype (Rec_Type)) then + Prepend_To (Body_Stmts, Init_Tag); + + else + declare + Nod : Node_Id := First (Body_Stmts); + + begin + -- We assume the first init_proc call is for the parent + + while Present (Next (Nod)) + and then (Nkind (Nod) /= N_Procedure_Call_Statement + or else Chars (Name (Nod)) /= Name_uInit_Proc) + loop + Nod := Next (Nod); + end loop; + + Insert_After (Nod, Init_Tag); + end; + end if; + end if; + + Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc); + Set_Statements (Handled_Stmt_Node, Body_Stmts); + Set_Exception_Handlers (Handled_Stmt_Node, No_List); + Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Proc_Id); + end if; + + -- Associate Init_Proc with type, and determine if the procedure + -- is null (happens because of the Initialize_Scalars pragma case, + -- where we have to generate a null procedure in case it is called + -- by a client with Initialize_Scalars set). Such procedures have + -- to be generated, but do not have to be called, so we mark them + -- as null to suppress the call. + + Set_Init_Proc (Rec_Type, Proc_Id); + + if List_Length (Body_Stmts) = 1 + and then Nkind (First (Body_Stmts)) = N_Null_Statement + then + Set_Is_Null_Init_Proc (Proc_Id); + end if; + end Build_Init_Procedure; + + --------------------------- + -- Build_Init_Statements -- + --------------------------- + + function Build_Init_Statements (Comp_List : Node_Id) return List_Id is + Alt_List : List_Id; + Statement_List : List_Id; + Stmts : List_Id; + Check_List : List_Id := New_List; + + Per_Object_Constraint_Components : Boolean; + + Decl : Node_Id; + Variant : Node_Id; + + Id : Entity_Id; + Typ : Entity_Id; + + begin + if Null_Present (Comp_List) then + return New_List (Make_Null_Statement (Loc)); + end if; + + Statement_List := New_List; + + -- Loop through components, skipping pragmas, in 2 steps. The first + -- step deals with regular components. The second step deals with + -- components have per object constraints, and no explicit initia- + -- lization. + + Per_Object_Constraint_Components := False; + + -- 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), + Decl, + Check_List); + + Id := Defining_Identifier (Decl); + Typ := Etype (Id); + + if Has_Per_Object_Constraint (Id) + and then No (Expression (Decl)) + then + -- Skip processing for now and ask for a second pass + + Per_Object_Constraint_Components := True; + else + if Present (Expression (Decl)) then + Stmts := Build_Assignment (Id, Expression (Decl)); + + elsif Has_Non_Null_Base_Init_Proc (Typ) then + Stmts := + Build_Initialization_Call (Loc, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Loc)), + Typ, True, Rec_Type, Discr_Map => Discr_Map); + + elsif Component_Needs_Simple_Initialization (Typ) then + Stmts := + Build_Assignment (Id, Get_Simple_Init_Val (Typ, Loc)); + + else + Stmts := No_List; + end if; + + if Present (Check_List) then + Append_List_To (Statement_List, Check_List); + end if; + + if Present (Stmts) then + + -- Add the initialization of the record controller + -- before the _Parent field is attached to it when + -- the attachment can occur. It does not work to + -- simply initialize the controller first: it must be + -- initialized after the parent if the parent holds + -- discriminants that can be used to compute the + -- offset of the controller. This code relies on + -- the last statement of the initialization call + -- being the attachement of the parent. see + -- Build_Initialization_Call. + + if Chars (Id) = Name_uController + and then Rec_Type /= Etype (Rec_Type) + and then Has_Controlled_Component (Etype (Rec_Type)) + and then Has_New_Controlled_Component (Rec_Type) + then + Insert_List_Before (Last (Statement_List), Stmts); + else + Append_List_To (Statement_List, Stmts); + end if; + end if; + end if; + + Next_Non_Pragma (Decl); + end loop; + + if Per_Object_Constraint_Components then + + -- Second pass: components with per-object constraints + + Decl := First_Non_Pragma (Component_Items (Comp_List)); + + while Present (Decl) loop + Loc := Sloc (Decl); + Id := Defining_Identifier (Decl); + Typ := Etype (Id); + + if Has_Per_Object_Constraint (Id) + and then No (Expression (Decl)) + then + if Has_Non_Null_Base_Init_Proc (Typ) then + Append_List_To (Statement_List, + Build_Initialization_Call (Loc, + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Loc)), + Typ, True, Rec_Type, Discr_Map => Discr_Map)); + + elsif Component_Needs_Simple_Initialization (Typ) then + Append_List_To (Statement_List, + Build_Assignment (Id, Get_Simple_Init_Val (Typ, Loc))); + end if; + end if; + + Next_Non_Pragma (Decl); + end loop; + end if; + + -- Process the variant part + + if Present (Variant_Part (Comp_List)) then + Alt_List := New_List; + Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); + + while Present (Variant) loop + Loc := Sloc (Variant); + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_Copy_List (Discrete_Choices (Variant)), + Statements => + Build_Init_Statements (Component_List (Variant)))); + + Next_Non_Pragma (Variant); + end loop; + + -- The expression of the case statement which is a reference + -- to one of the discriminants is replaced by the appropriate + -- formal parameter of the initialization procedure. + + Append_To (Statement_List, + Make_Case_Statement (Loc, + Expression => + New_Reference_To (Discriminal ( + Entity (Name (Variant_Part (Comp_List)))), Loc), + Alternatives => Alt_List)); + end if; + + -- For a task record type, add the task create call and calls + -- to bind any interrupt (signal) entries. + + if Is_Task_Record_Type (Rec_Type) then + Append_To (Statement_List, Make_Task_Create_Call (Rec_Type)); + + declare + Task_Type : constant Entity_Id := + Corresponding_Concurrent_Type (Rec_Type); + Task_Decl : constant Node_Id := Parent (Task_Type); + Task_Def : constant Node_Id := Task_Definition (Task_Decl); + Vis_Decl : Node_Id; + Ent : Entity_Id; + + begin + if Present (Task_Def) then + Vis_Decl := First (Visible_Declarations (Task_Def)); + while Present (Vis_Decl) loop + Loc := Sloc (Vis_Decl); + + if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then + if Get_Attribute_Id (Chars (Vis_Decl)) = + Attribute_Address + then + Ent := Entity (Name (Vis_Decl)); + + if Ekind (Ent) = E_Entry then + Append_To (Statement_List, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Bind_Interrupt_To_Entry), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uInit), + Selector_Name => + Make_Identifier (Loc, Name_uTask_Id)), + Entry_Index_Expression ( + Loc, Ent, Empty, Task_Type), + Expression (Vis_Decl)))); + end if; + end if; + end if; + + Next (Vis_Decl); + end loop; + end if; + end; + end if; + + -- For a protected type, add statements generated by + -- Make_Initialize_Protection. + + if Is_Protected_Record_Type (Rec_Type) then + Append_List_To (Statement_List, + Make_Initialize_Protection (Rec_Type)); + end if; + + -- If no initializations when generated for component declarations + -- corresponding to this Statement_List, append a null statement + -- to the Statement_List to make it a valid Ada tree. + + if Is_Empty_List (Statement_List) then + Append (New_Node (N_Null_Statement, Loc), Statement_List); + end if; + + return Statement_List; + end Build_Init_Statements; + + ------------------------- + -- Build_Record_Checks -- + ------------------------- + + procedure Build_Record_Checks + (S : Node_Id; + Related_Nod : Node_Id; + Check_List : List_Id) + is + P : Node_Id; + Subtype_Mark_Id : Entity_Id; + begin + + if Nkind (S) = N_Subtype_Indication then + Find_Type (Subtype_Mark (S)); + P := Parent (S); + Subtype_Mark_Id := Entity (Subtype_Mark (S)); + + -- Remaining processing depends on type + + case Ekind (Subtype_Mark_Id) is + + when Array_Kind => + Constrain_Array (S, Related_Nod, Check_List); + + when others => + null; + end case; + end if; + + end Build_Record_Checks; + + ------------------------------------------- + -- Component_Needs_Simple_Initialization -- + ------------------------------------------- + + function Component_Needs_Simple_Initialization + (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); + end Component_Needs_Simple_Initialization; + + --------------------- + -- Constrain_Array -- + --------------------- + + procedure Constrain_Array + (SI : Node_Id; + Related_Nod : Node_Id; + Check_List : List_Id) + is + C : constant Node_Id := Constraint (SI); + Number_Of_Constraints : Nat := 0; + Index : Node_Id; + S, T : Entity_Id; + + begin + T := Entity (Subtype_Mark (SI)); + + if Ekind (T) in Access_Kind then + T := Designated_Type (T); + end if; + + S := First (Constraints (C)); + + while Present (S) loop + Number_Of_Constraints := Number_Of_Constraints + 1; + Next (S); + end loop; + + -- In either case, the index constraint must provide a discrete + -- range for each index of the array type and the type of each + -- discrete range must be the same as that of the corresponding + -- index. (RM 3.6.1) + + S := First (Constraints (C)); + Index := First_Index (T); + Analyze (Index); + + -- Apply constraints to each index type + + for J in 1 .. Number_Of_Constraints loop + Constrain_Index (Index, S, Related_Nod, Check_List); + Next (Index); + Next (S); + end loop; + + end Constrain_Array; + + --------------------- + -- Constrain_Index -- + --------------------- + + procedure Constrain_Index + (Index : Node_Id; + S : Node_Id; + Related_Nod : Node_Id; + Check_List : List_Id) + is + T : constant Entity_Id := Etype (Index); + + begin + if Nkind (S) = N_Range then + Process_Range_Expr_In_Decl (S, T, Related_Nod, Check_List); + end if; + end Constrain_Index; + + -------------------------------------- + -- Parent_Subtype_Renaming_Discrims -- + -------------------------------------- + + function Parent_Subtype_Renaming_Discrims return Boolean is + De : Entity_Id; + Dp : Entity_Id; + + begin + if Base_Type (Pe) /= Pe then + return False; + end if; + + if Etype (Pe) = Pe + or else not Has_Discriminants (Pe) + or else Is_Constrained (Pe) + or else Is_Tagged_Type (Pe) + then + return False; + end if; + + -- If there are no explicit girder discriminants we have inherited + -- the root type discriminants so far, so no renamings occurred. + + if First_Discriminant (Pe) = First_Girder_Discriminant (Pe) then + return False; + end if; + + -- Check if we have done some trivial renaming of the parent + -- discriminants, i.e. someting like + -- + -- type DT (X1,X2: int) is new PT (X1,X2); + + De := First_Discriminant (Pe); + Dp := First_Discriminant (Etype (Pe)); + + while Present (De) loop + pragma Assert (Present (Dp)); + + if Corresponding_Discriminant (De) /= Dp then + return True; + end if; + + Next_Discriminant (De); + Next_Discriminant (Dp); + end loop; + + return Present (Dp); + end Parent_Subtype_Renaming_Discrims; + + ------------------------ + -- Requires_Init_Proc -- + ------------------------ + + function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is + Comp_Decl : Node_Id; + Id : Entity_Id; + Typ : Entity_Id; + + begin + -- Definitely do not need one if specifically suppressed + + if Suppress_Init_Proc (Rec_Id) then + return False; + end if; + + -- Otherwise we need to generate an initialization procedure if + -- Is_CPP_Class is False and at least one of the following applies: + + -- 1. Discriminants are present, since they need to be initialized + -- with the appropriate discriminant constraint expressions. + -- However, the discriminant of an unchecked union does not + -- count, since the discriminant is not present. + + -- 2. The type is a tagged type, since the implicit Tag component + -- needs to be initialized with a pointer to the dispatch table. + + -- 3. The type contains tasks + + -- 4. One or more components has an initial value + + -- 5. One or more components is for a type which itself requires + -- an initialization procedure. + + -- 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 + -- of these types are initialized by other means. + + -- 7. The type is the record type built for a task type (since at + -- the very least, Create_Task must be called) + + -- 8. The type is the record type built for a protected type (since + -- at least Initialize_Protection must be called) + + -- 9. The type is marked as a public entity. The reason we add this + -- case (even if none of the above apply) is to properly handle + -- Initialize_Scalars. If a package is compiled without an IS + -- pragma, and the client is compiled with an IS pragma, then + -- the client will think an initialization procedure is present + -- and call it, when in fact no such procedure is required, but + -- since the call is generated, there had better be a routine + -- at the other end of the call, even if it does nothing!) + + -- Note: the reason we exclude the CPP_Class case is ??? + + if Is_CPP_Class (Rec_Id) then + return False; + + elsif Is_Public (Rec_Id) then + return True; + + elsif (Has_Discriminants (Rec_Id) + and then not Is_Unchecked_Union (Rec_Id)) + or else Is_Tagged_Type (Rec_Id) + or else Is_Concurrent_Record_Type (Rec_Id) + or else Has_Task (Rec_Id) + then + return True; + end if; + + Id := First_Component (Rec_Id); + + while Present (Id) loop + Comp_Decl := Parent (Id); + Typ := Etype (Id); + + if Present (Expression (Comp_Decl)) + or else Has_Non_Null_Base_Init_Proc (Typ) + or else Component_Needs_Simple_Initialization (Typ) + then + return True; + end if; + + Next_Component (Id); + end loop; + + return False; + end Requires_Init_Proc; + + -- Start of processing for Build_Record_Init_Proc + + begin + Rec_Type := Defining_Identifier (N); + + -- This may be full declaration of a private type, in which case + -- the visible entity is a record, and the private entity has been + -- exchanged with it in the private part of the current package. + -- The initialization procedure is built for the record type, which + -- is retrievable from the private entity. + + if Is_Incomplete_Or_Private_Type (Rec_Type) then + Rec_Type := Underlying_Type (Rec_Type); + end if; + + -- If there are discriminants, build the discriminant map to replace + -- discriminants by their discriminals in complex bound expressions. + -- These only arise for the corresponding records of protected types. + + if Is_Concurrent_Record_Type (Rec_Type) + and then Has_Discriminants (Rec_Type) + then + declare + Disc : Entity_Id; + + begin + Disc := First_Discriminant (Rec_Type); + + while Present (Disc) loop + Append_Elmt (Disc, Discr_Map); + Append_Elmt (Discriminal (Disc), Discr_Map); + Next_Discriminant (Disc); + end loop; + end; + end if; + + -- Derived types that have no type extension can use the initialization + -- procedure of their parent and do not need a procedure of their own. + -- This is only correct if there are no representation clauses for the + -- type or its parent, and if the parent has in fact been frozen so + -- that its initialization procedure exists. + + if Is_Derived_Type (Rec_Type) + and then not Is_Tagged_Type (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)) + then + Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), 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 + Build_Init_Procedure; + Set_Is_Public (Proc_Id, Is_Public (Pe)); + + -- The initialization of protected records is not worth inlining. + -- In addition, when compiled for another unit for inlining purposes, + -- it may make reference to entities that have not been elaborated + -- yet. The initialization of controlled records contains a nested + -- clean-up procedure that makes it impractical to inline as well, + -- and leads to undefined symbols if inlined in a different unit. + + if not Is_Protected_Record_Type (Rec_Type) + and then not Controlled_Type (Rec_Type) + then + Set_Is_Inlined (Proc_Id); + end if; + + Set_Is_Internal (Proc_Id); + Set_Has_Completion (Proc_Id); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Proc_Id); + end if; + end if; + end Build_Record_Init_Proc; + + ------------------------------------ + -- Build_Variant_Record_Equality -- + ------------------------------------ + + -- Generates: + -- + -- function _Equality (X, Y : T) return Boolean is + -- begin + -- -- Compare discriminants + + -- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then + -- return False; + -- end if; + + -- -- Compare components + + -- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then + -- return False; + -- end if; + + -- -- Compare variant part + + -- case X.D1 is + -- when V1 => + -- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then + -- return False; + -- end if; + -- ... + -- when Vn => + -- if False or else X.Cn /= Y.Cn then + -- return False; + -- end if; + -- end case; + -- return True; + -- end _Equality; + + procedure Build_Variant_Record_Equality (Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + F : constant Entity_Id := Make_Defining_Identifier (Loc, + Name_uEquality); + X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X); + Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y); + Def : constant Node_Id := Parent (Typ); + Comps : constant Node_Id := Component_List (Type_Definition (Def)); + + Function_Body : Node_Id; + Stmts : List_Id := New_List; + + begin + if Is_Derived_Type (Typ) + and then not Has_New_Non_Standard_Rep (Typ) + then + declare + Parent_Eq : Entity_Id := TSS (Root_Type (Typ), Name_uEquality); + + begin + if Present (Parent_Eq) then + Copy_TSS (Parent_Eq, Typ); + return; + end if; + end; + end if; + + Function_Body := + Make_Subprogram_Body (Loc, + 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)), + + 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. + + if Has_Unchecked_Union (Typ) then + Append_To (Stmts, + Make_Raise_Program_Error (Loc)); + + else + Append_To (Stmts, + Make_Eq_If (Typ, + Discriminant_Specifications (Def))); + Append_List_To (Stmts, + Make_Eq_Case (Typ, Comps)); + end if; + + Append_To (Stmts, + Make_Return_Statement (Loc, + Expression => New_Reference_To (Standard_True, Loc))); + + Set_TSS (Typ, F); + Set_Is_Pure (F); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (F); + end if; + end Build_Variant_Record_Equality; + + --------------------------- + -- Expand_Derived_Record -- + --------------------------- + + -- Add a field _parent at the beginning of the record extension. This is + -- used to implement inheritance. Here are some examples of expansion: + + -- 1. no discriminants + -- type T2 is new T1 with null record; + -- gives + -- type T2 is new T1 with record + -- _Parent : T1; + -- end record; + + -- 2. renamed discriminants + -- type T2 (B, C : Int) is new T1 (A => B) with record + -- _Parent : T1 (A => B); + -- D : Int; + -- end; + + -- 3. inherited discriminants + -- type T2 is new T1 with record -- discriminant A inherited + -- _Parent : T1 (A); + -- D : Int; + -- end; + + procedure Expand_Derived_Record (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); + Par_Subtype : Entity_Id; + Comp_List : Node_Id; + Comp_Decl : Node_Id; + Parent_N : Node_Id; + D : Entity_Id; + List_Constr : constant List_Id := New_List; + + begin + -- Expand_Tagged_Extension is called directly from the semantics, so + -- we must check to see whether expansion is active before proceeding + + if not Expander_Active then + return; + end if; + + -- This may be a derivation of an untagged private type whose full + -- view is tagged, in which case the Derived_Type_Definition has no + -- extension part. Build an empty one now. + + if No (Rec_Ext_Part) then + Rec_Ext_Part := + Make_Record_Definition (Loc, + End_Label => Empty, + Component_List => Empty, + Null_Present => True); + + Set_Record_Extension_Part (Def, Rec_Ext_Part); + Mark_Rewrite_Insertion (Rec_Ext_Part); + end if; + + Comp_List := Component_List (Rec_Ext_Part); + + Parent_N := Make_Defining_Identifier (Loc, Name_uParent); + + -- If the derived type inherits its discriminants the type of the + -- _parent field must be constrained by the inherited discriminants + + if Has_Discriminants (T) + and then Nkind (Indic) /= N_Subtype_Indication + and then not Is_Constrained (Entity (Indic)) + then + D := First_Discriminant (T); + while (Present (D)) loop + Append_To (List_Constr, New_Occurrence_Of (D, Loc)); + Next_Discriminant (D); + end loop; + + Par_Subtype := + Process_Subtype ( + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Entity (Indic), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => List_Constr)), + Def); + + -- Otherwise the original subtype_indication is just what is needed + + else + Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); + end if; + + Set_Parent_Subtype (T, Par_Subtype); + + Comp_Decl := + Make_Component_Declaration (Loc, + Defining_Identifier => Parent_N, + Subtype_Indication => New_Reference_To (Par_Subtype, Loc)); + + if Null_Present (Rec_Ext_Part) then + Set_Component_List (Rec_Ext_Part, + Make_Component_List (Loc, + Component_Items => New_List (Comp_Decl), + Variant_Part => Empty, + Null_Present => False)); + Set_Null_Present (Rec_Ext_Part, False); + + elsif Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Set_Component_Items (Comp_List, New_List (Comp_Decl)); + Set_Null_Present (Comp_List, False); + + else + Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); + end if; + + Analyze (Comp_Decl); + end Expand_Derived_Record; + + ------------------------------------ + -- Expand_N_Full_Type_Declaration -- + ------------------------------------ + + procedure Expand_N_Full_Type_Declaration (N : Node_Id) is + Def_Id : constant Entity_Id := Defining_Identifier (N); + B_Id : Entity_Id := Base_Type (Def_Id); + Par_Id : Entity_Id; + FN : Node_Id; + + begin + if Is_Access_Type (Def_Id) then + + -- Anonymous access types are created for the components of the + -- record parameter for an entry declaration. No master is created + -- for such a type. + + if Has_Task (Designated_Type (Def_Id)) + and then Comes_From_Source (N) + then + Build_Master_Entity (Def_Id); + Build_Master_Renaming (Parent (Def_Id), Def_Id); + + -- Create a class-wide master because a Master_Id must be generated + -- for access-to-limited-class-wide types, whose root may be extended + -- with task components. + + elsif Is_Class_Wide_Type (Designated_Type (Def_Id)) + and then Is_Limited_Type (Designated_Type (Def_Id)) + and then Tasking_Allowed + + -- Don't create a class-wide master for types whose convention is + -- Java since these types cannot embed Ada tasks anyway. Note that + -- the following test cannot catch the following case: + -- + -- package java.lang.Object is + -- type Typ is tagged limited private; + -- type Ref is access all Typ'Class; + -- private + -- type Typ is tagged limited ...; + -- pragma Convention (Typ, Java) + -- end; + -- + -- Because the convention appears after we have done the + -- processing for type Ref. + + and then Convention (Designated_Type (Def_Id)) /= Convention_Java + then + Build_Class_Wide_Master (Def_Id); + + elsif Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then + Expand_Access_Protected_Subprogram_Type (N); + end if; + + elsif Has_Task (Def_Id) then + Expand_Previous_Access_Type (N, Def_Id); + end if; + + Par_Id := Etype (B_Id); + + -- The parent type is private then we need to inherit + -- any TSS operations from the full view. + + if Ekind (Par_Id) in Private_Kind + and then Present (Full_View (Par_Id)) + then + Par_Id := Base_Type (Full_View (Par_Id)); + end if; + + if Nkind (Type_Definition (Original_Node (N))) + = N_Derived_Type_Definition + and then not Is_Tagged_Type (Def_Id) + and then Present (Freeze_Node (Par_Id)) + and then Present (TSS_Elist (Freeze_Node (Par_Id))) + then + Ensure_Freeze_Node (B_Id); + FN := Freeze_Node (B_Id); + + if No (TSS_Elist (FN)) then + Set_TSS_Elist (FN, New_Elmt_List); + end if; + + declare + T_E : Elist_Id := TSS_Elist (FN); + Elmt : Elmt_Id; + + begin + Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id))); + + while Present (Elmt) loop + if Chars (Node (Elmt)) /= Name_uInit then + Append_Elmt (Node (Elmt), T_E); + end if; + + 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 Ekind (B_Id) in Private_Kind + and then Present (Full_View (B_Id)) + then + Ensure_Freeze_Node (Base_Type (Full_View (B_Id))); + Set_TSS_Elist + (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN)); + end if; + end; + end if; + end Expand_N_Full_Type_Declaration; + + --------------------------------- + -- Expand_N_Object_Declaration -- + --------------------------------- + + -- First we do special processing for objects of a tagged type where this + -- is the point at which the type is frozen. The creation of the dispatch + -- table and the initialization procedure have to be deferred to this + -- point, since we reference previously declared primitive subprograms. + + -- For all types, we call an initialization procedure if there is one + + procedure Expand_N_Object_Declaration (N : Node_Id) is + Def_Id : constant Entity_Id := Defining_Identifier (N); + Typ : constant Entity_Id := Etype (Def_Id); + Loc : constant Source_Ptr := Sloc (N); + Expr : Node_Id := Expression (N); + New_Ref : Node_Id; + Id_Ref : Node_Id; + Expr_Q : Node_Id; + + begin + -- Don't do anything for deferred constants. All proper actions will + -- be expanded during the redeclaration. + + if No (Expr) and Constant_Present (N) then + return; + end if; + + -- Make shared memory routines for shared passive variable + + if Is_Shared_Passive (Def_Id) then + Make_Shared_Var_Procs (N); + end if; + + -- If tasks being declared, make sure we have an activation chain + -- defined for the tasks (has no effect if we already have one), and + -- also that a Master variable is established and that the appropriate + -- enclosing construct is established as a task master. + + if Has_Task (Typ) then + Build_Activation_Chain_Entity (N); + Build_Master_Entity (Def_Id); + end if; + + -- Default initialization required, and no expression present + + if No (Expr) then + + -- Expand Initialize call for controlled objects. One may wonder why + -- the Initialize Call is not done in the regular Init procedure + -- attached to the record type. That's because the init procedure is + -- recursively called on each component, including _Parent, thus the + -- Init call for a controlled object would generate not only one + -- Initialize call as it is required but one for each ancestor of + -- its type. This processing is suppressed if No_Initialization set. + + if not Controlled_Type (Typ) + or else No_Initialization (N) + then + null; + + elsif not Abort_Allowed + or else not Comes_From_Source (N) + then + Insert_Actions_After (N, + Make_Init_Call ( + Ref => New_Occurrence_Of (Def_Id, Loc), + Typ => Base_Type (Typ), + Flist_Ref => Find_Final_List (Def_Id), + With_Attach => Make_Integer_Literal (Loc, 1))); + + -- Abort allowed + + else + -- We need to protect the initialize call + + -- begin + -- Defer_Abort.all; + -- Initialize (...); + -- at end + -- Undefer_Abort.all; + -- end; + + -- ??? this won't protect the initialize call for controlled + -- components which are part of the init proc, so this block + -- should probably also contain the call to _init_proc but this + -- requires some code reorganization... + + declare + L : constant List_Id := + Make_Init_Call ( + Ref => New_Occurrence_Of (Def_Id, Loc), + Typ => Base_Type (Typ), + Flist_Ref => Find_Final_List (Def_Id), + With_Attach => Make_Integer_Literal (Loc, 1)); + + Blk : constant Node_Id := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, L)); + + begin + Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer)); + Set_At_End_Proc (Handled_Statement_Sequence (Blk), + New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); + Insert_Actions_After (N, New_List (Blk)); + Expand_At_End_Handler + (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); + end; + end if; + + -- Call type initialization procedure if there is one. We build the + -- call and put it immediately after the object declaration, so that + -- it will be expanded in the usual manner. Note that this will + -- result in proper handling of defaulted discriminants. The call + -- to the Init_Proc is suppressed if No_Initialization is set. + + if Has_Non_Null_Base_Init_Proc (Typ) + and then not No_Initialization (N) + then + -- The call to the initialization procedure does NOT freeze + -- the object being initialized. This is because the call is + -- not a source level call. This works fine, because the only + -- possible statements depending on freeze status that can + -- appear after the _Init call are rep clauses which can + -- safely appear after actual references to the object. + + Id_Ref := New_Reference_To (Def_Id, Loc); + Set_Must_Not_Freeze (Id_Ref); + Set_Assignment_OK (Id_Ref); + + Insert_Actions_After (N, + Build_Initialization_Call (Loc, Id_Ref, Typ)); + + -- If simple initialization is required, then set an appropriate + -- simple initialization expression in place. This special + -- initialization is required even though No_Init_Flag is present. + + elsif Needs_Simple_Initialization (Typ) then + Set_No_Initialization (N, False); + Set_Expression (N, Get_Simple_Init_Val (Typ, Loc)); + Analyze_And_Resolve (Expression (N), Typ); + end if; + + -- Explicit initialization present + + else + -- Obtain actual expression from qualified expression + + if Nkind (Expr) = N_Qualified_Expression then + Expr_Q := Expression (Expr); + else + Expr_Q := Expr; + end if; + + -- When we have the appropriate type of aggregate in the + -- expression (it has been determined during analysis of the + -- aggregate by setting the delay flag), let's perform in + -- place assignment and thus avoid creating a temporay. + + if Is_Delayed_Aggregate (Expr_Q) then + Convert_Aggr_In_Object_Decl (N); + + else + -- In most cases, we must check that the initial value meets + -- any constraint imposed by the declared type. However, there + -- is one very important exception to this rule. If the entity + -- has an unconstrained nominal subtype, then it acquired its + -- constraints from the expression in the first place, and not + -- only does this mean that the constraint check is not needed, + -- but an attempt to perform the constraint check can + -- cause order of elaboration problems. + + if not Is_Constr_Subt_For_U_Nominal (Typ) then + + -- If this is an allocator for an aggregate that has been + -- allocated in place, delay checks until assignments are + -- made, because the discriminants are not initialized. + + if Nkind (Expr) = N_Allocator + and then No_Initialization (Expr) + then + null; + else + Apply_Constraint_Check (Expr, Typ); + end if; + end if; + + -- If the type is controlled we attach the object to the final + -- list and adjust the target after the copy. This + + if Controlled_Type (Typ) then + declare + Flist : Node_Id; + F : Entity_Id; + + begin + -- Attach the result to a dummy final list which will never + -- be finalized if Delay_Finalize_Attachis set. It is + -- important to attach to a dummy final list rather than + -- not attaching at all in order to reset the pointers + -- coming from the initial value. Equivalent code exists + -- in the sec-stack case in Exp_Ch4.Expand_N_Allocator. + + if Delay_Finalize_Attach (N) then + F := + Make_Defining_Identifier (Loc, New_Internal_Name ('F')); + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => F, + Object_Definition => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); + + Flist := New_Reference_To (F, Loc); + + else + Flist := Find_Final_List (Def_Id); + end if; + + Insert_Actions_After (N, + Make_Adjust_Call ( + Ref => New_Reference_To (Def_Id, Loc), + Typ => Base_Type (Typ), + Flist_Ref => Flist, + With_Attach => Make_Integer_Literal (Loc, 1))); + 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. + + 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 + then + -- The re-assignment of the tag has to be done even if + -- the object is a constant + + New_Ref := + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Def_Id, Loc), + Selector_Name => + New_Reference_To (Tag_Component (Typ), Loc)); + + Set_Assignment_OK (New_Ref); + + Insert_After (N, + Make_Assignment_Statement (Loc, + Name => New_Ref, + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (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. + + elsif Is_Discrete_Type (Typ) + and then Expr_Known_Valid (Expr) + then + Set_Is_Known_Valid (Def_Id); + end if; + + -- If validity checking on copies, validate initial expression + + if Validity_Checks_On + and then Validity_Check_Copies + then + Ensure_Valid (Expr); + Set_Is_Known_Valid (Def_Id); + end if; + end if; + end if; + + -- For array type, check for size too large + -- We really need this for record types too??? + + if Is_Array_Type (Typ) then + Apply_Array_Size_Check (N, Typ); + end if; + + end Expand_N_Object_Declaration; + + --------------------------------- + -- 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. + + procedure Expand_N_Subtype_Indication (N : Node_Id) is + Ran : Node_Id := Range_Expression (Constraint (N)); + Typ : Entity_Id := Entity (Subtype_Mark (N)); + + begin + if Nkind (Parent (N)) = N_Constrained_Array_Definition or else + Nkind (Parent (N)) = N_Slice + then + Resolve (Ran, Typ); + Apply_Range_Check (Ran, Typ); + end if; + end Expand_N_Subtype_Indication; + + --------------------------- + -- 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!) + + 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)); + Set_Others_Discrete_Choices + (Others_Node, Discrete_Choices (Last_Var)); + Set_Discrete_Choices (Last_Var, New_List (Others_Node)); + end if; + end Expand_N_Variant_Part; + + --------------------------------- + -- Expand_Previous_Access_Type -- + --------------------------------- + + procedure Expand_Previous_Access_Type (N : Node_Id; Def_Id : Entity_Id) is + T : Entity_Id := First_Entity (Current_Scope); + + begin + -- Find all access types declared in the current scope, whose + -- designated type is Def_Id. + + while Present (T) loop + if Is_Access_Type (T) + and then Designated_Type (T) = Def_Id + then + Build_Master_Entity (Def_Id); + Build_Master_Renaming (Parent (Def_Id), T); + end if; + + Next_Entity (T); + end loop; + end Expand_Previous_Access_Type; + + ------------------------------ + -- Expand_Record_Controller -- + ------------------------------ + + procedure Expand_Record_Controller (T : Entity_Id) is + Def : Node_Id := Type_Definition (Parent (T)); + Comp_List : Node_Id; + Comp_Decl : Node_Id; + Loc : Source_Ptr; + First_Comp : Node_Id; + Controller_Type : Entity_Id; + Ent : Entity_Id; + + begin + if Nkind (Def) = N_Derived_Type_Definition then + Def := Record_Extension_Part (Def); + end if; + + if Null_Present (Def) then + Set_Component_List (Def, + Make_Component_List (Sloc (Def), + Component_Items => Empty_List, + Variant_Part => Empty, + Null_Present => True)); + end if; + + Comp_List := Component_List (Def); + + if Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Loc := Sloc (Comp_List); + else + Loc := Sloc (First (Component_Items (Comp_List))); + end if; + + if Is_Return_By_Reference_Type (T) then + Controller_Type := RTE (RE_Limited_Record_Controller); + else + Controller_Type := RTE (RE_Record_Controller); + end if; + + Ent := Make_Defining_Identifier (Loc, Name_uController); + + Comp_Decl := + Make_Component_Declaration (Loc, + Defining_Identifier => Ent, + Subtype_Indication => New_Reference_To (Controller_Type, Loc)); + + if Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Set_Component_Items (Comp_List, New_List (Comp_Decl)); + 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. + + First_Comp := First (Component_Items (Comp_List)); + + if Chars (Defining_Identifier (First_Comp)) /= Name_uParent + and then Chars (Defining_Identifier (First_Comp)) /= Name_uTag + then + Insert_Before (First_Comp, Comp_Decl); + else + Insert_After (First_Comp, Comp_Decl); + end if; + end if; + + New_Scope (T); + Analyze (Comp_Decl); + 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. + + declare + E : Entity_Id := Last_Entity (T); + Comp : Entity_Id; + + begin + pragma Assert (Chars (E) = Name_uController); + + Set_Next_Entity (E, First_Entity (T)); + Set_First_Entity (T, E); + + Comp := Next_Entity (E); + while Next_Entity (Comp) /= E loop + Next_Entity (Comp); + end loop; + + Set_Next_Entity (Comp, Empty); + Set_Last_Entity (T, Comp); + end; + + End_Scope; + end Expand_Record_Controller; + + ------------------------ + -- Expand_Tagged_Root -- + ------------------------ + + procedure Expand_Tagged_Root (T : Entity_Id) is + Def : constant Node_Id := Type_Definition (Parent (T)); + Comp_List : Node_Id; + Comp_Decl : Node_Id; + Sloc_N : Source_Ptr; + + begin + if Null_Present (Def) then + Set_Component_List (Def, + Make_Component_List (Sloc (Def), + Component_Items => Empty_List, + Variant_Part => Empty, + Null_Present => True)); + end if; + + Comp_List := Component_List (Def); + + if Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Sloc_N := Sloc (Comp_List); + else + Sloc_N := Sloc (First (Component_Items (Comp_List))); + end if; + + Comp_Decl := + Make_Component_Declaration (Sloc_N, + Defining_Identifier => Tag_Component (T), + Subtype_Indication => + New_Reference_To (RTE (RE_Tag), Sloc_N)); + + if Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Set_Component_Items (Comp_List, New_List (Comp_Decl)); + Set_Null_Present (Comp_List, False); + + else + Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); + 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 + + Find_Type (Subtype_Indication (Comp_Decl)); + end Expand_Tagged_Root; + + ----------------------- + -- Freeze_Array_Type -- + ----------------------- + + procedure Freeze_Array_Type (N : Node_Id) is + Typ : constant Entity_Id := Entity (N); + Base : constant Entity_Id := Base_Type (Typ); + + begin + -- Nothing to do for packed case + + 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. + + Set_Has_Task (Base, Has_Task (Component_Type (Typ))); + Set_Has_Controlled_Component (Base, + Has_Controlled_Component (Component_Type (Typ)) + or else Is_Controlled (Component_Type (Typ))); + + 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- + -- ments, in which case the object declaration is carries the + -- No_Initialization flag. + + if Is_Itype (Base) + and then Nkind (Associated_Node_For_Itype (Base)) = + N_Object_Declaration + and then (Present (Expression (Associated_Node_For_Itype (Base))) + or else + No_Initialization (Associated_Node_For_Itype (Base))) + then + null; + + -- We do not need an init proc for string or 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 Base = Standard_String + or else Base = Standard_Wide_String + then + null; + + -- Otherwise we have to build an init proc for the subtype + + else + Build_Array_Init_Proc (Base, N); + end if; + end if; + + if Typ = Base and then Has_Controlled_Component (Base) then + Build_Controlling_Procs (Base); + end if; + end if; + end Freeze_Array_Type; + + ----------------------------- + -- Freeze_Enumeration_Type -- + ----------------------------- + + procedure Freeze_Enumeration_Type (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Entity (N); + Ent : Entity_Id; + Lst : List_Id; + Num : Nat; + Arr : Entity_Id; + Fent : Entity_Id; + Func : Entity_Id; + Ityp : Entity_Id; + + begin + -- Build list of literal references + + Lst := New_List; + Num := 0; + + Ent := First_Literal (Typ); + while Present (Ent) loop + Append_To (Lst, New_Reference_To (Ent, Sloc (Ent))); + Num := Num + 1; + Next_Literal (Ent); + end loop; + + -- 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 + + Arr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), 'A')); + + Append_Freeze_Action (Typ, + Make_Object_Declaration (Loc, + Defining_Identifier => Arr, + Constant_Present => True, + + Object_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Standard_Natural, Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => + Make_Integer_Literal (Loc, 0), + High_Bound => + Make_Integer_Literal (Loc, Num - 1))))), + + Subtype_Indication => New_Reference_To (Typ, Loc)), + + Expression => + Make_Aggregate (Loc, + Expressions => Lst))); + + Set_Enum_Pos_To_Rep (Typ, Arr); + + -- Now we build the function that converts representation values to + -- position values. This function has the form: + + -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is + -- begin + -- case ityp!(A) is + -- when enum-lit'Enum_Rep => return posval; + -- when enum-lit'Enum_Rep => return posval; + -- ... + -- when others => + -- [raise Program_Error when F] + -- return -1; + -- end case; + -- end; + + -- Note: the F parameter determines whether the others case (no valid + -- representation) raises Program_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: in the case of No_Run_Time mode, where we cannot handle + -- a program error in any case, we suppress the raise and just + -- return -1 unconditionally (this is an erroneous program in any + -- case and there is no obligation to raise Program_Error here!) + -- We also do this if pragma Restrictions (No_Exceptions) is active. + + -- First build list of cases + + Lst := New_List; + + Ent := First_Literal (Typ); + while Present (Ent) loop + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)), + Intval => Enumeration_Rep (Ent))), + + Statements => New_List ( + Make_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, + Intval => Enumeration_Pos (Ent)))))); + + Next_Literal (Ent); + end loop; + + -- Representations are signed + + if Enumeration_Rep (First_Literal (Typ)) < 0 then + if Esize (Typ) <= Standard_Integer_Size then + Ityp := Standard_Integer; + else + Ityp := Universal_Integer; + end if; + + -- Representations are unsigned + + else + if Esize (Typ) <= Standard_Integer_Size then + Ityp := RTE (RE_Unsigned); + else + Ityp := RTE (RE_Long_Long_Unsigned); + end if; + end if; + + -- In normal mode, add the others clause with the test + + if not (No_Run_Time or Restrictions (No_Exceptions)) then + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Raise_Program_Error (Loc, + Condition => Make_Identifier (Loc, Name_uF)), + Make_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, -1))))); + + -- If No_Run_Time mode, unconditionally return -1. Same + -- treatment if we have pragma Restrictions (No_Exceptions). + + else + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, -1))))); + end if; + + -- Now we can build the function body + + Fent := + Make_Defining_Identifier (Loc, Name_uRep_To_Pos); + + Func := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Fent, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uA), + Parameter_Type => New_Reference_To (Typ, Loc)), + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => New_Reference_To (Standard_Boolean, Loc))), + + Subtype_Mark => New_Reference_To (Standard_Integer, Loc)), + + Declarations => Empty_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Case_Statement (Loc, + Expression => + Unchecked_Convert_To (Ityp, + Make_Identifier (Loc, Name_uA)), + Alternatives => Lst)))); + + Set_TSS (Typ, Fent); + Set_Is_Pure (Fent); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Fent); + end if; + end Freeze_Enumeration_Type; + + ------------------------ + -- Freeze_Record_Type -- + ------------------------ + + 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); + Predef_List : List_Id; + + Renamed_Eq : Node_Id := Empty; + -- Could use some comments ??? + + begin + -- Build discriminant checking functions if not a derived type (for + -- derived types that are not tagged types, we always use the + -- discriminant checking functions of the parent type). However, for + -- untagged types the derivation may have taken place before the + -- parent was frozen, so we copy explicitly the discriminant checking + -- functions from the parent into the components of the derived type. + + if not Is_Derived_Type (Def_Id) + or else Has_New_Non_Standard_Rep (Def_Id) + or else Is_Tagged_Type (Def_Id) + then + Build_Discr_Checking_Funcs (Type_Decl); + + elsif Is_Derived_Type (Def_Id) + and then not Is_Tagged_Type (Def_Id) + and then Has_Discriminants (Def_Id) + then + declare + Old_Comp : Entity_Id; + + begin + Old_Comp := + First_Component (Base_Type (Underlying_Type (Etype (Def_Id)))); + Comp := First_Component (Def_Id); + + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Chars (Comp) = Chars (Old_Comp) + then + Set_Discriminant_Checking_Func (Comp, + Discriminant_Checking_Func (Old_Comp)); + end if; + + Next_Component (Old_Comp); + Next_Component (Comp); + end loop; + end; + end if; + + -- Update task and controlled component flags, because some of the + -- component types may have been private at the point of the record + -- declaration. + + Comp := First_Component (Def_Id); + + while Present (Comp) loop + if Has_Task (Etype (Comp)) then + Set_Has_Task (Def_Id); + + elsif Has_Controlled_Component (Etype (Comp)) + or else (Chars (Comp) /= Name_uParent + and then Is_Controlled (Etype (Comp))) + then + Set_Has_Controlled_Component (Def_Id); + end if; + + Next_Component (Comp); + 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. + + 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; + + begin + while Present (Elmt) loop + Subp := Node (Elmt); + + if Present (Alias (Subp)) then + Set_Has_Delayed_Freeze (Subp); + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + 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). + + 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. + + 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. + + if not Java_VM then + Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); + end if; + + -- 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, + Freeze_Entity + (Find_Prim_Op (Def_Id, Name_Adjust), Sloc (Def_Id))); + end if; + + Append_Freeze_Actions (Def_Id, + Freeze_Entity + (Find_Prim_Op (Def_Id, Name_Initialize), Sloc (Def_Id))); + + Append_Freeze_Actions (Def_Id, + Freeze_Entity + (Find_Prim_Op (Def_Id, Name_Finalize), Sloc (Def_Id))); + end if; + + -- Freeze rest of primitive operations + + Append_Freeze_Actions + (Def_Id, Predefined_Primitive_Freeze (Def_Id)); + end if; + + -- 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) + then + declare + Comps : constant Node_Id := + Component_List (Type_Definition (Type_Decl)); + + 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; + 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. + + if Is_Concurrent_Record_Type (Def_Id) + and then Has_Discriminants (Def_Id) + then + declare + Ctyp : constant Entity_Id := + Corresponding_Concurrent_Type (Def_Id); + Conc_Discr : Entity_Id; + Rec_Discr : Entity_Id; + Temp : Entity_Id; + + begin + Conc_Discr := First_Discriminant (Ctyp); + Rec_Discr := First_Discriminant (Def_Id); + + while Present (Conc_Discr) loop + Temp := Discriminal (Conc_Discr); + Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); + Set_Discriminal (Rec_Discr, Temp); + + Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); + Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); + + Next_Discriminant (Conc_Discr); + Next_Discriminant (Rec_Discr); + end loop; + end; + end if; + + if Has_Controlled_Component (Def_Id) then + if No (Controller_Component (Def_Id)) then + Expand_Record_Controller (Def_Id); + end if; + + Build_Controlling_Procs (Def_Id); + end if; + + 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 + + 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; + + 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 + -- node using Append_Freeze_Actions. + + procedure Freeze_Type (N : Node_Id) is + Def_Id : constant Entity_Id := Entity (N); + + begin + -- Process associated access types needing special processing + + if Present (Access_Types_To_Process (N)) then + declare + E : Elmt_Id := First_Elmt (Access_Types_To_Process (N)); + begin + while Present (E) loop + + -- If the access type is a RACW, call the expansion procedure + -- for this remote pointer. + + if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then + Remote_Types_Tagged_Full_View_Encountered (Def_Id); + end if; + + E := Next_Elmt (E); + end loop; + end; + end if; + + -- Freeze processing for record types + + if Is_Record_Type (Def_Id) then + 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. + + elsif Ekind (Def_Id) = E_Record_Subtype + and then Has_Discriminants (Def_Id) + and then Last_Entity (Def_Id) /= Last_Entity (Base_Type (Def_Id)) + and then Present (Controller_Component (Def_Id)) + then + declare + Old_C : Entity_Id := Controller_Component (Def_Id); + New_C : Entity_Id; + + begin + if Scope (Old_C) = Base_Type (Def_Id) then + + -- The entity is the one in the parent. Create new one. + + New_C := New_Copy (Old_C); + Set_Parent (New_C, Parent (Old_C)); + New_Scope (Def_Id); + Enter_Name (New_C); + End_Scope; + end if; + end; + end if; + + -- Freeze processing for array types + + elsif Is_Array_Type (Def_Id) then + Freeze_Array_Type (N); + + -- Freeze processing for access types + + -- For pool-specific access types, find out the pool object used for + -- this type, needs actual expansion of it in some cases. Here are the + -- different cases : + + -- 1. Rep Clause "for Def_Id'Storage_Size use 0;" + -- ---> don't use any storage pool + + -- 2. Rep Clause : for Def_Id'Storage_Size use Expr. + -- Expand: + -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment); + + -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" + -- ---> Storage Pool is the specified one + + -- See GNAT Pool packages in the Run-Time for more details + + elsif Ekind (Def_Id) = E_Access_Type + or else Ekind (Def_Id) = E_General_Access_Type + then + declare + Loc : constant Source_Ptr := Sloc (N); + Desig_Type : constant Entity_Id := Designated_Type (Def_Id); + Pool_Object : Entity_Id; + Siz_Exp : Node_Id; + + Freeze_Action_Typ : Entity_Id; + + begin + if Has_Storage_Size_Clause (Def_Id) then + Siz_Exp := Expression (Parent (Storage_Size_Variable (Def_Id))); + else + Siz_Exp := Empty; + end if; + + -- Case 1 + + -- Rep Clause "for Def_Id'Storage_Size use 0;" + -- ---> don't use any storage pool + + if Has_Storage_Size_Clause (Def_Id) + and then Compile_Time_Known_Value (Siz_Exp) + and then Expr_Value (Siz_Exp) = 0 + then + null; + + -- Case 2 + + -- Rep Clause : for Def_Id'Storage_Size use Expr. + -- ---> Expand: + -- Def_Id__Pool : Stack_Bounded_Pool + -- (Expr, DT'Size, DT'Alignment); + + elsif Has_Storage_Size_Clause (Def_Id) then + declare + DT_Size : Node_Id; + 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. + + if Is_Composite_Type (Desig_Type) + and then not Is_Constrained (Desig_Type) + then + DT_Size := + Make_Integer_Literal (Loc, 0); + + DT_Align := + Make_Integer_Literal (Loc, Maximum_Alignment); + + else + DT_Size := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Desig_Type, Loc), + Attribute_Name => Name_Max_Size_In_Storage_Elements); + + DT_Align := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Desig_Type, Loc), + Attribute_Name => Name_Alignment); + end if; + + Pool_Object := + 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 + + if Is_Frozen (Desig_Type) + and then (not Present (Freeze_Node (Desig_Type)) + or else Analyzed (Freeze_Node (Desig_Type))) + then + Freeze_Action_Typ := Def_Id; + + -- A Taft amendment type cannot get the freeze actions + -- since the full view is not there. + + elsif Is_Incomplete_Or_Private_Type (Desig_Type) + and then No (Full_View (Desig_Type)) + then + Freeze_Action_Typ := Def_Id; + + else + Freeze_Action_Typ := Desig_Type; + end if; + + Append_Freeze_Action (Freeze_Action_Typ, + Make_Object_Declaration (Loc, + Defining_Identifier => Pool_Object, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To + (RTE (RE_Stack_Bounded_Pool), Loc), + + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + + -- First discriminant is the Pool Size + + New_Reference_To ( + Storage_Size_Variable (Def_Id), Loc), + + -- Second discriminant is the element size + + DT_Size, + + -- Third discriminant is the alignment + + DT_Align))))); + + end; + + Set_Associated_Storage_Pool (Def_Id, Pool_Object); + + -- Case 3 + + -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" + -- ---> Storage Pool is the specified one + + elsif Present (Associated_Storage_Pool (Def_Id)) then + + -- Nothing to do the associated storage pool has been attached + -- when analyzing the rep. clause + + 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 + -- 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 + -- finalization support if not needed. + + if not Comes_From_Source (Def_Id) + and then not Has_Private_Declaration (Def_Id) + then + null; + + elsif (Controlled_Type (Desig_Type) + and then Convention (Desig_Type) /= Convention_Java) + or else (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... + -- Similarly, if No_Run_Time is enabled, the designated type + -- cannot be controlled. + + and then not In_Runtime (Def_Id) + and then not No_Run_Time) + + -- If the designated type is not frozen yet, its controlled + -- status must be retrieved explicitly. + + or else (Is_Array_Type (Desig_Type) + and then not Is_Frozen (Desig_Type) + and then Controlled_Type (Component_Type (Desig_Type))) + then + Set_Associated_Final_Chain (Def_Id, + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Def_Id), 'L'))); + + Append_Freeze_Action (Def_Id, + Make_Object_Declaration (Loc, + Defining_Identifier => Associated_Final_Chain (Def_Id), + Object_Definition => + New_Reference_To (RTE (RE_List_Controller), Loc))); + end if; + end; + + -- Freeze processing for enumeration types + + elsif Ekind (Def_Id) = E_Enumeration_Type then + + -- We only have something to do if we have a non-standard + -- representation (i.e. at least one literal whose pos value + -- is not the same as its representation) + + if Has_Non_Standard_Rep (Def_Id) then + Freeze_Enumeration_Type (N); + end if; + + -- private types that are completed by a derivation from a private + -- type have an internally generated full view, that needs to be + -- frozen. This must be done explicitly because the two views share + -- the freeze node, and the underlying full view is not visible when + -- the freeze node is analyzed. + + elsif Is_Private_Type (Def_Id) + and then Is_Derived_Type (Def_Id) + and then Present (Full_View (Def_Id)) + and then Is_Itype (Full_View (Def_Id)) + and then Has_Private_Declaration (Full_View (Def_Id)) + and then Freeze_Node (Full_View (Def_Id)) = N + then + Set_Entity (N, Full_View (Def_Id)); + 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. + + end if; + end Freeze_Type; + + ------------------------- + -- Get_Simple_Init_Val -- + ------------------------- + + function Get_Simple_Init_Val + (T : Entity_Id; + Loc : Source_Ptr) + return Node_Id + is + Val : Node_Id; + Typ : Node_Id; + Result : Node_Id; + Val_RE : RE_Id; + + begin + -- For scalars, we must have normalize/initialize scalars case + + if Is_Scalar_Type (T) then + pragma Assert (Init_Or_Norm_Scalars); + + -- Processing for Normalize_Scalars case + + if Normalize_Scalars then + + -- First prepare a value (out of subtype range if possible) + + 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); + + elsif Is_Modular_Integer_Type (T) then + Val := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Base_Type (T), Loc), + Attribute_Name => Name_Last); + + 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; + + Val := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Last); + end if; + + -- Here for Initialize_Scalars case + + else + if Is_Floating_Point_Type (T) then + if Root_Type (T) = Standard_Short_Float then + Val_RE := RE_IS_Isf; + elsif Root_Type (T) = Standard_Float then + Val_RE := RE_IS_Ifl; + + -- The form of the following test is quite deliberate, it + -- catches the case of architectures (the most common case) + -- where Long_Long_Float is the same as Long_Float, and in + -- such cases initializes Long_Long_Float variables from the + -- Long_Float constant (since the Long_Long_Float constant is + -- only for use on the x86). + + elsif Esize (Root_Type (T)) = Esize (Standard_Long_Float) then + Val_RE := RE_IS_Ilf; + + -- Otherwise we have extended real on an x86 + + else pragma Assert (Root_Type (T) = Standard_Long_Long_Float); + Val_RE := RE_IS_Ill; + end if; + + elsif Is_Unsigned_Type (Base_Type (T)) then + if Esize (T) = 8 then + Val_RE := RE_IS_Iu1; + elsif Esize (T) = 16 then + Val_RE := RE_IS_Iu2; + elsif Esize (T) = 32 then + Val_RE := RE_IS_Iu4; + else pragma Assert (Esize (T) = 64); + Val_RE := RE_IS_Iu8; + end if; + + else -- signed type + if Esize (T) = 8 then + Val_RE := RE_IS_Is1; + elsif Esize (T) = 16 then + Val_RE := RE_IS_Is2; + elsif Esize (T) = 32 then + Val_RE := RE_IS_Is4; + else pragma Assert (Esize (T) = 64); + 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. + + Result := Unchecked_Convert_To (Base_Type (T), Val); + + if Nkind (Result) = N_Unchecked_Type_Conversion then + Set_Kill_Range_Check (Result, True); + end if; + + return Result; + + -- String or Wide_String (must have Initialize_Scalars set) + + elsif Root_Type (T) = Standard_String + or else + Root_Type (T) = Standard_Wide_String + then + pragma Assert (Init_Or_Norm_Scalars); + + -- Build aggregate with an explicit qualification, because it + -- may otherwise be ambiguous in context. + + return + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Occurrence_Of (T, Loc), + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + Make_Others_Choice (Loc)), + Expression => + Get_Simple_Init_Val (Component_Type (T), Loc))))); + + -- Access type is initialized to null + + elsif Is_Access_Type (T) then + 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; + + -- Otherwise we have a case of a private type whose underlying type + -- needs simple initialization. In this case, we get the value for + -- the underlying type, then unchecked convert to the private type. + + else + pragma Assert + (Is_Private_Type (T) + and then Present (Underlying_Type (T))); + + Val := Get_Simple_Init_Val (Underlying_Type (T), Loc); + + -- A special case, if the underlying value is null, then qualify + -- it with the underlying type, so that the null is properly typed + + if Nkind (Val) = N_Null then + Val := + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Underlying_Type (T), Loc), + Expression => Val); + end if; + + return Unchecked_Convert_To (T, Val); + end if; + end Get_Simple_Init_Val; + + ------------------------------ + -- Has_New_Non_Standard_Rep -- + ------------------------------ + + function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is + begin + if not Is_Derived_Type (T) then + return Has_Non_Standard_Rep (T) + or else Has_Non_Standard_Rep (Root_Type (T)); + + -- If Has_Non_Standard_Rep is not set on the derived type, the + -- representation is fully inherited. + + elsif not Has_Non_Standard_Rep (T) then + return False; + + else + return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T)); + + -- May need a more precise check here: the First_Rep_Item may + -- be a stream attribute, which does not affect the representation + -- of the type ??? + end if; + end Has_New_Non_Standard_Rep; + + ---------------- + -- In_Runtime -- + ---------------- + + function In_Runtime (E : Entity_Id) return Boolean is + S1 : Entity_Id := Scope (E); + + begin + while Scope (S1) /= Standard_Standard loop + S1 := Scope (S1); + end loop; + + return Chars (S1) = Name_System or else Chars (S1) = Name_Ada; + end In_Runtime; + + ------------------ + -- Init_Formals -- + ------------------ + + function Init_Formals (Typ : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Typ); + Formals : List_Id; + + begin + -- First parameter is always _Init : in out typ. Note that we need + -- this to be in/out because in the case of the task record value, + -- there are default record fields (_Priority, _Size, -Task_Info) + -- that may be referenced in the generated initialization routine. + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uInit), + In_Present => True, + Out_Present => True, + Parameter_Type => New_Reference_To (Typ, Loc))); + + -- For task record value, or type that contains tasks, add two more + -- formals, _Master : Master_Id and _Chain : in out Activation_Chain + -- We also add these parameters for the task record type case. + + if Has_Task (Typ) + or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ)) + then + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uMaster), + Parameter_Type => New_Reference_To (RTE (RE_Master_Id), Loc))); + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uChain), + In_Present => True, + Out_Present => True, + Parameter_Type => + New_Reference_To (RTE (RE_Activation_Chain), Loc))); + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uTask_Id), + In_Present => True, + Parameter_Type => + New_Reference_To (RTE (RE_Task_Image_Type), Loc))); + end if; + + return Formals; + end Init_Formals; + + ------------------ + -- Make_Eq_Case -- + ------------------ + + -- <Make_Eq_if shared components> + -- case X.D1 is + -- when V1 => <Make_Eq_Case> on subcomponents + -- ... + -- 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); + Variant : Node_Id; + Alt_List : List_Id; + Result : List_Id := New_List; + + begin + Append_To (Result, Make_Eq_If (Node, Component_Items (CL))); + + if No (Variant_Part (CL)) then + return Result; + end if; + + Variant := First_Non_Pragma (Variants (Variant_Part (CL))); + + if No (Variant) then + return Result; + end if; + + Alt_List := New_List; + + while Present (Variant) loop + 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)))); + + 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)); + + return Result; + end Make_Eq_Case; + + ---------------- + -- Make_Eq_If -- + ---------------- + + -- Generates: + + -- if + -- X.C1 /= Y.C1 + -- or else + -- X.C2 /= Y.C2 + -- ... + -- then + -- return False; + -- end if; + + -- 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); + C : Node_Id; + Field_Name : Name_Id; + Cond : Node_Id; + + begin + if No (L) then + return Make_Null_Statement (Loc); + + else + Cond := Empty; + + C := First_Non_Pragma (L); + while Present (C) loop + Field_Name := Chars (Defining_Identifier (C)); + + -- The tags must not be compared they are not part of the value. + -- Note also that in the following, we use Make_Identifier for + -- the component names. Use of New_Reference_To to identify the + -- components would be incorrect because the wrong entities for + -- discriminants could be picked up in the private type case. + + if Field_Name /= Name_uTag then + Evolve_Or_Else (Cond, + Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_X), + Selector_Name => + Make_Identifier (Loc, Field_Name)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_Y), + Selector_Name => + Make_Identifier (Loc, Field_Name)))); + end if; + + Next_Non_Pragma (C); + end loop; + + if No (Cond) then + return Make_Null_Statement (Loc); + + else + return + Make_Implicit_If_Statement (Node, + Condition => Cond, + Then_Statements => New_List ( + Make_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_False, Loc)))); + end if; + end if; + end Make_Eq_If; + + ------------------------------------- + -- Make_Predefined_Primitive_Specs -- + ------------------------------------- + + procedure Make_Predefined_Primitive_Specs + (Tag_Typ : Entity_Id; + Predef_List : out List_Id; + Renamed_Eq : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Res : List_Id := New_List; + Prim : Elmt_Id; + Eq_Needed : Boolean; + Eq_Spec : Node_Id; + Eq_Name : Name_Id := Name_Op_Eq; + + function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean; + -- Returns true if Prim is a renaming of an unresolved predefined + -- equality operation. + + function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is + begin + return Chars (Prim) /= Name_Op_Eq + and then Present (Alias (Prim)) + and then Comes_From_Source (Prim) + and then Is_Intrinsic_Subprogram (Alias (Prim)) + and then Chars (Alias (Prim)) = Name_Op_Eq; + end Is_Predefined_Eq_Renaming; + + -- Start of processing for Make_Predefined_Primitive_Specs + + begin + Renamed_Eq := Empty; + + -- Spec of _Size + + Append_To (Res, Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + 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_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. + + -- We also skip these operations in No_Run_Time mode, where + -- dispatching stream operations cannot be used (this is currently + -- a No_Run_Time restriction). + + if not (No_Run_Time or else Is_Limited_Type (Tag_Typ)) then + Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uRead)); + Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uWrite)); + Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uInput)); + Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uOutput)); + end if; + + if not Is_Limited_Type (Tag_Typ) then + + -- Spec of "=" if expanded if the type is not limited and if a + -- user defined "=" was not already declared for the non-full + -- view of a private extension + + Eq_Needed := True; + + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + -- If a primitive is encountered that renames the predefined + -- equality operator before reaching any explicit equality + -- primitive, then we still need to create a predefined + -- equality function, because calls to it can occur via + -- the renaming. A new name is created for the equality + -- to avoid conflicting with any user-defined equality. + -- (Note that this doesn't account for renamings of + -- equality nested within subpackages???) + + if Is_Predefined_Eq_Renaming (Node (Prim)) then + Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); + + elsif Chars (Node (Prim)) = Name_Op_Eq + and then (No (Alias (Node (Prim))) + or else Nkind (Unit_Declaration_Node (Node (Prim))) = + N_Subprogram_Renaming_Declaration) + and then Etype (First_Formal (Node (Prim))) = + Etype (Next_Formal (First_Formal (Node (Prim)))) + + then + Eq_Needed := False; + exit; + + -- If the parent equality is abstract, the inherited equality is + -- abstract as well, and no body can be created for for it. + + elsif Chars (Node (Prim)) = Name_Op_Eq + and then Present (Alias (Node (Prim))) + and then Is_Abstract (Alias (Node (Prim))) + then + Eq_Needed := False; + exit; + end if; + + Next_Elmt (Prim); + end loop; + + -- If a renaming of predefined equality was found + -- but there was no user-defined equality (so Eq_Needed + -- is still true), then set the name back to Name_Op_Eq. + -- But in the case where a user-defined equality was + -- located after such a renaming, then the predefined + -- equality function is still needed, so Eq_Needed must + -- be set back to True. + + if Eq_Name /= Name_Op_Eq then + if Eq_Needed then + Eq_Name := Name_Op_Eq; + else + Eq_Needed := True; + end if; + end if; + + if Eq_Needed then + Eq_Spec := Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Eq_Name, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + Ret_Type => Standard_Boolean); + Append_To (Res, Eq_Spec); + + if Eq_Name /= Name_Op_Eq then + Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec)); + + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + + -- Any renamings of equality that appeared before an + -- overriding equality must be updated to refer to + -- the entity for the predefined equality, otherwise + -- calls via the renaming would get incorrectly + -- resolved to call the user-defined equality function. + + if Is_Predefined_Eq_Renaming (Node (Prim)) then + Set_Alias (Node (Prim), Renamed_Eq); + + -- Exit upon encountering a user-defined equality + + elsif Chars (Node (Prim)) = Name_Op_Eq + and then No (Alias (Node (Prim))) + then + exit; + end if; + + Next_Elmt (Prim); + end loop; + end if; + end if; + + -- Spec for dispatching assignment + + Append_To (Res, Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Name_uAssign, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), + Out_Present => True, + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))))); + 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 + -- when the type has controlled components and their body must be + -- generated. It is also impossible to provide those for tagged + -- types defined within s-finimp since it would involve circularity + -- problems + + if In_Finalization_Root (Tag_Typ) then + null; + + -- We also skip these in No_Run_Time mode where finalization is + -- never permissible. + + elsif No_Run_Time then + null; + + elsif Etype (Tag_Typ) = Tag_Typ or else Controlled_Type (Tag_Typ) then + + if not Is_Limited_Type (Tag_Typ) then + Append_To (Res, + Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Adjust)); + end if; + + Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Finalize)); + end if; + + Predef_List := Res; + end Make_Predefined_Primitive_Specs; + + --------------------------------- + -- Needs_Simple_Initialization -- + --------------------------------- + + function Needs_Simple_Initialization (T : Entity_Id) return Boolean is + begin + -- Cases needing simple initialization are access types, and, if pragma + -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar + -- types. + + if 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; + + -- If Initialize/Normalize_Scalars is in effect, string objects also + -- need initialization, unless they are created in the course of + -- expanding an aggregate (since in the latter case they will be + -- filled with appropriate initializing values before they are used). + + elsif Init_Or_Norm_Scalars + and then + (Root_Type (T) = Standard_String + or else Root_Type (T) = Standard_Wide_String) + and then + (not Is_Itype (T) + or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate) + then + return True; + + -- Check for private type, in which case test applies to the + -- underlying type of the private type. + + elsif Is_Private_Type (T) then + declare + RT : constant Entity_Id := Underlying_Type (T); + + begin + if Present (RT) then + return Needs_Simple_Initialization (RT); + else + return False; + end if; + end; + + else + return False; + end if; + end Needs_Simple_Initialization; + + ---------------------- + -- Predef_Deep_Spec -- + ---------------------- + + function Predef_Deep_Spec + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : Name_Id; + For_Body : Boolean := False) + return Node_Id + is + Prof : List_Id; + Type_B : Entity_Id; + + begin + if Name = Name_uDeep_Finalize then + Prof := New_List; + Type_B := Standard_Boolean; + + else + Prof := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_L), + In_Present => True, + Out_Present => True, + Parameter_Type => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); + Type_B := Standard_Short_Short_Integer; + end if; + + Append_To (Prof, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + In_Present => True, + Out_Present => True, + Parameter_Type => New_Reference_To (Tag_Typ, Loc))); + + Append_To (Prof, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_B), + Parameter_Type => New_Reference_To (Type_B, Loc))); + + return Predef_Spec_Or_Body (Loc, + Name => Name, + Tag_Typ => Tag_Typ, + Profile => Prof, + For_Body => For_Body); + end Predef_Deep_Spec; + + ------------------------- + -- Predef_Spec_Or_Body -- + ------------------------- + + function Predef_Spec_Or_Body + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : Name_Id; + Profile : List_Id; + Ret_Type : Entity_Id := Empty; + For_Body : Boolean := False) + return Node_Id + is + Id : Entity_Id := Make_Defining_Identifier (Loc, Name); + Spec : Node_Id; + + begin + Set_Is_Public (Id, Is_Public (Tag_Typ)); + + -- The internal flag is set to mark these declarations because + -- they have specific properties. First they are primitives even + -- if they are not defined in the type scope (the freezing point + -- is not necessarily in the same scope), furthermore the + -- predefined equality can be overridden by a user-defined + -- equality, no body will be generated in this case. + + Set_Is_Internal (Id); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Id); + end if; + + if No (Ret_Type) then + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Id, + Parameter_Specifications => Profile); + else + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Id, + Parameter_Specifications => Profile, + Subtype_Mark => + New_Reference_To (Ret_Type, Loc)); + end if; + + -- If body case, return empty subprogram body. Note that this is + -- ill-formed, because there is not even a null statement, and + -- certainly not a return in the function case. The caller is + -- expected to do surgery on the body to add the appropriate stuff. + + if For_Body then + return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty); + + -- For the case of _Input and _Ouput applied to an abstract type, + -- generate abstract specifications. These will never be called, + -- but we need the slots allocated in the dispatching table so + -- that typ'Class'Input and typ'Class'Output will work properly. + + elsif (Name = Name_uInput or else Name = Name_uOutput) + and then Is_Abstract (Tag_Typ) + then + return Make_Abstract_Subprogram_Declaration (Loc, Spec); + + -- Normal spec case, where we return a subprogram declaration + + else + return Make_Subprogram_Declaration (Loc, Spec); + end if; + end Predef_Spec_Or_Body; + + ----------------------------- + -- Predef_Stream_Attr_Spec -- + ----------------------------- + + function Predef_Stream_Attr_Spec + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : Name_Id; + For_Body : Boolean := False) + return Node_Id + is + Ret_Type : Entity_Id; + + begin + if Name = Name_uInput then + Ret_Type := Tag_Typ; + else + Ret_Type := Empty; + end if; + + return Predef_Spec_Or_Body (Loc, + Name => Name, + Tag_Typ => Tag_Typ, + Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name), + Ret_Type => Ret_Type, + For_Body => For_Body); + end Predef_Stream_Attr_Spec; + + --------------------------------- + -- Predefined_Primitive_Bodies -- + --------------------------------- + + function Predefined_Primitive_Bodies + (Tag_Typ : Entity_Id; + Renamed_Eq : Node_Id) + return List_Id + is + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Decl : Node_Id; + Res : List_Id := New_List; + Prim : Elmt_Id; + Eq_Needed : Boolean; + Eq_Name : Name_Id; + Ent : Entity_Id; + + begin + -- See if we have a predefined "=" operator + + if Present (Renamed_Eq) then + Eq_Needed := True; + Eq_Name := Chars (Renamed_Eq); + + else + Eq_Needed := False; + Eq_Name := No_Name; + + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + if Chars (Node (Prim)) = Name_Op_Eq + and then Is_Internal (Node (Prim)) + then + Eq_Needed := True; + Eq_Name := Name_Op_Eq; + end if; + + Next_Elmt (Prim); + end loop; + end if; + + -- Body of _Size + + Decl := Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + 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_Long_Long_Integer, + For_Body => True); + + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_X), + Attribute_Name => Name_Size))))); + + Append_To (Res, Decl); + + -- Bodies for Dispatching stream IO routines. We need these only for + -- non-limited types (in the limited case there is no dispatching). + -- and we always skip them in No_Run_Time mode where streams are not + -- permitted. + + if not (Is_Limited_Type (Tag_Typ) or else No_Run_Time) then + if No (TSS (Tag_Typ, Name_uRead)) then + Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + + if No (TSS (Tag_Typ, Name_uWrite)) then + 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 No (TSS (Tag_Typ, Name_uInput)) then + Build_Record_Or_Elementary_Input_Function + (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + + if No (TSS (Tag_Typ, Name_uOutput)) then + Build_Record_Or_Elementary_Output_Procedure + (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + end if; + end if; + + if not Is_Limited_Type (Tag_Typ) then + + -- Body for equality + + if Eq_Needed then + + Decl := Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Eq_Name, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + + Ret_Type => Standard_Boolean, + For_Body => True); + + declare + Def : constant Node_Id := Parent (Tag_Typ); + Variant_Case : Boolean := Has_Discriminants (Tag_Typ); + Comps : Node_Id := Empty; + Typ_Def : Node_Id := Type_Definition (Def); + Stmts : List_Id := New_List; + + begin + if Variant_Case then + if Nkind (Typ_Def) = N_Derived_Type_Definition then + Typ_Def := Record_Extension_Part (Typ_Def); + end if; + + if Present (Typ_Def) then + Comps := Component_List (Typ_Def); + end if; + + Variant_Case := Present (Comps) + and then Present (Variant_Part (Comps)); + end if; + + if Variant_Case then + Append_To (Stmts, + Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def))); + Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps)); + Append_To (Stmts, + Make_Return_Statement (Loc, + Expression => New_Reference_To (Standard_True, Loc))); + + else + Append_To (Stmts, + Make_Return_Statement (Loc, + Expression => + Expand_Record_Equality (Tag_Typ, + Typ => Tag_Typ, + Lhs => Make_Identifier (Loc, Name_X), + Rhs => Make_Identifier (Loc, Name_Y), + Bodies => Declarations (Decl)))); + end if; + + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + end; + Append_To (Res, Decl); + end if; + + -- Body for dispatching assignment + + Decl := Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Name_uAssign, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), + Out_Present => True, + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + For_Body => True); + + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_X), + Expression => Make_Identifier (Loc, Name_Y))))); + + Append_To (Res, Decl); + end if; + + -- Generate dummy bodies for finalization actions of types that have + -- no controlled components. + + -- Skip this processing if we are in the finalization routine in the + -- runtime itself, otherwise we get hopelessly circularly confused! + + if In_Finalization_Root (Tag_Typ) then + null; + + -- Skip this in no run time mode (where finalization is never allowed) + + elsif No_Run_Time then + null; + + elsif (Etype (Tag_Typ) = Tag_Typ or else Is_Controlled (Tag_Typ)) + and then not Has_Controlled_Component (Tag_Typ) + then + if not Is_Limited_Type (Tag_Typ) then + Decl := Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Adjust, True); + + if Is_Controlled (Tag_Typ) then + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Make_Adjust_Call ( + Ref => Make_Identifier (Loc, Name_V), + Typ => Tag_Typ, + Flist_Ref => Make_Identifier (Loc, Name_L), + With_Attach => Make_Identifier (Loc, Name_B)))); + + else + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Null_Statement (Loc)))); + end if; + + Append_To (Res, Decl); + end if; + + Decl := Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Finalize, True); + + if Is_Controlled (Tag_Typ) then + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Make_Final_Call ( + Ref => Make_Identifier (Loc, Name_V), + Typ => Tag_Typ, + With_Detach => Make_Identifier (Loc, Name_B)))); + + else + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Null_Statement (Loc)))); + end if; + + Append_To (Res, Decl); + end if; + + return Res; + end Predefined_Primitive_Bodies; + + --------------------------------- + -- Predefined_Primitive_Freeze -- + --------------------------------- + + function Predefined_Primitive_Freeze + (Tag_Typ : Entity_Id) + return List_Id + is + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Res : List_Id := New_List; + Prim : Elmt_Id; + Frnodes : List_Id; + + begin + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + if Is_Internal (Node (Prim)) then + Frnodes := Freeze_Entity (Node (Prim), Loc); + + if Present (Frnodes) then + Append_List_To (Res, Frnodes); + end if; + end if; + + Next_Elmt (Prim); + end loop; + + return Res; + end Predefined_Primitive_Freeze; + +end Exp_Ch3; |