Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/exp_ch3.adb @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/ada/exp_ch3.adb Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,10463 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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 COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Aspects; use Aspects; +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Aggr; use Exp_Aggr; +with Exp_Atag; use Exp_Atag; +with Exp_Ch4; use Exp_Ch4; +with Exp_Ch6; use Exp_Ch6; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch9; use Exp_Ch9; +with Exp_Dbug; use Exp_Dbug; +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 Ghost; use Ghost; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Attr; use Sem_Attr; +with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Disp; use Sem_Disp; +with Sem_Eval; use Sem_Eval; +with Sem_Mech; use Sem_Mech; +with Sem_Res; use Sem_Res; +with Sem_SCIL; use Sem_SCIL; +with Sem_Type; use Sem_Type; +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 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. + + 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 Build_Init_Procedure among other places. + -- If the flag Use_Dl is set, the list is built using the already + -- defined discriminals of the type, as is the case for concurrent + -- types with discriminants. Otherwise new identifiers are created, + -- with the source names of the discriminants. + + function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id; + -- This function builds a static aggregate that can serve as the initial + -- value for an array type whose bounds are static, and whose component + -- type is a composite type that has a static equivalent aggregate. + -- The equivalent array aggregate is used both for object initialization + -- and for component initialization, when used in the following function. + + function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id; + -- This function builds a static aggregate that can serve as the initial + -- value for a record type whose components are scalar and initialized + -- with compile-time values, or arrays with similar initialization or + -- defaults. When possible, initialization of an object of the type can + -- be achieved by using a copy of the aggregate as an initial value, thus + -- removing the implicit call that would otherwise constitute elaboration + -- code. + + procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id); + -- Build record initialization procedure. N is the type declaration + -- node, and Rec_Ent is the corresponding entity for the record type. + + procedure Build_Slice_Assignment (Typ : Entity_Id); + -- Build assignment procedure for one-dimensional arrays of controlled + -- types. Other array and slice assignments are expanded in-line, but + -- the code expansion for controlled components (when control actions + -- are active) can lead to very large blocks that GCC3 handles poorly. + + procedure Build_Untagged_Equality (Typ : Entity_Id); + -- AI05-0123: Equality on untagged records composes. This procedure + -- builds the equality routine for an untagged record that has components + -- of a record type that has user-defined primitive equality operations. + -- The resulting operation is a TSS subprogram. + + procedure Build_Variant_Record_Equality (Typ : Entity_Id); + -- Create An Equality function for the untagged variant record Typ and + -- attach it to the TSS list + + procedure Check_Stream_Attributes (Typ : Entity_Id); + -- Check that if a limited extension has a parent with user-defined stream + -- attributes, and does not itself have user-defined stream-attributes, + -- then any limited component of the extension also has the corresponding + -- user-defined stream attributes. + + procedure Clean_Task_Names + (Typ : Entity_Id; + Proc_Id : Entity_Id); + -- If an initialization procedure includes calls to generate names + -- for task subcomponents, indicate that secondary stack cleanup is + -- needed after an initialization. Typ is the component type, and Proc_Id + -- the initialization procedure for the enclosing composite type. + + procedure Expand_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 Expand_Freeze_Class_Wide_Type (N : Node_Id); + -- Freeze a class-wide type. Build routine Finalize_Address for the purpose + -- of finalizing controlled derivations from the class-wide's root type. + + procedure Expand_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 Expand_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. + + 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 type, the _Tag field being inherited by the descendants. + + procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id); + -- Treat user-defined stream operations as renaming_as_body if the + -- subprogram they rename is not frozen when the type is frozen. + + procedure Initialization_Warning (E : Entity_Id); + -- If static elaboration of the package is requested, indicate + -- when a type does meet the conditions for static initialization. If + -- E is a type, it has components that have no static initialization. + -- if E is an entity, its initial expression is not compile-time known. + + 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_Name : String + -- + -- The caller must append additional entries for discriminants if required. + + function Inline_Init_Proc (Typ : Entity_Id) return Boolean; + -- Returns true if the initialization procedure of Typ should be inlined + + 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 Is_User_Defined_Equality (Prim : Node_Id) return Boolean; + -- Returns true if Prim is a user defined equality function + + function Make_Eq_Body + (Typ : Entity_Id; + Eq_Name : Name_Id) return Node_Id; + -- Build the body of a primitive equality operation for a tagged record + -- type, or in Ada 2012 for any record type that has components with a + -- user-defined equality. Factored out of Predefined_Primitive_Bodies. + + function Make_Eq_Case + (E : Entity_Id; + CL : Node_Id; + Discrs : Elist_Id := New_Elmt_List) return List_Id; + -- Building block for variant record equality. Defined to share the code + -- between the tagged and untagged 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). E provides the Sloc to be used for the + -- generated code. + -- + -- IF E is an unchecked_union, Discrs is the list of formals created for + -- the inferred discriminants of one operand. These formals are used in + -- the generated case statements for each variant of the unchecked union. + + function Make_Eq_If + (E : Entity_Id; + L : List_Id) return Node_Id; + -- Building block for variant record equality. Defined to share the code + -- between the tagged and untagged 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). E provides the Sloc to be used for the + -- generated code. + + function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id; + -- Search for a renaming of the inequality dispatching primitive of + -- this tagged type. If found then build and return the corresponding + -- rename-as-body inequality subprogram; otherwise return Empty. + + procedure Make_Predefined_Primitive_Specs + (Tag_Typ : Entity_Id; + Predef_List : out List_Id; + Renamed_Eq : out Entity_Id); + -- Create a list with the specs of the predefined primitive operations. + -- For tagged types that are interfaces all these primitives are defined + -- abstract. + -- + -- The following entries are present for all tagged types, and provide + -- the results of the corresponding attribute applied to the object. + -- Dispatching is required in general, since the result of the attribute + -- will vary with the actual object subtype. + -- + -- _size provides result of 'Size attribute + -- typSR provides result of 'Read attribute + -- typSW provides result of 'Write attribute + -- typSI provides result of 'Input attribute + -- typSO provides result of 'Output attribute + -- + -- The following entries are additionally present for non-limited tagged + -- types, and implement additional dispatching operations for predefined + -- operations: + -- + -- _equality implements "=" operator + -- _assign implements assignment operation + -- typDF implements deep finalization + -- typDA implements deep adjust + -- + -- The latter two are empty procedures unless the type contains some + -- controlled components that require finalization actions (the deep + -- in the name refers to the fact that the action applies to components). + -- + -- 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. + + procedure Make_Controlling_Function_Wrappers + (Tag_Typ : Entity_Id; + Decl_List : out List_Id; + Body_List : out List_Id); + -- Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions + -- associated with inherited functions with controlling results which + -- are not overridden. The body of each wrapper function consists solely + -- of a return statement whose expression is an extension aggregate + -- invoking the inherited subprogram's parent subprogram and extended + -- with a null association list. + + function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id; + -- Ada 2005 (AI-251): Makes specs for null procedures associated with any + -- null procedures inherited from an interface type that have not been + -- overridden. Only one null procedure will be created for a given set of + -- inherited null procedures with homographic profiles. + + 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 : TSS_Name_Type; + For_Body : Boolean := False) return Node_Id; + -- Specialized version of Predef_Spec_Or_Body that apply to read, write, + -- input and output attribute whose specs are constructed in Exp_Strm. + + function Predef_Deep_Spec + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : TSS_Name_Type; + 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 : Entity_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 freezing. + + function Stream_Operation_OK + (Typ : Entity_Id; + Operation : TSS_Name_Type) return Boolean; + -- Check whether the named stream operation must be emitted for a given + -- type. The rules for inheritance of stream attributes by type extensions + -- are enforced by this function. Furthermore, various restrictions prevent + -- the generation of these operations, as a useful optimization or for + -- certification purposes and to save unnecessary generated code. + + -------------------------- + -- 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 that 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_Temporary (Loc, '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 + Comp_Type : constant Entity_Id := Component_Type (A_Type); + Comp_Simple_Init : constant Boolean := + Needs_Simple_Initialization + (T => Comp_Type, + Consider_IS => + not (Validity_Check_Copies and Is_Bit_Packed_Array (A_Type))); + -- True if the component needs simple initialization, based on its type, + -- plus the fact that we do not do simple initialization for components + -- of bit-packed arrays when validity checks are enabled, because the + -- initialization with deliberately out-of-range values would raise + -- Constraint_Error. + + Body_Stmts : List_Id; + Has_Default_Init : Boolean; + Index_List : List_Id; + Loc : Source_Ptr; + Proc_Id : Entity_Id; + + function Init_Component return List_Id; + -- Create one statement to initialize one array component, designated + -- by a full set of indexes. + + 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 Has_Default_Aspect (A_Type) then + Set_Assignment_OK (Comp); + return New_List ( + Make_Assignment_Statement (Loc, + Name => Comp, + Expression => + Convert_To (Comp_Type, + Default_Aspect_Component_Value (First_Subtype (A_Type))))); + + elsif Comp_Simple_Init then + Set_Assignment_OK (Comp); + return New_List ( + Make_Assignment_Statement (Loc, + Name => Comp, + Expression => + Get_Simple_Init_Val + (Comp_Type, Nod, Component_Size (A_Type)))); + + else + Clean_Task_Names (Comp_Type, Proc_Id); + return + Build_Initialization_Call + (Loc, Comp, Comp_Type, + In_Init_Proc => True, + Enclos_Type => 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 Comp_Simple_Init + and then not Has_Task (Comp_Type) + and then not Has_Default_Aspect (A_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_Occurrence_Of (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 + -- The init proc is created when analyzing the freeze node for the type, + -- but it properly belongs with the array type declaration. However, if + -- the freeze node is for a subtype of a type declared in another unit + -- it seems preferable to use the freeze node as the source location of + -- the init proc. In any case this is preferable for gcov usage, and + -- the Sloc is not otherwise used by the compiler. + + if In_Open_Scopes (Scope (A_Type)) then + Loc := Sloc (A_Type); + else + Loc := Sloc (Nod); + end if; + + -- Nothing to generate in the following cases: + + -- 1. Initialization is suppressed for the type + -- 2. An initialization already exists for the base type + + if Initialization_Suppressed (A_Type) + or else Present (Base_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 public entity + -- 5. The array type has a Default_Component_Value aspect + + -- 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_[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. + + Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type) + or else Comp_Simple_Init + or else Has_Task (Comp_Type) + or else Has_Default_Aspect (A_Type); + + if Has_Default_Init + or else (not Restriction_Active (No_Initialize_Scalars) + and then Is_Public (A_Type) + and then not Is_Standard_String_Type (A_Type)) + then + Proc_Id := + Make_Defining_Identifier (Loc, + Chars => Make_Init_Proc_Name (A_Type)); + + -- If No_Default_Initialization restriction is active, then we don't + -- want to build an init_proc, but we need to mark that an init_proc + -- would be needed if this restriction was not active (so that we can + -- detect attempts to call it), so set a dummy init_proc in place. + -- This is only done though when actual default initialization is + -- needed (and not done when only Is_Public is True), since otherwise + -- objects such as arrays of scalars could be wrongly flagged as + -- violating the restriction. + + if Restriction_Active (No_Default_Initialization) then + if Has_Default_Init then + Set_Init_Proc (A_Type, Proc_Id); + end if; + + return; + end if; + + Body_Stmts := Init_One_Dimension (1); + + Discard_Node ( + 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_Internal (Proc_Id); + Set_Has_Completion (Proc_Id); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Proc_Id); + end if; + + -- Set Inlined on Init_Proc if it is set on the Init_Proc of the + -- component type itself (see also Build_Record_Init_Proc). + + Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Comp_Type)); + + -- 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 + + -- We must skip SCIL nodes because they may have been added to this + -- list by Insert_Actions. + + and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement + then + Set_Is_Null_Init_Proc (Proc_Id); + + else + -- Try to build a static aggregate to statically initialize + -- objects of the type. This can only be done for constrained + -- one-dimensional arrays with static bounds. + + Set_Static_Initialization + (Proc_Id, + Build_Equivalent_Array_Aggregate (First_Subtype (A_Type))); + end if; + end if; + end Build_Array_Init_Proc; + + -------------------------------- + -- 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; + -- 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 + -- second alternative is an OTHERS choice that will return True + -- indicating the discriminant did not match. + + 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 + Alt_List : constant List_Id := New_List; + Actuals_List : List_Id; + Case_Node : Node_Id; + Case_Alt_Node : Node_Id; + Choice : Node_Id; + Choice_List : List_Id; + D : Entity_Id; + Return_Node : Node_Id; + + begin + 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_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Enclosing_Func_Id, Loc), + Parameter_Associations => + Actuals_List)); + + else + Return_Node := + Make_Simple_Return_Statement (Loc, + Expression => + New_Occurrence_Of (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_Simple_Return_Statement (Loc, + Expression => + New_Occurrence_Of (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)); + Set_Is_Discriminant_Check_Function (Func_Id); + + 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_Result_Definition (Spec_Node, + New_Occurrence_Of (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; + + Analyze (Body_Node); + + 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, and + -- label all components of that variant with the function's name. + -- We only Generate a discriminant-checking function when the + -- variant is not empty, to prevent the creation of dead code. + + Discr_Name := Entity (Name (Variant_Part_Node)); + Variant := First_Non_Pragma (Variants (Variant_Part_Node)); + + while Present (Variant) loop + Component_List_Node := Component_List (Variant); + + if not Null_Present (Component_List_Node) then + Func_Id := Build_Dcheck_Function (Discr_Name, Variant); + + 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 + Loc : Source_Ptr := Sloc (Rec_Id); + Parameter_List : constant List_Id := New_List; + D : Entity_Id; + Formal : Entity_Id; + Formal_Type : Entity_Id; + Param_Spec_Node : Node_Id; + + 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); + Formal_Type := Etype (Formal); + else + Formal := Make_Defining_Identifier (Loc, Chars (D)); + Formal_Type := Etype (D); + end if; + + Param_Spec_Node := + Make_Parameter_Specification (Loc, + Defining_Identifier => Formal, + Parameter_Type => + New_Occurrence_Of (Formal_Type, Loc)); + Append (Param_Spec_Node, Parameter_List); + Next_Discriminant (D); + end loop; + end if; + + return Parameter_List; + end Build_Discriminant_Formals; + + -------------------------------------- + -- Build_Equivalent_Array_Aggregate -- + -------------------------------------- + + function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (T); + Comp_Type : constant Entity_Id := Component_Type (T); + Index_Type : constant Entity_Id := Etype (First_Index (T)); + Proc : constant Entity_Id := Base_Init_Proc (T); + Lo, Hi : Node_Id; + Aggr : Node_Id; + Expr : Node_Id; + + begin + if not Is_Constrained (T) + or else Number_Dimensions (T) > 1 + or else No (Proc) + then + Initialization_Warning (T); + return Empty; + end if; + + Lo := Type_Low_Bound (Index_Type); + Hi := Type_High_Bound (Index_Type); + + if not Compile_Time_Known_Value (Lo) + or else not Compile_Time_Known_Value (Hi) + then + Initialization_Warning (T); + return Empty; + end if; + + if Is_Record_Type (Comp_Type) + and then Present (Base_Init_Proc (Comp_Type)) + then + Expr := Static_Initialization (Base_Init_Proc (Comp_Type)); + + if No (Expr) then + Initialization_Warning (T); + return Empty; + end if; + + else + Initialization_Warning (T); + return Empty; + end if; + + Aggr := Make_Aggregate (Loc, No_List, New_List); + Set_Etype (Aggr, T); + Set_Aggregate_Bounds (Aggr, + Make_Range (Loc, + Low_Bound => New_Copy (Lo), + High_Bound => New_Copy (Hi))); + Set_Parent (Aggr, Parent (Proc)); + + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => + New_List ( + Make_Range (Loc, + Low_Bound => New_Copy (Lo), + High_Bound => New_Copy (Hi))), + Expression => Expr)); + + if Static_Array_Aggregate (Aggr) then + return Aggr; + else + Initialization_Warning (T); + return Empty; + end if; + end Build_Equivalent_Array_Aggregate; + + --------------------------------------- + -- Build_Equivalent_Record_Aggregate -- + --------------------------------------- + + function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is + Agg : Node_Id; + Comp : Entity_Id; + Comp_Type : Entity_Id; + + -- Start of processing for Build_Equivalent_Record_Aggregate + + begin + if not Is_Record_Type (T) + or else Has_Discriminants (T) + or else Is_Limited_Type (T) + or else Has_Non_Standard_Rep (T) + then + Initialization_Warning (T); + return Empty; + end if; + + Comp := First_Component (T); + + -- A null record needs no warning + + if No (Comp) then + return Empty; + end if; + + while Present (Comp) loop + + -- Array components are acceptable if initialized by a positional + -- aggregate with static components. + + if Is_Array_Type (Etype (Comp)) then + Comp_Type := Component_Type (Etype (Comp)); + + if Nkind (Parent (Comp)) /= N_Component_Declaration + or else No (Expression (Parent (Comp))) + or else Nkind (Expression (Parent (Comp))) /= N_Aggregate + then + Initialization_Warning (T); + return Empty; + + elsif Is_Scalar_Type (Component_Type (Etype (Comp))) + and then + (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type)) + or else + not Compile_Time_Known_Value (Type_High_Bound (Comp_Type))) + then + Initialization_Warning (T); + return Empty; + + elsif + not Static_Array_Aggregate (Expression (Parent (Comp))) + then + Initialization_Warning (T); + return Empty; + end if; + + elsif Is_Scalar_Type (Etype (Comp)) then + Comp_Type := Etype (Comp); + + if Nkind (Parent (Comp)) /= N_Component_Declaration + or else No (Expression (Parent (Comp))) + or else not Compile_Time_Known_Value (Expression (Parent (Comp))) + or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type)) + or else not + Compile_Time_Known_Value (Type_High_Bound (Comp_Type)) + then + Initialization_Warning (T); + return Empty; + end if; + + -- For now, other types are excluded + + else + Initialization_Warning (T); + return Empty; + end if; + + Next_Component (Comp); + end loop; + + -- All components have static initialization. Build positional aggregate + -- from the given expressions or defaults. + + Agg := Make_Aggregate (Sloc (T), New_List, New_List); + Set_Parent (Agg, Parent (T)); + + Comp := First_Component (T); + while Present (Comp) loop + Append + (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg)); + Next_Component (Comp); + end loop; + + Analyze_And_Resolve (Agg, T); + return Agg; + end Build_Equivalent_Record_Aggregate; + + ------------------------------- + -- 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; + With_Default_Init : Boolean := False; + Constructor_Ref : Node_Id := Empty) return List_Id + is + Res : constant List_Id := New_List; + + Full_Type : Entity_Id; + + procedure Check_Predicated_Discriminant + (Val : Node_Id; + Discr : Entity_Id); + -- Discriminants whose subtypes have predicates are checked in two + -- cases: + -- a) When an object is default-initialized and assertions are enabled + -- we check that the value of the discriminant obeys the predicate. + + -- b) In all cases, if the discriminant controls a variant and the + -- variant has no others_choice, Constraint_Error must be raised if + -- the predicate is violated, because there is no variant covered + -- by the illegal discriminant value. + + ----------------------------------- + -- Check_Predicated_Discriminant -- + ----------------------------------- + + procedure Check_Predicated_Discriminant + (Val : Node_Id; + Discr : Entity_Id) + is + Typ : constant Entity_Id := Etype (Discr); + + procedure Check_Missing_Others (V : Node_Id); + -- ??? + + -------------------------- + -- Check_Missing_Others -- + -------------------------- + + procedure Check_Missing_Others (V : Node_Id) is + Alt : Node_Id; + Choice : Node_Id; + Last_Var : Node_Id; + + begin + Last_Var := Last_Non_Pragma (Variants (V)); + Choice := First (Discrete_Choices (Last_Var)); + + -- An others_choice is added during expansion for gcc use, but + -- does not cover the illegality. + + if Entity (Name (V)) = Discr then + if Present (Choice) + and then (Nkind (Choice) /= N_Others_Choice + or else not Comes_From_Source (Choice)) + then + Check_Expression_Against_Static_Predicate (Val, Typ); + + if not Is_Static_Expression (Val) then + Prepend_To (Res, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => Make_Predicate_Call (Typ, Val)), + Reason => CE_Invalid_Data)); + end if; + end if; + end if; + + -- Check whether some nested variant is ruled by the predicated + -- discriminant. + + Alt := First (Variants (V)); + while Present (Alt) loop + if Nkind (Alt) = N_Variant + and then Present (Variant_Part (Component_List (Alt))) + then + Check_Missing_Others + (Variant_Part (Component_List (Alt))); + end if; + + Next (Alt); + end loop; + end Check_Missing_Others; + + -- Local variables + + Def : Node_Id; + + -- Start of processing for Check_Predicated_Discriminant + + begin + if Ekind (Base_Type (Full_Type)) = E_Record_Type then + Def := Type_Definition (Parent (Base_Type (Full_Type))); + else + return; + end if; + + if Policy_In_Effect (Name_Assert) = Name_Check + and then not Predicates_Ignored (Etype (Discr)) + then + Prepend_To (Res, Make_Predicate_Check (Typ, Val)); + end if; + + -- If discriminant controls a variant, verify that predicate is + -- obeyed or else an Others_Choice is present. + + if Nkind (Def) = N_Record_Definition + and then Present (Variant_Part (Component_List (Def))) + and then Policy_In_Effect (Name_Assert) = Name_Ignore + then + Check_Missing_Others (Variant_Part (Component_List (Def))); + end if; + end Check_Predicated_Discriminant; + + -- Local variables + + Arg : Node_Id; + Args : List_Id; + Decls : List_Id; + Decl : Node_Id; + Discr : Entity_Id; + First_Arg : Node_Id; + Full_Init_Type : Entity_Id; + Init_Call : Node_Id; + Init_Type : Entity_Id; + Proc : Entity_Id; + + -- Start of processing for Build_Initialization_Call + + begin + pragma Assert (Constructor_Ref = Empty + or else Is_CPP_Constructor_Call (Constructor_Ref)); + + if No (Constructor_Ref) then + Proc := Base_Init_Proc (Typ); + else + Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref))); + end if; + + pragma Assert (Present (Proc)); + Init_Type := Etype (First_Formal (Proc)); + Full_Init_Type := Underlying_Type (Init_Type); + + -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars + -- is active (in which case we make the call anyway, since in the + -- actual compiled client it may be non null). + + if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then + return Empty_List; + + -- Nothing to do for an array of controlled components that have only + -- the inherited Initialize primitive. This is a useful optimization + -- for CodePeer. + + elsif Is_Trivial_Subprogram (Proc) + and then Is_Array_Type (Full_Init_Type) + then + return New_List (Make_Null_Statement (Loc)); + end if; + + -- Use the [underlying] full view when dealing with a private type. This + -- may require several steps depending on derivations. + + Full_Type := Typ; + loop + if Is_Private_Type (Full_Type) then + if Present (Full_View (Full_Type)) then + Full_Type := Full_View (Full_Type); + + elsif Present (Underlying_Full_View (Full_Type)) then + Full_Type := Underlying_Full_View (Full_Type); + + -- When a private type acts as a generic actual and lacks a full + -- view, use the base type. + + elsif Is_Generic_Actual_Type (Full_Type) then + Full_Type := Base_Type (Full_Type); + + elsif Ekind (Full_Type) = E_Private_Subtype + and then (not Has_Discriminants (Full_Type) + or else No (Discriminant_Constraint (Full_Type))) + then + Full_Type := Etype (Full_Type); + + -- The loop has recovered the [underlying] full view, stop the + -- traversal. + + else + exit; + end if; + + -- The type is not private, nothing to do + + else + exit; + end if; + end loop; + + -- 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 Restriction_Active (No_Task_Hierarchy) then + Append_To (Args, + New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); + else + Append_To (Args, Make_Identifier (Loc, Name_uMaster)); + end if; + + -- Add _Chain (not done for sequential elaboration policy, see + -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). + + if Partition_Elaboration_Policy /= 'S' then + Append_To (Args, Make_Identifier (Loc, Name_uChain)); + end if; + + -- Ada 2005 (AI-287): In case of default initialized components + -- with tasks, we generate a null string actual parameter. + -- This is just a workaround that must be improved later??? + + if With_Default_Init then + Append_To (Args, + Make_String_Literal (Loc, + Strval => "")); + + else + Decls := + Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc); + Decl := Last (Decls); + + Append_To (Args, + New_Occurrence_Of (Defining_Identifier (Decl), Loc)); + Append_List (Decls, Res); + end if; + + 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 the target has access discriminants, and is constrained by + -- an access to the enclosing construct, i.e. a current instance, + -- replace the reference to the type by a reference to the object. + + if 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); + + elsif 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_Occurrence_Of (Discriminal (Entity (Arg)), Loc); + + -- 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_No_Checks (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). + -- In addition, if a predicate check is needed on the value + -- of the discriminant, insert it ahead of the call. + + Arg := New_Copy_Tree (Arg, New_Sloc => Loc); + end if; + + if Has_Predicates (Etype (Discr)) then + Check_Predicated_Discriminant (Arg, Discr); + end if; + end if; + + -- Ada 2005 (AI-287): In case of default initialized components, + -- if the component is constrained with a discriminant of the + -- enclosing type, we need to generate the corresponding selected + -- component node to access the discriminant value. In other cases + -- this is not required, either because we are inside the init + -- proc and we use the corresponding formal, or else because the + -- component is constrained by an expression. + + if With_Default_Init + and then Nkind (Id_Ref) = N_Selected_Component + and then Nkind (Arg) = N_Identifier + and then Ekind (Entity (Arg)) = E_Discriminant + then + Append_To (Args, + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Prefix (Id_Ref)), + Selector_Name => Arg)); + else + Append_To (Args, Arg); + end if; + + 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)); + + elsif Present (Constructor_Ref) then + Append_List_To (Args, + New_Copy_List (Parameter_Associations (Constructor_Ref))); + end if; + + Append_To (Res, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Proc, Loc), + Parameter_Associations => Args)); + + if Needs_Finalization (Typ) + and then Nkind (Id_Ref) = N_Selected_Component + then + if Chars (Selector_Name (Id_Ref)) /= Name_uParent then + Init_Call := + Make_Init_Call + (Obj_Ref => New_Copy_Tree (First_Arg), + Typ => Typ); + + -- Guard against a missing [Deep_]Initialize when the type was not + -- properly frozen. + + if Present (Init_Call) then + Append_To (Res, Init_Call); + end if; + end if; + end if; + + return Res; + + exception + when RE_Not_Available => + return Empty_List; + end Build_Initialization_Call; + + ---------------------------- + -- Build_Record_Init_Proc -- + ---------------------------- + + procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id) is + Decls : constant List_Id := New_List; + Discr_Map : constant Elist_Id := New_Elmt_List; + Loc : constant Source_Ptr := Sloc (Rec_Ent); + Counter : Nat := 0; + Proc_Id : Entity_Id; + Rec_Type : Entity_Id; + Set_Tag : Entity_Id := Empty; + + function Build_Assignment + (Id : Entity_Id; + Default : Node_Id) return List_Id; + -- Build an assignment statement that assigns the default expression to + -- its corresponding record component if defined. The left-hand side of + -- the assignment is marked Assignment_OK so that initialization of + -- limited private records works correctly. This routine may also build + -- an adjustment call if the component is controlled. + + procedure Build_Discriminant_Assignments (Statement_List : List_Id); + -- If the record has discriminants, add 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. Append any locally declared + -- objects on list Decls. + + function Build_Init_Call_Thru (Parameters : List_Id) return List_Id; + -- Given an untagged type-derivation that declares discriminants, e.g. + -- + -- 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_CPP_Init_Procedure; + -- Build the tree corresponding to the procedure specification and body + -- of the IC procedure that initializes the C++ part of the dispatch + -- table of an Ada tagged type that is a derivation of a CPP type. + -- Install it as the CPP_Init TSS. + + procedure Build_Init_Procedure; + -- Build the tree corresponding to the procedure specification and body + -- of the initialization procedure and install it as the _init TSS. + + procedure Build_Offset_To_Top_Functions; + -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec + -- and body of Offset_To_Top, a function used in conjuction with types + -- having secondary dispatch tables. + + procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id); + -- Add range checks to components of discriminated records. S is a + -- subtype indication of a record component. Check_List is a list + -- to which the check actions are appended. + + function Component_Needs_Simple_Initialization + (T : Entity_Id) return Boolean; + -- Determine if a component needs simple initialization, given its type + -- T. This routine is the same as Needs_Simple_Initialization except for + -- components of type Tag and Interface_Tag. These two access types do + -- not require initialization since they are explicitly initialized by + -- other means. + + 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; + -- Determine whether a record initialization procedure needs to be + -- generated for the given record type. + + ---------------------- + -- Build_Assignment -- + ---------------------- + + function Build_Assignment + (Id : Entity_Id; + Default : Node_Id) return List_Id + is + Default_Loc : constant Source_Ptr := Sloc (Default); + Typ : constant Entity_Id := Underlying_Type (Etype (Id)); + + Adj_Call : Node_Id; + Exp : Node_Id := Default; + Kind : Node_Kind := Nkind (Default); + Lhs : Node_Id; + Res : List_Id; + + function Replace_Discr_Ref (N : Node_Id) return Traverse_Result; + -- Analysis of the aggregate has replaced discriminants by their + -- corresponding discriminals, but these are irrelevant when the + -- component has a mutable type and is initialized with an aggregate. + -- Instead, they must be replaced by the values supplied in the + -- aggregate, that will be assigned during the expansion of the + -- assignment. + + ----------------------- + -- Replace_Discr_Ref -- + ----------------------- + + function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is + Val : Node_Id; + + begin + if Is_Entity_Name (N) + and then Present (Entity (N)) + and then Is_Formal (Entity (N)) + and then Present (Discriminal_Link (Entity (N))) + then + Val := + Make_Selected_Component (Default_Loc, + Prefix => New_Copy_Tree (Lhs), + Selector_Name => + New_Occurrence_Of + (Discriminal_Link (Entity (N)), Default_Loc)); + + if Present (Val) then + Rewrite (N, New_Copy_Tree (Val)); + end if; + end if; + + return OK; + end Replace_Discr_Ref; + + procedure Replace_Discriminant_References is + new Traverse_Proc (Replace_Discr_Ref); + + -- Start of processing for Build_Assignment + + begin + Lhs := + Make_Selected_Component (Default_Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Default_Loc)); + Set_Assignment_OK (Lhs); + + if Nkind (Exp) = N_Aggregate + and then Has_Discriminants (Typ) + and then not Is_Constrained (Base_Type (Typ)) + then + -- The aggregate may provide new values for the discriminants + -- of the component, and other components may depend on those + -- discriminants. Previous analysis of those expressions have + -- replaced the discriminants by the formals of the initialization + -- procedure for the type, but these are irrelevant in the + -- enclosing initialization procedure: those discriminant + -- references must be replaced by the values provided in the + -- aggregate. + + Replace_Discriminant_References (Exp); + end if; + + -- Case of an access attribute applied to the current instance. + -- Replace the reference to the type by a reference to the actual + -- object. (Note that this handles the case of the top level of + -- the expression being given by such an attribute, but does not + -- cover uses nested within an initial value expression. Nested + -- uses are unlikely to occur in practice, but are theoretically + -- possible.) It is not clear how to handle them without fully + -- traversing the expression. ??? + + if Kind = N_Attribute_Reference + and then Nam_In (Attribute_Name (Default), Name_Unchecked_Access, + Name_Unrestricted_Access) + and then Is_Entity_Name (Prefix (Default)) + and then Is_Type (Entity (Prefix (Default))) + and then Entity (Prefix (Default)) = Rec_Type + then + Exp := + Make_Attribute_Reference (Default_Loc, + Prefix => + Make_Identifier (Default_Loc, Name_uInit), + Attribute_Name => Name_Unrestricted_Access); + end if; + + -- Take a copy of Exp to ensure that later copies of this component + -- declaration in derived types see the original tree, not a node + -- rewritten during expansion of the init_proc. If the copy contains + -- itypes, the scope of the new itypes is the init_proc being built. + + Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id); + + 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 not Tagged_Type_Expansion because + -- tags are represented implicitly in objects. + + if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then + Append_To (Res, + Make_Assignment_Statement (Default_Loc, + Name => + Make_Selected_Component (Default_Loc, + Prefix => + New_Copy_Tree (Lhs, New_Scope => Proc_Id), + Selector_Name => + New_Occurrence_Of + (First_Tag_Component (Typ), Default_Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Underlying_Type + (Typ)))), + Default_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 (Expression (Default)); + end if; + + if Needs_Finalization (Typ) + and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)) + and then not Is_Build_In_Place_Function_Call (Exp) + then + Adj_Call := + Make_Adjust_Call + (Obj_Ref => New_Copy_Tree (Lhs), + Typ => Etype (Id)); + + -- Guard against a missing [Deep_]Adjust when the component type + -- was not properly frozen. + + if Present (Adj_Call) then + Append_To (Res, Adj_Call); + end if; + end if; + + -- If a component type has a predicate, add check to the component + -- assignment. Discriminants are handled at the point of the call, + -- which provides for a better error message. + + if Comes_From_Source (Exp) + and then Has_Predicates (Typ) + and then not Predicate_Checks_Suppressed (Empty) + and then not Predicates_Ignored (Typ) + then + Append (Make_Predicate_Check (Typ, Exp), Res); + end if; + + return Res; + + exception + when RE_Not_Available => + return Empty_List; + end Build_Assignment; + + ------------------------------------ + -- Build_Discriminant_Assignments -- + ------------------------------------ + + procedure Build_Discriminant_Assignments (Statement_List : List_Id) is + Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type); + D : Entity_Id; + D_Loc : Source_Ptr; + + 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 + D_Loc := Sloc (D); + Append_List_To (Statement_List, + Build_Assignment (D, + New_Occurrence_Of (Discriminal (D), 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; + + Arg : Node_Id; + Args : List_Id; + First_Arg : Node_Id; + Parent_Discr : Entity_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_Occurrence_Of + (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_Name as the value of the _Task_Name 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 Restriction_Active (No_Task_Hierarchy) then + Append_To (Args, + New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); + else + Append_To (Args, Make_Identifier (Loc, Name_uMaster)); + end if; + + -- Add _Chain (not done for sequential elaboration policy, see + -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). + + if Partition_Elaboration_Policy /= 'S' then + Append_To (Args, Make_Identifier (Loc, Name_uChain)); + end if; + + Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); + 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 : Entity_Id := + First_Stored_Discriminant (Uparent_Type); + + Discr_Value : Elmt_Id := + First_Elmt (Stored_Constraint (Rec_Type)); + + begin + while Original_Record_Component (Parent_Discr) /= Discr loop + Next_Stored_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_Occurrence_Of (Discriminal (Entity (Arg)), Loc)); + + -- Case of access discriminants. We replace the reference + -- to the type by a reference to the actual object. + + -- Is above comment right??? Use of New_Copy below seems mighty + -- suspicious ??? + + 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_Offset_To_Top_Functions -- + ----------------------------------- + + procedure Build_Offset_To_Top_Functions is + + procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id); + -- Generate: + -- function Fxx (O : Address) return Storage_Offset is + -- type Acc is access all <Typ>; + -- begin + -- return Acc!(O).Iface_Comp'Position; + -- end Fxx; + + ---------------------------------- + -- Build_Offset_To_Top_Function -- + ---------------------------------- + + procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is + Body_Node : Node_Id; + Func_Id : Entity_Id; + Spec_Node : Node_Id; + Acc_Type : Entity_Id; + + begin + Func_Id := Make_Temporary (Loc, 'F'); + Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id); + + -- Generate + -- function Fxx (O : in Rec_Typ) return Storage_Offset; + + Spec_Node := New_Node (N_Function_Specification, Loc); + Set_Defining_Unit_Name (Spec_Node, Func_Id); + Set_Parameter_Specifications (Spec_Node, New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + In_Present => True, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Address), Loc)))); + Set_Result_Definition (Spec_Node, + New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); + + -- Generate + -- function Fxx (O : in Rec_Typ) return Storage_Offset is + -- begin + -- return O.Iface_Comp'Position; + -- end Fxx; + + Body_Node := New_Node (N_Subprogram_Body, Loc); + Set_Specification (Body_Node, Spec_Node); + + Acc_Type := Make_Temporary (Loc, 'T'); + Set_Declarations (Body_Node, New_List ( + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Acc_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Null_Exclusion_Present => False, + Constant_Present => False, + Subtype_Indication => + New_Occurrence_Of (Rec_Type, Loc))))); + + Set_Handled_Statement_Sequence (Body_Node, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Acc_Type, + Make_Identifier (Loc, Name_uO)), + Selector_Name => + New_Occurrence_Of (Iface_Comp, Loc)), + Attribute_Name => Name_Position))))); + + Set_Ekind (Func_Id, E_Function); + Set_Mechanism (Func_Id, Default_Mechanism); + Set_Is_Internal (Func_Id, True); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Func_Id); + end if; + + Analyze (Body_Node); + + Append_Freeze_Action (Rec_Type, Body_Node); + end Build_Offset_To_Top_Function; + + -- Local variables + + Iface_Comp : Node_Id; + Iface_Comp_Elmt : Elmt_Id; + Ifaces_Comp_List : Elist_Id; + + -- Start of processing for Build_Offset_To_Top_Functions + + begin + -- Offset_To_Top_Functions are built only for derivations of types + -- with discriminants that cover interface types. + -- Nothing is needed either in case of virtual targets, since + -- interfaces are handled directly by the target. + + if not Is_Tagged_Type (Rec_Type) + or else Etype (Rec_Type) = Rec_Type + or else not Has_Discriminants (Etype (Rec_Type)) + or else not Tagged_Type_Expansion + then + return; + end if; + + Collect_Interface_Components (Rec_Type, Ifaces_Comp_List); + + -- For each interface type with secondary dispatch table we generate + -- the Offset_To_Top_Functions (required to displace the pointer in + -- interface conversions) + + Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); + while Present (Iface_Comp_Elmt) loop + Iface_Comp := Node (Iface_Comp_Elmt); + pragma Assert (Is_Interface (Related_Type (Iface_Comp))); + + -- If the interface is a parent of Rec_Type it shares the primary + -- dispatch table and hence there is no need to build the function + + if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type, + Use_Full_View => True) + then + Build_Offset_To_Top_Function (Iface_Comp); + end if; + + Next_Elmt (Iface_Comp_Elmt); + end loop; + end Build_Offset_To_Top_Functions; + + ------------------------------ + -- Build_CPP_Init_Procedure -- + ------------------------------ + + procedure Build_CPP_Init_Procedure is + Body_Node : Node_Id; + Body_Stmts : List_Id; + Flag_Id : Entity_Id; + Handled_Stmt_Node : Node_Id; + Init_Tags_List : List_Id; + Proc_Id : Entity_Id; + Proc_Spec_Node : Node_Id; + + begin + -- Check cases requiring no IC routine + + if not Is_CPP_Class (Root_Type (Rec_Type)) + or else Is_CPP_Class (Rec_Type) + or else CPP_Num_Prims (Rec_Type) = 0 + or else not Tagged_Type_Expansion + or else No_Run_Time_Mode + then + return; + end if; + + -- Generate: + + -- Flag : Boolean := False; + -- + -- procedure Typ_IC is + -- begin + -- if not Flag then + -- Copy C++ dispatch table slots from parent + -- Update C++ slots of overridden primitives + -- end if; + -- end; + + Flag_Id := Make_Temporary (Loc, 'F'); + + Append_Freeze_Action (Rec_Type, + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + New_Occurrence_Of (Standard_True, Loc))); + + Body_Stmts := New_List; + Body_Node := New_Node (N_Subprogram_Body, Loc); + + Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); + + Proc_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc)); + + Set_Ekind (Proc_Id, E_Procedure); + Set_Is_Internal (Proc_Id); + + Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); + + Set_Parameter_Specifications (Proc_Spec_Node, New_List); + Set_Specification (Body_Node, Proc_Spec_Node); + Set_Declarations (Body_Node, New_List); + + Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type); + + Append_To (Init_Tags_List, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of (Flag_Id, Loc), + Expression => + New_Occurrence_Of (Standard_False, Loc))); + + Append_To (Body_Stmts, + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Flag_Id, Loc), + Then_Statements => Init_Tags_List)); + + 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 CPP_Init_Proc with type + + Set_Init_Proc (Rec_Type, Proc_Id); + end Build_CPP_Init_Procedure; + + -------------------------- + -- Build_Init_Procedure -- + -------------------------- + + procedure Build_Init_Procedure is + Body_Stmts : List_Id; + Body_Node : Node_Id; + Handled_Stmt_Node : Node_Id; + Init_Tags_List : List_Id; + Parameters : List_Id; + Proc_Spec_Node : Node_Id; + Record_Extension_Node : Node_Id; + + begin + Body_Stmts := New_List; + Body_Node := New_Node (N_Subprogram_Body, Loc); + 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) then + Set_Tag := Make_Temporary (Loc, '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, Decls); + + -- N is a Derived_Type_Definition that renames the parameters of the + -- ancestor type. We initialize it by expanding our discriminants and + -- call the ancestor _init_proc with a type-converted object. + + if Parent_Subtype_Renaming_Discrims then + 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; + + -- 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. + + else + Build_Discriminant_Assignments (Body_Stmts); + + Record_Extension_Node := + Record_Extension_Part (Type_Definition (N)); + + if not Null_Present (Record_Extension_Node) then + declare + Stmts : constant 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. This is + -- not needed if the parent is an interface type because in + -- such case the initialization of the _parent field was not + -- generated. + + if not Is_Interface (Etype (Rec_Ent)) then + declare + Parent_IP : constant Name_Id := + Make_Init_Proc_Name (Etype (Rec_Ent)); + Stmt : Node_Id; + IP_Call : Node_Id; + IP_Stmts : List_Id; + + begin + -- Look for a call to the parent IP at the beginning + -- of Stmts associated with the record extension + + Stmt := First (Stmts); + IP_Call := Empty; + while Present (Stmt) loop + if Nkind (Stmt) = N_Procedure_Call_Statement + and then Chars (Name (Stmt)) = Parent_IP + then + IP_Call := Stmt; + exit; + end if; + + Next (Stmt); + end loop; + + -- If found then move it to the beginning of the + -- statements of this IP routine + + if Present (IP_Call) then + IP_Stmts := New_List; + loop + Stmt := Remove_Head (Stmts); + Append_To (IP_Stmts, Stmt); + exit when Stmt = IP_Call; + end loop; + + Prepend_List_To (Body_Stmts, IP_Stmts); + end if; + end; + end if; + + Append_List_To (Body_Stmts, Stmts); + end; + end if; + end if; + + -- Add here the assignment to instantiate the Tag + + -- The assignment corresponds to the code: + + -- _Init._Tag := Typ'Tag; + + -- Suppress the tag assignment when not Tagged_Type_Expansion because + -- tags are represented implicitly in objects. It is also suppressed + -- in case of CPP_Class types because in this case the tag is + -- initialized in the C++ side. + + if Is_Tagged_Type (Rec_Type) + and then Tagged_Type_Expansion + and then not No_Run_Time_Mode + then + -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of + -- the actual object and invoke the IP of the parent (in this + -- order). The tag must be initialized before the call to the IP + -- of the parent and the assignments to other components because + -- the initial value of the components may depend on 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. + + if not Is_CPP_Class (Root_Type (Rec_Type)) then + + -- Initialize the primary tag component + + Init_Tags_List := New_List ( + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => + New_Occurrence_Of + (First_Tag_Component (Rec_Type), Loc)), + Expression => + New_Occurrence_Of + (Node + (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); + + -- Ada 2005 (AI-251): Initialize the secondary tags components + -- located at fixed positions (tags whose position depends on + -- variable size components are initialized later ---see below) + + if Ada_Version >= Ada_2005 + and then not Is_Interface (Rec_Type) + and then Has_Interfaces (Rec_Type) + then + declare + Elab_Sec_DT_Stmts_List : constant List_Id := New_List; + + begin + Init_Secondary_Tags + (Typ => Rec_Type, + Target => Make_Identifier (Loc, Name_uInit), + Init_Tags_List => Init_Tags_List, + Stmts_List => Elab_Sec_DT_Stmts_List, + Fixed_Comps => True, + Variable_Comps => False); + + Append_To (Elab_Sec_DT_Stmts_List, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of + (Access_Disp_Table_Elab_Flag (Rec_Type), Loc), + Expression => + New_Occurrence_Of (Standard_False, Loc))); + + Prepend_List_To (Body_Stmts, New_List ( + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Set_Tag, Loc), + Then_Statements => Init_Tags_List), + + Make_If_Statement (Loc, + Condition => + New_Occurrence_Of + (Access_Disp_Table_Elab_Flag (Rec_Type), Loc), + Then_Statements => Elab_Sec_DT_Stmts_List))); + end; + else + Prepend_To (Body_Stmts, + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Set_Tag, Loc), + Then_Statements => Init_Tags_List)); + end if; + + -- Case 2: CPP type. The imported C++ constructor takes care of + -- tags initialization. No action needed here because the IP + -- is built by Set_CPP_Constructors; in this case the IP is a + -- wrapper that invokes the C++ constructor and copies the C++ + -- tags locally. Done to inherit the C++ slots in Ada derivations + -- (see case 3). + + elsif Is_CPP_Class (Rec_Type) then + pragma Assert (False); + null; + + -- Case 3: Combined hierarchy containing C++ types and Ada tagged + -- type derivations. Derivations of imported C++ classes add a + -- complication, because we cannot inhibit tag setting in the + -- constructor for the parent. Hence we initialize the tag after + -- the call to the parent IP (that is, in reverse order compared + -- with pure Ada hierarchies ---see comment on case 1). + + else + -- Initialize the primary tag + + Init_Tags_List := New_List ( + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => + New_Occurrence_Of + (First_Tag_Component (Rec_Type), Loc)), + Expression => + New_Occurrence_Of + (Node + (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); + + -- Ada 2005 (AI-251): Initialize the secondary tags components + -- located at fixed positions (tags whose position depends on + -- variable size components are initialized later ---see below) + + if Ada_Version >= Ada_2005 + and then not Is_Interface (Rec_Type) + and then Has_Interfaces (Rec_Type) + then + Init_Secondary_Tags + (Typ => Rec_Type, + Target => Make_Identifier (Loc, Name_uInit), + Init_Tags_List => Init_Tags_List, + Stmts_List => Init_Tags_List, + Fixed_Comps => True, + Variable_Comps => False); + end if; + + -- Initialize the tag component after invocation of parent IP. + + -- Generate: + -- parent_IP(_init.parent); // Invokes the C++ constructor + -- [ typIC; ] // Inherit C++ slots from parent + -- init_tags + + declare + Ins_Nod : Node_Id; + + begin + -- Search for the call to the IP of the parent. We assume + -- that the first init_proc call is for the parent. + + Ins_Nod := First (Body_Stmts); + while Present (Next (Ins_Nod)) + and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement + or else not Is_Init_Proc (Name (Ins_Nod))) + loop + Next (Ins_Nod); + end loop; + + -- The IC routine copies the inherited slots of the C+ part + -- of the dispatch table from the parent and updates the + -- overridden C++ slots. + + if CPP_Num_Prims (Rec_Type) > 0 then + declare + Init_DT : Entity_Id; + New_Nod : Node_Id; + + begin + Init_DT := CPP_Init_Proc (Rec_Type); + pragma Assert (Present (Init_DT)); + + New_Nod := + Make_Procedure_Call_Statement (Loc, + New_Occurrence_Of (Init_DT, Loc)); + Insert_After (Ins_Nod, New_Nod); + + -- Update location of init tag statements + + Ins_Nod := New_Nod; + end; + end if; + + Insert_List_After (Ins_Nod, Init_Tags_List); + end; + end if; + + -- Ada 2005 (AI-251): Initialize the secondary tag components + -- located at variable positions. We delay the generation of this + -- code until here because the value of the attribute 'Position + -- applied to variable size components of the parent type that + -- depend on discriminants is only safely read at runtime after + -- the parent components have been initialized. + + if Ada_Version >= Ada_2005 + and then not Is_Interface (Rec_Type) + and then Has_Interfaces (Rec_Type) + and then Has_Discriminants (Etype (Rec_Type)) + and then Is_Variable_Size_Record (Etype (Rec_Type)) + then + Init_Tags_List := New_List; + + Init_Secondary_Tags + (Typ => Rec_Type, + Target => Make_Identifier (Loc, Name_uInit), + Init_Tags_List => Init_Tags_List, + Stmts_List => Init_Tags_List, + Fixed_Comps => False, + Variable_Comps => True); + + if Is_Non_Empty_List (Init_Tags_List) then + Append_List_To (Body_Stmts, Init_Tags_List); + end if; + end if; + end if; + + Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc); + Set_Statements (Handled_Stmt_Node, Body_Stmts); + + -- Generate: + -- Deep_Finalize (_init, C1, ..., CN); + -- raise; + + if Counter > 0 + and then Needs_Finalization (Rec_Type) + and then not Is_Abstract_Type (Rec_Type) + and then not Restriction_Active (No_Exception_Propagation) + then + declare + DF_Id : Entity_Id; + + begin + -- Create a local version of Deep_Finalize which has indication + -- of partial initialization state. + + DF_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Name_uFinalizer)); + + Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id)); + + Set_Exception_Handlers (Handled_Stmt_Node, New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List ( + Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (DF_Id, Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, Name_uInit), + New_Occurrence_Of (Standard_False, Loc))), + + Make_Raise_Statement (Loc))))); + end; + else + Set_Exception_Handlers (Handled_Stmt_Node, No_List); + end if; + + 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 + + -- We must skip SCIL nodes because they may have been added to this + -- list by Insert_Actions. + + and then Nkind (First_Non_SCIL_Node (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 + Checks : constant List_Id := New_List; + Actions : List_Id := No_List; + Counter_Id : Entity_Id := Empty; + Comp_Loc : Source_Ptr; + Decl : Node_Id; + Has_POC : Boolean; + Id : Entity_Id; + Parent_Stmts : List_Id; + Stmts : List_Id; + Typ : Entity_Id; + + procedure Increment_Counter (Loc : Source_Ptr); + -- Generate an "increment by one" statement for the current counter + -- and append it to the list Stmts. + + procedure Make_Counter (Loc : Source_Ptr); + -- Create a new counter for the current component list. The routine + -- creates a new defining Id, adds an object declaration and sets + -- the Id generator for the next variant. + + ----------------------- + -- Increment_Counter -- + ----------------------- + + procedure Increment_Counter (Loc : Source_Ptr) is + begin + -- Generate: + -- Counter := Counter + 1; + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Counter_Id, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); + end Increment_Counter; + + ------------------ + -- Make_Counter -- + ------------------ + + procedure Make_Counter (Loc : Source_Ptr) is + begin + -- Increment the Id generator + + Counter := Counter + 1; + + -- Create the entity and declaration + + Counter_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name ('C', Counter)); + + -- Generate: + -- Cnn : Integer := 0; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Counter_Id, + Object_Definition => + New_Occurrence_Of (Standard_Integer, Loc), + Expression => + Make_Integer_Literal (Loc, 0))); + end Make_Counter; + + -- Start of processing for Build_Init_Statements + + begin + if Null_Present (Comp_List) then + return New_List (Make_Null_Statement (Loc)); + end if; + + Parent_Stmts := New_List; + Stmts := New_List; + + -- Loop through visible declarations of task types and protected + -- types moving any expanded code from the spec to the body of the + -- init procedure. + + if Is_Task_Record_Type (Rec_Type) + or else Is_Protected_Record_Type (Rec_Type) + then + declare + Decl : constant Node_Id := + Parent (Corresponding_Concurrent_Type (Rec_Type)); + Def : Node_Id; + N1 : Node_Id; + N2 : Node_Id; + + begin + if Is_Task_Record_Type (Rec_Type) then + Def := Task_Definition (Decl); + else + Def := Protected_Definition (Decl); + end if; + + if Present (Def) then + N1 := First (Visible_Declarations (Def)); + while Present (N1) loop + N2 := N1; + N1 := Next (N1); + + if Nkind (N2) in N_Statement_Other_Than_Procedure_Call + or else Nkind (N2) in N_Raise_xxx_Error + or else Nkind (N2) = N_Procedure_Call_Statement + then + Append_To (Stmts, + New_Copy_Tree (N2, New_Scope => Proc_Id)); + Rewrite (N2, Make_Null_Statement (Sloc (N2))); + Analyze (N2); + end if; + end loop; + end if; + end; + end if; + + -- Loop through components, skipping pragmas, in 2 steps. The first + -- step deals with regular components. The second step deals with + -- components that have per object constraints and no explicit + -- initialization. + + Has_POC := False; + + -- First pass : regular components + + Decl := First_Non_Pragma (Component_Items (Comp_List)); + while Present (Decl) loop + Comp_Loc := Sloc (Decl); + Build_Record_Checks + (Subtype_Indication (Component_Definition (Decl)), Checks); + + Id := Defining_Identifier (Decl); + Typ := Etype (Id); + + -- Leave any processing of per-object constrained component for + -- the second pass. + + if Has_Access_Constraint (Id) and then No (Expression (Decl)) then + Has_POC := True; + + -- Regular component cases + + else + -- In the context of the init proc, references to discriminants + -- resolve to denote the discriminals: this is where we can + -- freeze discriminant dependent component subtypes. + + if not Is_Frozen (Typ) then + Append_List_To (Stmts, Freeze_Entity (Typ, N)); + end if; + + -- Explicit initialization + + if Present (Expression (Decl)) then + if Is_CPP_Constructor_Call (Expression (Decl)) then + Actions := + Build_Initialization_Call + (Comp_Loc, + Id_Ref => + Make_Selected_Component (Comp_Loc, + Prefix => + Make_Identifier (Comp_Loc, Name_uInit), + Selector_Name => + New_Occurrence_Of (Id, Comp_Loc)), + Typ => Typ, + In_Init_Proc => True, + Enclos_Type => Rec_Type, + Discr_Map => Discr_Map, + Constructor_Ref => Expression (Decl)); + else + Actions := Build_Assignment (Id, Expression (Decl)); + end if; + + -- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size + -- components are filled in with the corresponding rep-item + -- expression of the concurrent type (if any). + + elsif Ekind (Scope (Id)) = E_Record_Type + and then Present (Corresponding_Concurrent_Type (Scope (Id))) + and then Nam_In (Chars (Id), Name_uCPU, + Name_uDispatching_Domain, + Name_uPriority, + Name_uSecondary_Stack_Size) + then + declare + Exp : Node_Id; + Nam : Name_Id; + pragma Warnings (Off, Nam); + Ritem : Node_Id; + + begin + if Chars (Id) = Name_uCPU then + Nam := Name_CPU; + + elsif Chars (Id) = Name_uDispatching_Domain then + Nam := Name_Dispatching_Domain; + + elsif Chars (Id) = Name_uPriority then + Nam := Name_Priority; + + elsif Chars (Id) = Name_uSecondary_Stack_Size then + Nam := Name_Secondary_Stack_Size; + end if; + + -- Get the Rep Item (aspect specification, attribute + -- definition clause or pragma) of the corresponding + -- concurrent type. + + Ritem := + Get_Rep_Item + (Corresponding_Concurrent_Type (Scope (Id)), + Nam, + Check_Parents => False); + + if Present (Ritem) then + + -- Pragma case + + if Nkind (Ritem) = N_Pragma then + Exp := First (Pragma_Argument_Associations (Ritem)); + + if Nkind (Exp) = N_Pragma_Argument_Association then + Exp := Expression (Exp); + end if; + + -- Conversion for Priority expression + + if Nam = Name_Priority then + if Pragma_Name (Ritem) = Name_Priority + and then not GNAT_Mode + then + Exp := Convert_To (RTE (RE_Priority), Exp); + else + Exp := + Convert_To (RTE (RE_Any_Priority), Exp); + end if; + end if; + + -- Aspect/Attribute definition clause case + + else + Exp := Expression (Ritem); + + -- Conversion for Priority expression + + if Nam = Name_Priority then + if Chars (Ritem) = Name_Priority + and then not GNAT_Mode + then + Exp := Convert_To (RTE (RE_Priority), Exp); + else + Exp := + Convert_To (RTE (RE_Any_Priority), Exp); + end if; + end if; + end if; + + -- Conversion for Dispatching_Domain value + + if Nam = Name_Dispatching_Domain then + Exp := + Unchecked_Convert_To + (RTE (RE_Dispatching_Domain_Access), Exp); + + -- Conversion for Secondary_Stack_Size value + + elsif Nam = Name_Secondary_Stack_Size then + Exp := Convert_To (RTE (RE_Size_Type), Exp); + end if; + + Actions := Build_Assignment (Id, Exp); + + -- Nothing needed if no Rep Item + + else + Actions := No_List; + end if; + end; + + -- Composite component with its own Init_Proc + + elsif not Is_Interface (Typ) + and then Has_Non_Null_Base_Init_Proc (Typ) + then + Actions := + Build_Initialization_Call + (Comp_Loc, + Make_Selected_Component (Comp_Loc, + Prefix => + Make_Identifier (Comp_Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Comp_Loc)), + Typ, + In_Init_Proc => True, + Enclos_Type => Rec_Type, + Discr_Map => Discr_Map); + + Clean_Task_Names (Typ, Proc_Id); + + -- Simple initialization + + elsif Component_Needs_Simple_Initialization (Typ) then + Actions := + Build_Assignment + (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))); + + -- Nothing needed for this case + + else + Actions := No_List; + end if; + + if Present (Checks) then + if Chars (Id) = Name_uParent then + Append_List_To (Parent_Stmts, Checks); + else + Append_List_To (Stmts, Checks); + end if; + end if; + + if Present (Actions) then + if Chars (Id) = Name_uParent then + Append_List_To (Parent_Stmts, Actions); + + else + Append_List_To (Stmts, Actions); + + -- Preserve initialization state in the current counter + + if Needs_Finalization (Typ) then + if No (Counter_Id) then + Make_Counter (Comp_Loc); + end if; + + Increment_Counter (Comp_Loc); + end if; + end if; + end if; + end if; + + Next_Non_Pragma (Decl); + end loop; + + -- The parent field must be initialized first because variable + -- size components of the parent affect the location of all the + -- new components. + + Prepend_List_To (Stmts, Parent_Stmts); + + -- Set up tasks and protected object support. This needs to be done + -- before any component with a per-object access discriminant + -- constraint, or any variant part (which may contain such + -- components) is initialized, because the initialization of these + -- components may reference the enclosing concurrent object. + + -- 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 + + -- In the case of the restricted run time the ATCB has already + -- been preallocated. + + if Restricted_Profile then + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uATCB)), + Attribute_Name => Name_Unchecked_Access))); + end if; + + Append_To (Stmts, 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); + Decl_Loc : Source_Ptr; + Ent : Entity_Id; + Vis_Decl : Node_Id; + + begin + if Present (Task_Def) then + Vis_Decl := First (Visible_Declarations (Task_Def)); + while Present (Vis_Decl) loop + Decl_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 (Stmts, + Make_Procedure_Call_Statement (Decl_Loc, + Name => + New_Occurrence_Of (RTE ( + RE_Bind_Interrupt_To_Entry), Decl_Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Decl_Loc, + Prefix => + Make_Identifier (Decl_Loc, Name_uInit), + Selector_Name => + Make_Identifier + (Decl_Loc, Name_uTask_Id)), + Entry_Index_Expression + (Decl_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 (Stmts, + Make_Initialize_Protection (Rec_Type)); + end if; + + -- Second pass: components with per-object constraints + + if Has_POC then + Decl := First_Non_Pragma (Component_Items (Comp_List)); + while Present (Decl) loop + Comp_Loc := Sloc (Decl); + Id := Defining_Identifier (Decl); + Typ := Etype (Id); + + if Has_Access_Constraint (Id) + and then No (Expression (Decl)) + then + if Has_Non_Null_Base_Init_Proc (Typ) then + Append_List_To (Stmts, + Build_Initialization_Call (Comp_Loc, + Make_Selected_Component (Comp_Loc, + Prefix => + Make_Identifier (Comp_Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Comp_Loc)), + Typ, + In_Init_Proc => True, + Enclos_Type => Rec_Type, + Discr_Map => Discr_Map)); + + Clean_Task_Names (Typ, Proc_Id); + + -- Preserve initialization state in the current counter + + if Needs_Finalization (Typ) then + if No (Counter_Id) then + Make_Counter (Comp_Loc); + end if; + + Increment_Counter (Comp_Loc); + end if; + + elsif Component_Needs_Simple_Initialization (Typ) then + Append_List_To (Stmts, + Build_Assignment + (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)))); + end if; + end if; + + Next_Non_Pragma (Decl); + end loop; + end if; + + -- Process the variant part + + if Present (Variant_Part (Comp_List)) then + declare + Variant_Alts : constant List_Id := New_List; + Var_Loc : Source_Ptr := No_Location; + Variant : Node_Id; + + begin + Variant := + First_Non_Pragma (Variants (Variant_Part (Comp_List))); + while Present (Variant) loop + Var_Loc := Sloc (Variant); + Append_To (Variant_Alts, + Make_Case_Statement_Alternative (Var_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 (Stmts, + Make_Case_Statement (Var_Loc, + Expression => + New_Occurrence_Of (Discriminal ( + Entity (Name (Variant_Part (Comp_List)))), Var_Loc), + Alternatives => Variant_Alts)); + end; + end if; + + -- If no initializations when generated for component declarations + -- corresponding to this Stmts, append a null statement to Stmts to + -- to make it a valid Ada tree. + + if Is_Empty_List (Stmts) then + Append (Make_Null_Statement (Loc), Stmts); + end if; + + return Stmts; + + exception + when RE_Not_Available => + return Empty_List; + end Build_Init_Statements; + + ------------------------- + -- Build_Record_Checks -- + ------------------------- + + procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is + Subtype_Mark_Id : Entity_Id; + + procedure Constrain_Array + (SI : Node_Id; + Check_List : List_Id); + -- Apply a list of index constraints to an unconstrained array type. + -- The first parameter is the entity for the resulting subtype. + -- Check_List is a list to which the check actions are appended. + + --------------------- + -- Constrain_Array -- + --------------------- + + procedure Constrain_Array + (SI : 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; + + procedure Constrain_Index + (Index : Node_Id; + S : Node_Id; + Check_List : List_Id); + -- Process an index constraint in a constrained array declaration. + -- The constraint can be either a subtype name or a range with or + -- without an explicit subtype mark. 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. + + --------------------- + -- Constrain_Index -- + --------------------- + + procedure Constrain_Index + (Index : Node_Id; + S : 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, Check_List => Check_List); + end if; + end Constrain_Index; + + -- Start of processing for Constrain_Array + + begin + T := Entity (Subtype_Mark (SI)); + + if Is_Access_Type (T) 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, Check_List); + Next (Index); + Next (S); + end loop; + end Constrain_Array; + + -- Start of processing for Build_Record_Checks + + begin + if Nkind (S) = N_Subtype_Indication then + Find_Type (Subtype_Mark (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, 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) + + -- Ada 2005 (AI-251): Check also the tag of abstract interfaces + + and then not Is_RTE (T, RE_Interface_Tag); + end Component_Needs_Simple_Initialization; + + -------------------------------------- + -- Parent_Subtype_Renaming_Discrims -- + -------------------------------------- + + function Parent_Subtype_Renaming_Discrims return Boolean is + De : Entity_Id; + Dp : Entity_Id; + + begin + if Base_Type (Rec_Ent) /= Rec_Ent then + return False; + end if; + + if Etype (Rec_Ent) = Rec_Ent + or else not Has_Discriminants (Rec_Ent) + or else Is_Constrained (Rec_Ent) + or else Is_Tagged_Type (Rec_Ent) + then + return False; + end if; + + -- If there are no explicit stored discriminants we have inherited + -- the root type discriminants so far, so no renamings occurred. + + if First_Discriminant (Rec_Ent) = + First_Stored_Discriminant (Rec_Ent) + then + return False; + end if; + + -- Check if we have done some trivial renaming of the parent + -- discriminants, i.e. something like + -- + -- type DT (X1, X2: int) is new PT (X1, X2); + + De := First_Discriminant (Rec_Ent); + Dp := First_Discriminant (Etype (Rec_Ent)); + 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 Initialization_Suppressed (Rec_Id) then + return False; + end if; + + -- If it is a type derived from a type with unknown discriminants, + -- we cannot build an initialization procedure for it. + + if Has_Unknown_Discriminants (Rec_Id) + or else Has_Unknown_Discriminants (Etype (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 Interface_Tag are excluded, since fields + -- of these types are initialized by other means. + + -- 7. The type is the record type built for a task type (since at + -- 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 because in this + -- case the initialization is performed by the C++ constructors, and + -- the IP is built by Set_CPP_Constructors. + + if Is_CPP_Class (Rec_Id) then + return False; + + elsif Is_Interface (Rec_Id) then + return False; + + 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; + + -- As explained above, a record initialization procedure is needed + -- for public types in case Initialize_Scalars applies to a client. + -- However, such a procedure is not needed in the case where either + -- of restrictions No_Initialize_Scalars or No_Default_Initialization + -- applies. No_Initialize_Scalars excludes the possibility of using + -- Initialize_Scalars in any partition, and No_Default_Initialization + -- implies that no initialization should ever be done for objects of + -- the type, so is incompatible with Initialize_Scalars. + + if not Restriction_Active (No_Initialize_Scalars) + and then not Restriction_Active (No_Default_Initialization) + and then Is_Public (Rec_Id) + then + return True; + end if; + + 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 we have a variant record with restriction No_Implicit_Conditionals + -- in effect, then we skip building the procedure. This is safe because + -- if we can see the restriction, so can any caller, calls to initialize + -- such records are not allowed for variant records if this restriction + -- is active. + + if Has_Variant_Part (Rec_Type) + and then Restriction_Active (No_Implicit_Conditionals) + then + return; + 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 synchronized 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 Is_Unchecked_Union (Rec_Type) + and then not Has_New_Non_Standard_Rep (Rec_Type) + and then not Parent_Subtype_Renaming_Discrims + and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type)) + 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) + or else Is_Unchecked_Union (Rec_Type) + then + Proc_Id := + Make_Defining_Identifier (Loc, + Chars => Make_Init_Proc_Name (Rec_Type)); + + -- If No_Default_Initialization restriction is active, then we don't + -- want to build an init_proc, but we need to mark that an init_proc + -- would be needed if this restriction was not active (so that we can + -- detect attempts to call it), so set a dummy init_proc in place. + + if Restriction_Active (No_Default_Initialization) then + Set_Init_Proc (Rec_Type, Proc_Id); + return; + end if; + + Build_Offset_To_Top_Functions; + Build_CPP_Init_Procedure; + Build_Init_Procedure; + + Set_Is_Public (Proc_Id, Is_Public (Rec_Ent)); + Set_Is_Internal (Proc_Id); + Set_Has_Completion (Proc_Id); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Proc_Id); + end if; + + Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Rec_Type)); + + -- Do not build an aggregate if Modify_Tree_For_C, this isn't + -- needed and may generate early references to non frozen types + -- since we expand aggregate much more systematically. + + if Modify_Tree_For_C then + return; + end if; + + declare + Agg : constant Node_Id := + Build_Equivalent_Record_Aggregate (Rec_Type); + + procedure Collect_Itypes (Comp : Node_Id); + -- Generate references to itypes in the aggregate, because + -- the first use of the aggregate may be in a nested scope. + + -------------------- + -- Collect_Itypes -- + -------------------- + + procedure Collect_Itypes (Comp : Node_Id) is + Ref : Node_Id; + Sub_Aggr : Node_Id; + Typ : constant Entity_Id := Etype (Comp); + + begin + if Is_Array_Type (Typ) and then Is_Itype (Typ) then + Ref := Make_Itype_Reference (Loc); + Set_Itype (Ref, Typ); + Append_Freeze_Action (Rec_Type, Ref); + + Ref := Make_Itype_Reference (Loc); + Set_Itype (Ref, Etype (First_Index (Typ))); + Append_Freeze_Action (Rec_Type, Ref); + + -- Recurse on nested arrays + + Sub_Aggr := First (Expressions (Comp)); + while Present (Sub_Aggr) loop + Collect_Itypes (Sub_Aggr); + Next (Sub_Aggr); + end loop; + end if; + end Collect_Itypes; + + begin + -- If there is a static initialization aggregate for the type, + -- generate itype references for the types of its (sub)components, + -- to prevent out-of-scope errors in the resulting tree. + -- The aggregate may have been rewritten as a Raise node, in which + -- case there are no relevant itypes. + + if Present (Agg) and then Nkind (Agg) = N_Aggregate then + Set_Static_Initialization (Proc_Id, Agg); + + declare + Comp : Node_Id; + begin + Comp := First (Component_Associations (Agg)); + while Present (Comp) loop + Collect_Itypes (Expression (Comp)); + Next (Comp); + end loop; + end; + end if; + end; + end if; + end Build_Record_Init_Proc; + + ---------------------------- + -- Build_Slice_Assignment -- + ---------------------------- + + -- Generates the following subprogram: + + -- procedure Assign + -- (Source, Target : Array_Type, + -- Left_Lo, Left_Hi : Index; + -- Right_Lo, Right_Hi : Index; + -- Rev : Boolean) + -- is + -- Li1 : Index; + -- Ri1 : Index; + + -- begin + + -- if Left_Hi < Left_Lo then + -- return; + -- end if; + + -- if Rev then + -- Li1 := Left_Hi; + -- Ri1 := Right_Hi; + -- else + -- Li1 := Left_Lo; + -- Ri1 := Right_Lo; + -- end if; + + -- loop + -- Target (Li1) := Source (Ri1); + + -- if Rev then + -- exit when Li1 = Left_Lo; + -- Li1 := Index'pred (Li1); + -- Ri1 := Index'pred (Ri1); + -- else + -- exit when Li1 = Left_Hi; + -- Li1 := Index'succ (Li1); + -- Ri1 := Index'succ (Ri1); + -- end if; + -- end loop; + -- end Assign; + + procedure Build_Slice_Assignment (Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); + + Larray : constant Entity_Id := Make_Temporary (Loc, 'A'); + Rarray : constant Entity_Id := Make_Temporary (Loc, 'R'); + Left_Lo : constant Entity_Id := Make_Temporary (Loc, 'L'); + Left_Hi : constant Entity_Id := Make_Temporary (Loc, 'L'); + Right_Lo : constant Entity_Id := Make_Temporary (Loc, 'R'); + Right_Hi : constant Entity_Id := Make_Temporary (Loc, 'R'); + Rev : constant Entity_Id := Make_Temporary (Loc, 'D'); + -- Formal parameters of procedure + + Proc_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Typ, TSS_Slice_Assign)); + + Lnn : constant Entity_Id := Make_Temporary (Loc, 'L'); + Rnn : constant Entity_Id := Make_Temporary (Loc, 'R'); + -- Subscripts for left and right sides + + Decls : List_Id; + Loops : Node_Id; + Stats : List_Id; + + begin + -- Build declarations for indexes + + Decls := New_List; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Lnn, + Object_Definition => + New_Occurrence_Of (Index, Loc))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => + New_Occurrence_Of (Index, Loc))); + + Stats := New_List; + + -- Build test for empty slice case + + Append_To (Stats, + Make_If_Statement (Loc, + Condition => + Make_Op_Lt (Loc, + Left_Opnd => New_Occurrence_Of (Left_Hi, Loc), + Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)), + Then_Statements => New_List (Make_Simple_Return_Statement (Loc)))); + + -- Build initializations for indexes + + declare + F_Init : constant List_Id := New_List; + B_Init : constant List_Id := New_List; + + begin + Append_To (F_Init, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Lnn, Loc), + Expression => New_Occurrence_Of (Left_Lo, Loc))); + + Append_To (F_Init, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Rnn, Loc), + Expression => New_Occurrence_Of (Right_Lo, Loc))); + + Append_To (B_Init, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Lnn, Loc), + Expression => New_Occurrence_Of (Left_Hi, Loc))); + + Append_To (B_Init, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Rnn, Loc), + Expression => New_Occurrence_Of (Right_Hi, Loc))); + + Append_To (Stats, + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Rev, Loc), + Then_Statements => B_Init, + Else_Statements => F_Init)); + end; + + -- Now construct the assignment statement + + Loops := + Make_Loop_Statement (Loc, + Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Larray, Loc), + Expressions => New_List (New_Occurrence_Of (Lnn, Loc))), + Expression => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Rarray, Loc), + Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))), + End_Label => Empty); + + -- Build the exit condition and increment/decrement statements + + declare + F_Ass : constant List_Id := New_List; + B_Ass : constant List_Id := New_List; + + begin + Append_To (F_Ass, + Make_Exit_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Lnn, Loc), + Right_Opnd => New_Occurrence_Of (Left_Hi, Loc)))); + + Append_To (F_Ass, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Lnn, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Index, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List ( + New_Occurrence_Of (Lnn, Loc))))); + + Append_To (F_Ass, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Rnn, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Index, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List ( + New_Occurrence_Of (Rnn, Loc))))); + + Append_To (B_Ass, + Make_Exit_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Lnn, Loc), + Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)))); + + Append_To (B_Ass, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Lnn, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Index, Loc), + Attribute_Name => Name_Pred, + Expressions => New_List ( + New_Occurrence_Of (Lnn, Loc))))); + + Append_To (B_Ass, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Rnn, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Index, Loc), + Attribute_Name => Name_Pred, + Expressions => New_List ( + New_Occurrence_Of (Rnn, Loc))))); + + Append_To (Statements (Loops), + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Rev, Loc), + Then_Statements => B_Ass, + Else_Statements => F_Ass)); + end; + + Append_To (Stats, Loops); + + declare + Spec : Node_Id; + Formals : List_Id := New_List; + + begin + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Larray, + Out_Present => True, + Parameter_Type => + New_Occurrence_Of (Base_Type (Typ), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Rarray, + Parameter_Type => + New_Occurrence_Of (Base_Type (Typ), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Left_Lo, + Parameter_Type => + New_Occurrence_Of (Index, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Left_Hi, + Parameter_Type => + New_Occurrence_Of (Index, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Right_Lo, + Parameter_Type => + New_Occurrence_Of (Index, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Right_Hi, + Parameter_Type => + New_Occurrence_Of (Index, Loc))); + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Rev, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc))); + + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Name, + Parameter_Specifications => Formals); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stats))); + end; + + Set_TSS (Typ, Proc_Name); + Set_Is_Pure (Proc_Name); + end Build_Slice_Assignment; + + ----------------------------- + -- Build_Untagged_Equality -- + ----------------------------- + + procedure Build_Untagged_Equality (Typ : Entity_Id) is + Build_Eq : Boolean; + Comp : Entity_Id; + Decl : Node_Id; + Op : Entity_Id; + Prim : Elmt_Id; + Eq_Op : Entity_Id; + + function User_Defined_Eq (T : Entity_Id) return Entity_Id; + -- Check whether the type T has a user-defined primitive equality. If so + -- return it, else return Empty. If true for a component of Typ, we have + -- to build the primitive equality for it. + + --------------------- + -- User_Defined_Eq -- + --------------------- + + function User_Defined_Eq (T : Entity_Id) return Entity_Id is + Prim : Elmt_Id; + Op : Entity_Id; + + begin + Op := TSS (T, TSS_Composite_Equality); + + if Present (Op) then + return Op; + end if; + + Prim := First_Elmt (Collect_Primitive_Operations (T)); + while Present (Prim) loop + Op := Node (Prim); + + if Chars (Op) = Name_Op_Eq + and then Etype (Op) = Standard_Boolean + and then Etype (First_Formal (Op)) = T + and then Etype (Next_Formal (First_Formal (Op))) = T + then + return Op; + end if; + + Next_Elmt (Prim); + end loop; + + return Empty; + end User_Defined_Eq; + + -- Start of processing for Build_Untagged_Equality + + begin + -- If a record component has a primitive equality operation, we must + -- build the corresponding one for the current type. + + Build_Eq := False; + Comp := First_Component (Typ); + while Present (Comp) loop + if Is_Record_Type (Etype (Comp)) + and then Present (User_Defined_Eq (Etype (Comp))) + then + Build_Eq := True; + end if; + + Next_Component (Comp); + end loop; + + -- If there is a user-defined equality for the type, we do not create + -- the implicit one. + + Prim := First_Elmt (Collect_Primitive_Operations (Typ)); + Eq_Op := Empty; + while Present (Prim) loop + if Chars (Node (Prim)) = Name_Op_Eq + and then Comes_From_Source (Node (Prim)) + + -- Don't we also need to check formal types and return type as in + -- User_Defined_Eq above??? + + then + Eq_Op := Node (Prim); + Build_Eq := False; + exit; + end if; + + Next_Elmt (Prim); + end loop; + + -- If the type is derived, inherit the operation, if present, from the + -- parent type. It may have been declared after the type derivation. If + -- the parent type itself is derived, it may have inherited an operation + -- that has itself been overridden, so update its alias and related + -- flags. Ditto for inequality. + + if No (Eq_Op) and then Is_Derived_Type (Typ) then + Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ))); + while Present (Prim) loop + if Chars (Node (Prim)) = Name_Op_Eq then + Copy_TSS (Node (Prim), Typ); + Build_Eq := False; + + declare + Op : constant Entity_Id := User_Defined_Eq (Typ); + Eq_Op : constant Entity_Id := Node (Prim); + NE_Op : constant Entity_Id := Next_Entity (Eq_Op); + + begin + if Present (Op) then + Set_Alias (Op, Eq_Op); + Set_Is_Abstract_Subprogram + (Op, Is_Abstract_Subprogram (Eq_Op)); + + if Chars (Next_Entity (Op)) = Name_Op_Ne then + Set_Is_Abstract_Subprogram + (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op)); + end if; + end if; + end; + + exit; + end if; + + Next_Elmt (Prim); + end loop; + end if; + + -- If not inherited and not user-defined, build body as for a type with + -- tagged components. + + if Build_Eq then + Decl := + Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality)); + Op := Defining_Entity (Decl); + Set_TSS (Typ, Op); + Set_Is_Pure (Op); + + if Is_Library_Level_Entity (Typ) then + Set_Is_Public (Op); + end if; + end if; + end Build_Untagged_Equality; + + ----------------------------------- + -- Build_Variant_Record_Equality -- + ----------------------------------- + + -- Generates: + + -- function _Equality (X, Y : T) return Boolean is + -- begin + -- -- Compare discriminants + + -- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then + -- return False; + -- end if; + + -- -- Compare components + + -- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then + -- return False; + -- end if; + + -- -- Compare variant part + + -- case X.D1 is + -- when V1 => + -- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then + -- return False; + -- end if; + -- ... + -- when Vn => + -- if X.Cn /= Y.Cn or else ... 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, + Chars => Make_TSS_Name (Typ, TSS_Composite_Equality)); + + 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)); + Stmts : constant List_Id := New_List; + Pspecs : constant List_Id := New_List; + + begin + -- If we have a variant record with restriction No_Implicit_Conditionals + -- in effect, then we skip building the procedure. This is safe because + -- if we can see the restriction, so can any caller, calls to equality + -- test routines are not allowed for variant records if this restriction + -- is active. + + if Restriction_Active (No_Implicit_Conditionals) then + return; + end if; + + -- Derived Unchecked_Union types no longer inherit the equality function + -- of their parent. + + if Is_Derived_Type (Typ) + and then not Is_Unchecked_Union (Typ) + and then not Has_New_Non_Standard_Rep (Typ) + then + declare + Parent_Eq : constant Entity_Id := + TSS (Root_Type (Typ), TSS_Composite_Equality); + begin + if Present (Parent_Eq) then + Copy_TSS (Parent_Eq, Typ); + return; + end if; + end; + end if; + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => F, + Parameter_Specifications => Pspecs, + Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)), + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts))); + + Append_To (Pspecs, + Make_Parameter_Specification (Loc, + Defining_Identifier => X, + Parameter_Type => New_Occurrence_Of (Typ, Loc))); + + Append_To (Pspecs, + Make_Parameter_Specification (Loc, + Defining_Identifier => Y, + Parameter_Type => New_Occurrence_Of (Typ, Loc))); + + -- Unchecked_Unions require additional machinery to support equality. + -- Two extra parameters (A and B) are added to the equality function + -- parameter list for each discriminant of the type, in order to + -- capture the inferred values of the discriminants in equality calls. + -- The names of the parameters match the names of the corresponding + -- discriminant, with an added suffix. + + if Is_Unchecked_Union (Typ) then + declare + Discr : Entity_Id; + Discr_Type : Entity_Id; + A, B : Entity_Id; + New_Discrs : Elist_Id; + + begin + New_Discrs := New_Elmt_List; + + Discr := First_Discriminant (Typ); + while Present (Discr) loop + Discr_Type := Etype (Discr); + A := Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Discr), 'A')); + + B := Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Discr), 'B')); + + -- Add new parameters to the parameter list + + Append_To (Pspecs, + Make_Parameter_Specification (Loc, + Defining_Identifier => A, + Parameter_Type => + New_Occurrence_Of (Discr_Type, Loc))); + + Append_To (Pspecs, + Make_Parameter_Specification (Loc, + Defining_Identifier => B, + Parameter_Type => + New_Occurrence_Of (Discr_Type, Loc))); + + Append_Elmt (A, New_Discrs); + + -- Generate the following code to compare each of the inferred + -- discriminants: + + -- if a /= b then + -- return False; + -- end if; + + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (A, Loc), + Right_Opnd => New_Occurrence_Of (B, Loc)), + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + New_Occurrence_Of (Standard_False, Loc))))); + Next_Discriminant (Discr); + end loop; + + -- Generate component-by-component comparison. Note that we must + -- propagate the inferred discriminants formals to act as + -- the case statement switch. Their value is added when an + -- equality call on unchecked unions is expanded. + + Append_List_To (Stmts, Make_Eq_Case (Typ, Comps, New_Discrs)); + end; + + -- Normal case (not unchecked union) + + 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_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (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; + + ----------------------------- + -- Check_Stream_Attributes -- + ----------------------------- + + procedure Check_Stream_Attributes (Typ : Entity_Id) is + Comp : Entity_Id; + Par_Read : constant Boolean := + Stream_Attribute_Available (Typ, TSS_Stream_Read) + and then not Has_Specified_Stream_Read (Typ); + Par_Write : constant Boolean := + Stream_Attribute_Available (Typ, TSS_Stream_Write) + and then not Has_Specified_Stream_Write (Typ); + + procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type); + -- Check that Comp has a user-specified Nam stream attribute + + ---------------- + -- Check_Attr -- + ---------------- + + procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is + begin + if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then + Error_Msg_Name_1 := Nam; + Error_Msg_N + ("|component& in limited extension must have% attribute", Comp); + end if; + end Check_Attr; + + -- Start of processing for Check_Stream_Attributes + + begin + if Par_Read or else Par_Write then + Comp := First_Component (Typ); + while Present (Comp) loop + if Comes_From_Source (Comp) + and then Original_Record_Component (Comp) = Comp + and then Is_Limited_Type (Etype (Comp)) + then + if Par_Read then + Check_Attr (Name_Read, TSS_Stream_Read); + end if; + + if Par_Write then + Check_Attr (Name_Write, TSS_Stream_Write); + end if; + end if; + + Next_Component (Comp); + end loop; + end if; + end Check_Stream_Attributes; + + ---------------------- + -- Clean_Task_Names -- + ---------------------- + + procedure Clean_Task_Names + (Typ : Entity_Id; + Proc_Id : Entity_Id) + is + begin + if Has_Task (Typ) + and then not Restriction_Active (No_Implicit_Heap_Allocations) + and then not Global_Discard_Names + and then Tagged_Type_Expansion + then + Set_Uses_Sec_Stack (Proc_Id); + end if; + end Clean_Task_Names; + + ------------------------------ + -- Expand_Freeze_Array_Type -- + ------------------------------ + + procedure Expand_Freeze_Array_Type (N : Node_Id) is + Typ : constant Entity_Id := Entity (N); + Base : constant Entity_Id := Base_Type (Typ); + Comp_Typ : constant Entity_Id := Component_Type (Typ); + + begin + if not Is_Bit_Packed_Array (Typ) then + + -- If the component contains tasks, so does the array type. This may + -- not be indicated in the array type because the component may have + -- been a private type at the point of definition. Same if component + -- type is controlled or contains protected objects. + + Propagate_Concurrent_Flags (Base, Comp_Typ); + Set_Has_Controlled_Component + (Base, Has_Controlled_Component (Comp_Typ) + or else Is_Controlled (Comp_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 assignments, + -- 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 [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 Is_Standard_String_Type (Base) 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); + + if not Is_Limited_Type (Comp_Typ) + and then Number_Dimensions (Typ) = 1 + then + Build_Slice_Assignment (Typ); + end if; + end if; + + -- For packed case, default initialization, except if the component type + -- is itself a packed structure with an initialization procedure, or + -- initialize/normalize scalars active, and we have a base type, or the + -- type is public, because in that case a client might specify + -- Normalize_Scalars and there better be a public Init_Proc for it. + + elsif (Present (Init_Proc (Component_Type (Base))) + and then No (Base_Init_Proc (Base))) + or else (Init_Or_Norm_Scalars and then Base = Typ) + or else Is_Public (Typ) + then + Build_Array_Init_Proc (Base, N); + end if; + end Expand_Freeze_Array_Type; + + ----------------------------------- + -- Expand_Freeze_Class_Wide_Type -- + ----------------------------------- + + procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is + function Is_C_Derivation (Typ : Entity_Id) return Boolean; + -- Given a type, determine whether it is derived from a C or C++ root + + --------------------- + -- Is_C_Derivation -- + --------------------- + + function Is_C_Derivation (Typ : Entity_Id) return Boolean is + T : Entity_Id; + + begin + T := Typ; + loop + if Is_CPP_Class (T) + or else Convention (T) = Convention_C + or else Convention (T) = Convention_CPP + then + return True; + end if; + + exit when T = Etype (T); + + T := Etype (T); + end loop; + + return False; + end Is_C_Derivation; + + -- Local variables + + Typ : constant Entity_Id := Entity (N); + Root : constant Entity_Id := Root_Type (Typ); + + -- Start of processing for Expand_Freeze_Class_Wide_Type + + begin + -- Certain run-time configurations and targets do not provide support + -- for controlled types. + + if Restriction_Active (No_Finalization) then + return; + + -- Do not create TSS routine Finalize_Address when dispatching calls are + -- disabled since the core of the routine is a dispatching call. + + elsif Restriction_Active (No_Dispatching_Calls) then + return; + + -- Do not create TSS routine Finalize_Address for concurrent class-wide + -- types. Ignore C, C++, CIL and Java types since it is assumed that the + -- non-Ada side will handle their destruction. + + elsif Is_Concurrent_Type (Root) + or else Is_C_Derivation (Root) + or else Convention (Typ) = Convention_CPP + then + return; + + -- Do not create TSS routine Finalize_Address when compiling in CodePeer + -- mode since the routine contains an Unchecked_Conversion. + + elsif CodePeer_Mode then + return; + end if; + + -- Create the body of TSS primitive Finalize_Address. This automatically + -- sets the TSS entry for the class-wide type. + + Make_Finalize_Address_Body (Typ); + end Expand_Freeze_Class_Wide_Type; + + ------------------------------------ + -- Expand_Freeze_Enumeration_Type -- + ------------------------------------ + + procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is + Typ : constant Entity_Id := Entity (N); + Loc : constant Source_Ptr := Sloc (Typ); + + Arr : Entity_Id; + Ent : Entity_Id; + Fent : Entity_Id; + Is_Contiguous : Boolean; + Ityp : Entity_Id; + Last_Repval : Uint; + Lst : List_Id; + Num : Nat; + Pos_Expr : Node_Id; + + Func : Entity_Id; + pragma Warnings (Off, Func); + + begin + -- Various optimizations possible if given representation is contiguous + + Is_Contiguous := True; + + Ent := First_Literal (Typ); + Last_Repval := Enumeration_Rep (Ent); + + Next_Literal (Ent); + while Present (Ent) loop + if Enumeration_Rep (Ent) - Last_Repval /= 1 then + Is_Contiguous := False; + exit; + else + Last_Repval := Enumeration_Rep (Ent); + end if; + + Next_Literal (Ent); + end loop; + + if Is_Contiguous then + Set_Has_Contiguous_Rep (Typ); + Ent := First_Literal (Typ); + Num := 1; + Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent))); + + else + -- Build list of literal references + + Lst := New_List; + Num := 0; + + Ent := First_Literal (Typ); + while Present (Ent) loop + Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent))); + Num := Num + 1; + Next_Literal (Ent); + end loop; + end if; + + -- Now build an array declaration + + -- typA : array (Natural range 0 .. num - 1) of ctype := + -- (v, v, v, v, v, ....) + + -- where ctype is the corresponding integer type. If the representation + -- is contiguous, we only keep the first literal, which provides the + -- offset for Pos_To_Rep computations. + + 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_Occurrence_Of (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))))), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Occurrence_Of (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 Constraint_Error when F "invalid data"] + -- return -1; + -- end case; + -- end; + + -- Note: the F parameter determines whether the others case (no valid + -- representation) raises Constraint_Error or returns a unique value + -- of minus one. The latter case is used, e.g. in 'Valid code. + + -- Note: the reason we use Enum_Rep values in the case here is to avoid + -- the code generator making inappropriate assumptions about the range + -- of the values in the case where the value is invalid. ityp is a + -- signed or unsigned integer type of appropriate width. + + -- Note: if exceptions are not supported, then we suppress the raise + -- and return -1 unconditionally (this is an erroneous program in any + -- case and there is no obligation to raise Constraint_Error here). We + -- also do this if pragma Restrictions (No_Exceptions) is active. + + -- Is this right??? What about No_Exception_Propagation??? + + -- Representations are signed + + if Enumeration_Rep (First_Literal (Typ)) < 0 then + + -- The underlying type is signed. Reset the Is_Unsigned_Type + -- explicitly, because it might have been inherited from + -- parent type. + + Set_Is_Unsigned_Type (Typ, False); + + 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; + + -- The body of the function is a case statement. First collect case + -- alternatives, or optimize the contiguous case. + + Lst := New_List; + + -- If representation is contiguous, Pos is computed by subtracting + -- the representation of the first literal. + + if Is_Contiguous then + Ent := First_Literal (Typ); + + if Enumeration_Rep (Ent) = Last_Repval then + + -- Another special case: for a single literal, Pos is zero + + Pos_Expr := Make_Integer_Literal (Loc, Uint_0); + + else + Pos_Expr := + Convert_To (Standard_Integer, + Make_Op_Subtract (Loc, + Left_Opnd => + Unchecked_Convert_To + (Ityp, Make_Identifier (Loc, Name_uA)), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => Enumeration_Rep (First_Literal (Typ))))); + end if; + + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Range (Sloc (Enumeration_Rep_Expr (Ent)), + Low_Bound => + Make_Integer_Literal (Loc, + Intval => Enumeration_Rep (Ent)), + High_Bound => + Make_Integer_Literal (Loc, Intval => Last_Repval))), + + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Pos_Expr)))); + + else + 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_Simple_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, + Intval => Enumeration_Pos (Ent)))))); + + Next_Literal (Ent); + end loop; + end if; + + -- In normal mode, add the others clause with the test. + -- If Predicates_Ignored is True, validity checks do not apply to + -- the subtype. + + if not No_Exception_Handlers_Set + and then not Predicates_Ignored (Typ) + then + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Raise_Constraint_Error (Loc, + Condition => Make_Identifier (Loc, Name_uF), + Reason => CE_Invalid_Data), + Make_Simple_Return_Statement (Loc, + Expression => Make_Integer_Literal (Loc, -1))))); + + -- If either of the restrictions No_Exceptions_Handlers/Propagation is + -- active then return -1 (we cannot usefully raise Constraint_Error in + -- this case). See description above for further details. + + else + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Make_Integer_Literal (Loc, -1))))); + end if; + + -- Now we can build the function body + + Fent := + Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_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_Occurrence_Of (Typ, Loc)), + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc))), + + Result_Definition => New_Occurrence_Of (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 Pure flag (it will be reset if the current context is not Pure). + -- We also pretend there was a pragma Pure_Function so that for purposes + -- of optimization and constant-folding, we will consider the function + -- Pure even if we are not in a Pure context). + + Set_Is_Pure (Fent); + Set_Has_Pragma_Pure_Function (Fent); + + -- Unless we are in -gnatD mode, where we are debugging generated code, + -- this is an internal entity for which we don't need debug info. + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Fent); + end if; + + Set_Is_Inlined (Fent); + + exception + when RE_Not_Available => + return; + end Expand_Freeze_Enumeration_Type; + + ------------------------------- + -- Expand_Freeze_Record_Type -- + ------------------------------- + + procedure Expand_Freeze_Record_Type (N : Node_Id) is + Typ : constant Node_Id := Entity (N); + Typ_Decl : constant Node_Id := Parent (Typ); + + Comp : Entity_Id; + Comp_Typ : Entity_Id; + Predef_List : List_Id; + + Wrapper_Decl_List : List_Id := No_List; + Wrapper_Body_List : List_Id := No_List; + + Renamed_Eq : Node_Id := Empty; + -- 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). Used to pass this entity from + -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies. + + -- Start of processing for Expand_Freeze_Record_Type + + begin + -- Build discriminant checking functions if not a derived type (for + -- derived types that are not tagged types, 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 (Typ) + or else Has_New_Non_Standard_Rep (Typ) + or else Is_Tagged_Type (Typ) + then + Build_Discr_Checking_Funcs (Typ_Decl); + + elsif Is_Derived_Type (Typ) + and then not Is_Tagged_Type (Typ) + + -- If we have a derived Unchecked_Union, we do not inherit the + -- discriminant checking functions from the parent type since the + -- discriminants are non existent. + + and then not Is_Unchecked_Union (Typ) + and then Has_Discriminants (Typ) + then + declare + Old_Comp : Entity_Id; + + begin + Old_Comp := + First_Component (Base_Type (Underlying_Type (Etype (Typ)))); + Comp := First_Component (Typ); + 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; + + if Is_Derived_Type (Typ) + and then Is_Limited_Type (Typ) + and then Is_Tagged_Type (Typ) + then + Check_Stream_Attributes (Typ); + end if; + + -- Update task, protected, and controlled component flags, because some + -- of the component types may have been private at the point of the + -- record declaration. Detect anonymous access-to-controlled components. + + Comp := First_Component (Typ); + while Present (Comp) loop + Comp_Typ := Etype (Comp); + + Propagate_Concurrent_Flags (Typ, Comp_Typ); + + -- Do not set Has_Controlled_Component on a class-wide equivalent + -- type. See Make_CW_Equivalent_Type. + + if not Is_Class_Wide_Equivalent_Type (Typ) + and then + (Has_Controlled_Component (Comp_Typ) + or else (Chars (Comp) /= Name_uParent + and then Is_Controlled (Comp_Typ))) + then + Set_Has_Controlled_Component (Typ); + end if; + + Next_Component (Comp); + end loop; + + -- Handle constructors of untagged CPP_Class types + + if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then + Set_CPP_Constructors (Typ); + end if; + + -- Creation of the Dispatch Table. Note that a Dispatch Table is built + -- for regular tagged types as well as for Ada types deriving from a C++ + -- Class, but not for tagged types directly corresponding to C++ classes + -- In the later case we assume that it is created in the C++ side and we + -- just use it. + + if Is_Tagged_Type (Typ) then + + -- Add the _Tag component + + if Underlying_Type (Etype (Typ)) = Typ then + Expand_Tagged_Root (Typ); + end if; + + if Is_CPP_Class (Typ) then + Set_All_DT_Position (Typ); + + -- Create the tag entities with a minimum decoration + + if Tagged_Type_Expansion then + Append_Freeze_Actions (Typ, Make_Tags (Typ)); + end if; + + Set_CPP_Constructors (Typ); + + else + if not Building_Static_DT (Typ) then + + -- 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. + + -- Similarly, if this is an inherited operation whose parent is + -- not frozen yet, it is not in the DT of the parent, and we + -- generate an explicit freeze node for the inherited operation + -- so it is properly inserted in the DT of the current type. + + declare + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Subp := Node (Elmt); + + if Present (Alias (Subp)) then + if Is_CPP_Class (Etype (Typ)) then + Set_Has_Delayed_Freeze (Subp); + + elsif Has_Delayed_Freeze (Alias (Subp)) + and then not Is_Frozen (Alias (Subp)) + then + Set_Is_Frozen (Subp, False); + Set_Has_Delayed_Freeze (Subp); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + -- 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 (Typ, False); + + -- Do not add the spec of predefined primitives in case of + -- CPP tagged type derivations that have convention CPP. + + if Is_CPP_Class (Root_Type (Typ)) + and then Convention (Typ) = Convention_CPP + then + null; + + -- Do not add the spec of the predefined primitives if we are + -- compiling under restriction No_Dispatching_Calls. + + elsif not Restriction_Active (No_Dispatching_Calls) then + Make_Predefined_Primitive_Specs (Typ, Predef_List, Renamed_Eq); + Insert_List_Before_And_Analyze (N, Predef_List); + end if; + + -- Ada 2005 (AI-391): For a nonabstract null extension, create + -- wrapper functions for each nonoverridden inherited function + -- with a controlling result of the type. The wrapper for such + -- a function returns an extension aggregate that invokes the + -- parent function. + + if Ada_Version >= Ada_2005 + and then not Is_Abstract_Type (Typ) + and then Is_Null_Extension (Typ) + then + Make_Controlling_Function_Wrappers + (Typ, Wrapper_Decl_List, Wrapper_Body_List); + Insert_List_Before_And_Analyze (N, Wrapper_Decl_List); + end if; + + -- Ada 2005 (AI-251): For a nonabstract type extension, build + -- null procedure declarations for each set of homographic null + -- procedures that are inherited from interface types but not + -- overridden. This is done to ensure that the dispatch table + -- entry associated with such null primitives are properly filled. + + if Ada_Version >= Ada_2005 + and then Etype (Typ) /= Typ + and then not Is_Abstract_Type (Typ) + and then Has_Interfaces (Typ) + then + Insert_Actions (N, Make_Null_Procedure_Specs (Typ)); + end if; + + Set_Is_Frozen (Typ); + + if not Is_Derived_Type (Typ) + or else Is_Tagged_Type (Etype (Typ)) + then + Set_All_DT_Position (Typ); + + -- If this is a type derived from an untagged private type whose + -- full view is tagged, the type is marked tagged for layout + -- reasons, but it has no dispatch table. + + elsif Is_Derived_Type (Typ) + and then Is_Private_Type (Etype (Typ)) + and then not Is_Tagged_Type (Etype (Typ)) + then + return; + end if; + + -- Create and decorate the tags. Suppress their creation when + -- not Tagged_Type_Expansion because the dispatching mechanism is + -- handled internally by the virtual target. + + if Tagged_Type_Expansion then + Append_Freeze_Actions (Typ, Make_Tags (Typ)); + + -- Generate dispatch table of locally defined tagged type. + -- Dispatch tables of library level tagged types are built + -- later (see Analyze_Declarations). + + if not Building_Static_DT (Typ) then + Append_Freeze_Actions (Typ, Make_DT (Typ)); + end if; + end if; + + -- If the type has unknown discriminants, propagate dispatching + -- information to its underlying record view, which does not get + -- its own dispatch table. + + if Is_Derived_Type (Typ) + and then Has_Unknown_Discriminants (Typ) + and then Present (Underlying_Record_View (Typ)) + then + declare + Rep : constant Entity_Id := Underlying_Record_View (Typ); + begin + Set_Access_Disp_Table + (Rep, Access_Disp_Table (Typ)); + Set_Dispatch_Table_Wrappers + (Rep, Dispatch_Table_Wrappers (Typ)); + Set_Direct_Primitive_Operations + (Rep, Direct_Primitive_Operations (Typ)); + end; + end if; + + -- Make sure that the primitives Initialize, Adjust and Finalize + -- are Frozen before other TSS subprograms. We don't want them + -- Frozen inside. + + if Is_Controlled (Typ) then + if not Is_Limited_Type (Typ) then + Append_Freeze_Actions (Typ, + Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ)); + end if; + + Append_Freeze_Actions (Typ, + Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ)); + + Append_Freeze_Actions (Typ, + Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ)); + end if; + + -- Freeze rest of primitive operations. There is no need to handle + -- the predefined primitives if we are compiling under restriction + -- No_Dispatching_Calls. + + if not Restriction_Active (No_Dispatching_Calls) then + Append_Freeze_Actions (Typ, Predefined_Primitive_Freeze (Typ)); + end if; + end if; + + -- In the untagged case, ever since Ada 83 an equality function must + -- be provided for variant records that are not unchecked unions. + -- In Ada 2012 the equality function composes, and thus must be built + -- explicitly just as for tagged records. + + elsif Has_Discriminants (Typ) + and then not Is_Limited_Type (Typ) + then + declare + Comps : constant Node_Id := + Component_List (Type_Definition (Typ_Decl)); + begin + if Present (Comps) + and then Present (Variant_Part (Comps)) + then + Build_Variant_Record_Equality (Typ); + end if; + end; + + -- Otherwise create primitive equality operation (AI05-0123) + + -- This is done unconditionally to ensure that tools can be linked + -- properly with user programs compiled with older language versions. + -- In addition, this is needed because "=" composes for bounded strings + -- in all language versions (see Exp_Ch4.Expand_Composite_Equality). + + elsif Comes_From_Source (Typ) + and then Convention (Typ) = Convention_Ada + and then not Is_Limited_Type (Typ) + then + Build_Untagged_Equality (Typ); + 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 (Typ) + and then Has_Discriminants (Typ) + then + declare + Ctyp : constant Entity_Id := + Corresponding_Concurrent_Type (Typ); + Conc_Discr : Entity_Id; + Rec_Discr : Entity_Id; + Temp : Entity_Id; + + begin + Conc_Discr := First_Discriminant (Ctyp); + Rec_Discr := First_Discriminant (Typ); + 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 (Typ) then + Build_Controlling_Procs (Typ); + end if; + + Adjust_Discriminants (Typ); + + -- Do not need init for interfaces on virtual targets since they're + -- abstract. + + if Tagged_Type_Expansion or else not Is_Interface (Typ) then + Build_Record_Init_Proc (Typ_Decl, Typ); + end if; + + -- For tagged type that are not interfaces, build bodies of primitive + -- operations. Note: do this after building the record initialization + -- procedure, since the primitive operations may need the initialization + -- routine. There is no need to add predefined primitives of interfaces + -- because all their predefined primitives are abstract. + + if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then + + -- Do not add the body of predefined primitives in case of CPP tagged + -- type derivations that have convention CPP. + + if Is_CPP_Class (Root_Type (Typ)) + and then Convention (Typ) = Convention_CPP + then + null; + + -- Do not add the body of the predefined primitives if we are + -- compiling under restriction No_Dispatching_Calls or if we are + -- compiling a CPP tagged type. + + elsif not Restriction_Active (No_Dispatching_Calls) then + + -- Create the body of TSS primitive Finalize_Address. This must + -- be done before the bodies of all predefined primitives are + -- created. If Typ is limited, Stream_Input and Stream_Read may + -- produce build-in-place allocations and for those the expander + -- needs Finalize_Address. + + Make_Finalize_Address_Body (Typ); + Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq); + Append_Freeze_Actions (Typ, Predef_List); + end if; + + -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden + -- inherited functions, then add their bodies to the freeze actions. + + if Present (Wrapper_Body_List) then + Append_Freeze_Actions (Typ, Wrapper_Body_List); + end if; + + -- Create extra formals for the primitive operations of the type. + -- This must be done before analyzing the body of the initialization + -- procedure, because a self-referential type might call one of these + -- primitives in the body of the init_proc itself. + + declare + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Subp := Node (Elmt); + if not Has_Foreign_Convention (Subp) + and then not Is_Predefined_Dispatching_Operation (Subp) + then + Create_Extra_Formals (Subp); + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + end Expand_Freeze_Record_Type; + + ------------------------------------ + -- Expand_N_Full_Type_Declaration -- + ------------------------------------ + + procedure Expand_N_Full_Type_Declaration (N : Node_Id) is + procedure Build_Master (Ptr_Typ : Entity_Id); + -- Create the master associated with Ptr_Typ + + ------------------ + -- Build_Master -- + ------------------ + + procedure Build_Master (Ptr_Typ : Entity_Id) is + Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ); + + begin + -- If the designated type is an incomplete view coming from a + -- limited-with'ed package, we need to use the nonlimited view in + -- case it has tasks. + + if Ekind (Desig_Typ) in Incomplete_Kind + and then Present (Non_Limited_View (Desig_Typ)) + then + Desig_Typ := Non_Limited_View (Desig_Typ); + end if; + + -- 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 Comes_From_Source (N) and then Has_Task (Desig_Typ) then + Build_Master_Entity (Ptr_Typ); + Build_Master_Renaming (Ptr_Typ); + + -- 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. + + -- Note: This code covers access-to-limited-interfaces because they + -- can be used to reference tasks implementing them. + + elsif Is_Limited_Class_Wide_Type (Desig_Typ) + and then Tasking_Allowed + then + Build_Class_Wide_Master (Ptr_Typ); + end if; + end Build_Master; + + -- Local declarations + + Def_Id : constant Entity_Id := Defining_Identifier (N); + B_Id : constant Entity_Id := Base_Type (Def_Id); + FN : Node_Id; + Par_Id : Entity_Id; + + -- Start of processing for Expand_N_Full_Type_Declaration + + begin + if Is_Access_Type (Def_Id) then + Build_Master (Def_Id); + + if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then + Expand_Access_Protected_Subprogram_Type (N); + end if; + + -- Array of anonymous access-to-task pointers + + elsif Ada_Version >= Ada_2005 + and then Is_Array_Type (Def_Id) + and then Is_Access_Type (Component_Type (Def_Id)) + and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type + then + Build_Master (Component_Type (Def_Id)); + + elsif Has_Task (Def_Id) then + Expand_Previous_Access_Type (Def_Id); + + -- Check the components of a record type or array of records for + -- anonymous access-to-task pointers. + + elsif Ada_Version >= Ada_2005 + and then (Is_Record_Type (Def_Id) + or else + (Is_Array_Type (Def_Id) + and then Is_Record_Type (Component_Type (Def_Id)))) + then + declare + Comp : Entity_Id; + First : Boolean; + M_Id : Entity_Id; + Typ : Entity_Id; + + begin + if Is_Array_Type (Def_Id) then + Comp := First_Entity (Component_Type (Def_Id)); + else + Comp := First_Entity (Def_Id); + end if; + + -- Examine all components looking for anonymous access-to-task + -- types. + + First := True; + while Present (Comp) loop + Typ := Etype (Comp); + + if Ekind (Typ) = E_Anonymous_Access_Type + and then Has_Task (Available_View (Designated_Type (Typ))) + and then No (Master_Id (Typ)) + then + -- Ensure that the record or array type have a _master + + if First then + Build_Master_Entity (Def_Id); + Build_Master_Renaming (Typ); + M_Id := Master_Id (Typ); + + First := False; + + -- Reuse the same master to service any additional types + + else + Set_Master_Id (Typ, M_Id); + end if; + end if; + + Next_Entity (Comp); + end loop; + end; + 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 : constant 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 -- + --------------------------------- + + procedure Expand_N_Object_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Def_Id : constant Entity_Id := Defining_Identifier (N); + Expr : constant Node_Id := Expression (N); + Obj_Def : constant Node_Id := Object_Definition (N); + Typ : constant Entity_Id := Etype (Def_Id); + Base_Typ : constant Entity_Id := Base_Type (Typ); + Expr_Q : Node_Id; + + function Build_Equivalent_Aggregate return Boolean; + -- If the object has a constrained discriminated type and no initial + -- value, it may be possible to build an equivalent aggregate instead, + -- and prevent an actual call to the initialization procedure. + + procedure Check_Large_Modular_Array; + -- Check that the size of the array can be computed without overflow, + -- and generate a Storage_Error otherwise. This is only relevant for + -- array types whose index in a (mod 2**64) type, where wrap-around + -- arithmetic might yield a meaningless value for the length of the + -- array, or its corresponding attribute. + + procedure Count_Default_Sized_Task_Stacks + (Typ : Entity_Id; + Pri_Stacks : out Int; + Sec_Stacks : out Int); + -- Count the number of default-sized primary and secondary task stacks + -- required for task objects contained within type Typ. If the number of + -- task objects contained within the type is not known at compile time + -- the procedure will return the stack counts of zero. + + procedure Default_Initialize_Object (After : Node_Id); + -- Generate all default initialization actions for object Def_Id. Any + -- new code is inserted after node After. + + function Rewrite_As_Renaming return Boolean; + -- Indicate whether to rewrite a declaration with initialization into an + -- object renaming declaration (see below). + + -------------------------------- + -- Build_Equivalent_Aggregate -- + -------------------------------- + + function Build_Equivalent_Aggregate return Boolean is + Aggr : Node_Id; + Comp : Entity_Id; + Discr : Elmt_Id; + Full_Type : Entity_Id; + + begin + Full_Type := Typ; + + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + Full_Type := Full_View (Typ); + end if; + + -- Only perform this transformation if Elaboration_Code is forbidden + -- or undesirable, and if this is a global entity of a constrained + -- record type. + + -- If Initialize_Scalars might be active this transformation cannot + -- be performed either, because it will lead to different semantics + -- or because elaboration code will in fact be created. + + if Ekind (Full_Type) /= E_Record_Subtype + or else not Has_Discriminants (Full_Type) + or else not Is_Constrained (Full_Type) + or else Is_Controlled (Full_Type) + or else Is_Limited_Type (Full_Type) + or else not Restriction_Active (No_Initialize_Scalars) + then + return False; + end if; + + if Ekind (Current_Scope) = E_Package + and then + (Restriction_Active (No_Elaboration_Code) + or else Is_Preelaborated (Current_Scope)) + then + -- Building a static aggregate is possible if the discriminants + -- have static values and the other components have static + -- defaults or none. + + Discr := First_Elmt (Discriminant_Constraint (Full_Type)); + while Present (Discr) loop + if not Is_OK_Static_Expression (Node (Discr)) then + return False; + end if; + + Next_Elmt (Discr); + end loop; + + -- Check that initialized components are OK, and that non- + -- initialized components do not require a call to their own + -- initialization procedure. + + Comp := First_Component (Full_Type); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Present (Expression (Parent (Comp))) + and then + not Is_OK_Static_Expression (Expression (Parent (Comp))) + then + return False; + + elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then + return False; + + end if; + + Next_Component (Comp); + end loop; + + -- Everything is static, assemble the aggregate, discriminant + -- values first. + + Aggr := + Make_Aggregate (Loc, + Expressions => New_List, + Component_Associations => New_List); + + Discr := First_Elmt (Discriminant_Constraint (Full_Type)); + while Present (Discr) loop + Append_To (Expressions (Aggr), New_Copy (Node (Discr))); + Next_Elmt (Discr); + end loop; + + -- Now collect values of initialized components + + Comp := First_Component (Full_Type); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Present (Expression (Parent (Comp))) + then + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => New_List (New_Occurrence_Of (Comp, Loc)), + Expression => New_Copy_Tree + (Expression (Parent (Comp))))); + end if; + + Next_Component (Comp); + end loop; + + -- Finally, box-initialize remaining components + + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => New_List (Make_Others_Choice (Loc)), + Expression => Empty)); + Set_Box_Present (Last (Component_Associations (Aggr))); + Set_Expression (N, Aggr); + + if Typ /= Full_Type then + Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type))); + Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr)); + Analyze_And_Resolve (Aggr, Typ); + else + Analyze_And_Resolve (Aggr, Full_Type); + end if; + + return True; + + else + return False; + end if; + end Build_Equivalent_Aggregate; + + ------------------------------- + -- Check_Large_Modular_Array -- + ------------------------------- + + procedure Check_Large_Modular_Array is + Index_Typ : Entity_Id; + + begin + if Is_Array_Type (Typ) + and then Is_Modular_Integer_Type (Etype (First_Index (Typ))) + then + -- To prevent arithmetic overflow with large values, we raise + -- Storage_Error under the following guard: + + -- (Arr'Last / 2 - Arr'First / 2) > (2 ** 30) + + -- This takes care of the boundary case, but it is preferable to + -- use a smaller limit, because even on 64-bit architectures an + -- array of more than 2 ** 30 bytes is likely to raise + -- Storage_Error. + + Index_Typ := Etype (First_Index (Typ)); + + if RM_Size (Index_Typ) = RM_Size (Standard_Long_Long_Integer) then + Insert_Action (N, + Make_Raise_Storage_Error (Loc, + Condition => + Make_Op_Ge (Loc, + Left_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Op_Divide (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Last), + Right_Opnd => + Make_Integer_Literal (Loc, Uint_2)), + Right_Opnd => + Make_Op_Divide (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_First), + Right_Opnd => + Make_Integer_Literal (Loc, Uint_2))), + Right_Opnd => + Make_Integer_Literal (Loc, (Uint_2 ** 30))), + Reason => SE_Object_Too_Large)); + end if; + end if; + end Check_Large_Modular_Array; + + ------------------------------------- + -- Count_Default_Sized_Task_Stacks -- + ------------------------------------- + + procedure Count_Default_Sized_Task_Stacks + (Typ : Entity_Id; + Pri_Stacks : out Int; + Sec_Stacks : out Int) + is + Component : Entity_Id; + + begin + -- To calculate the number of default-sized task stacks required for + -- an object of Typ, a depth-first recursive traversal of the AST + -- from the Typ entity node is undertaken. Only type nodes containing + -- task objects are visited. + + Pri_Stacks := 0; + Sec_Stacks := 0; + + if not Has_Task (Typ) then + return; + end if; + + case Ekind (Typ) is + when E_Task_Subtype + | E_Task_Type + => + -- A task type is found marking the bottom of the descent. If + -- the type has no representation aspect for the corresponding + -- stack then that stack is using the default size. + + if Present (Get_Rep_Item (Typ, Name_Storage_Size)) then + Pri_Stacks := 0; + else + Pri_Stacks := 1; + end if; + + if Present (Get_Rep_Item (Typ, Name_Secondary_Stack_Size)) then + Sec_Stacks := 0; + else + Sec_Stacks := 1; + end if; + + when E_Array_Subtype + | E_Array_Type + => + -- First find the number of default stacks contained within an + -- array component. + + Count_Default_Sized_Task_Stacks + (Component_Type (Typ), + Pri_Stacks, + Sec_Stacks); + + -- Then multiply the result by the size of the array + + declare + Quantity : constant Int := Number_Of_Elements_In_Array (Typ); + -- Number_Of_Elements_In_Array is non-trival, consequently + -- its result is captured as an optimization. + + begin + Pri_Stacks := Pri_Stacks * Quantity; + Sec_Stacks := Sec_Stacks * Quantity; + end; + + when E_Protected_Subtype + | E_Protected_Type + | E_Record_Subtype + | E_Record_Type + => + Component := First_Component_Or_Discriminant (Typ); + + -- Recursively descend each component of the composite type + -- looking for tasks, but only if the component is marked as + -- having a task. + + while Present (Component) loop + if Has_Task (Etype (Component)) then + declare + P : Int; + S : Int; + + begin + Count_Default_Sized_Task_Stacks + (Etype (Component), P, S); + Pri_Stacks := Pri_Stacks + P; + Sec_Stacks := Sec_Stacks + S; + end; + end if; + + Next_Component_Or_Discriminant (Component); + end loop; + + when E_Limited_Private_Subtype + | E_Limited_Private_Type + | E_Record_Subtype_With_Private + | E_Record_Type_With_Private + => + -- Switch to the full view of the private type to continue + -- search. + + Count_Default_Sized_Task_Stacks + (Full_View (Typ), Pri_Stacks, Sec_Stacks); + + -- Other types should not contain tasks + + when others => + raise Program_Error; + end case; + end Count_Default_Sized_Task_Stacks; + + ------------------------------- + -- Default_Initialize_Object -- + ------------------------------- + + procedure Default_Initialize_Object (After : Node_Id) is + function New_Object_Reference return Node_Id; + -- Return a new reference to Def_Id with attributes Assignment_OK and + -- Must_Not_Freeze already set. + + -------------------------- + -- New_Object_Reference -- + -------------------------- + + function New_Object_Reference return Node_Id is + Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc); + + begin + -- The call to the type init proc or [Deep_]Finalize must not + -- freeze the related object as the call is internally generated. + -- This way legal rep clauses that apply to the object will not be + -- flagged. Note that the initialization call may be removed if + -- pragma Import is encountered or moved to the freeze actions of + -- the object because of an address clause. + + Set_Assignment_OK (Obj_Ref); + Set_Must_Not_Freeze (Obj_Ref); + + return Obj_Ref; + end New_Object_Reference; + + -- Local variables + + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + + Aggr_Init : Node_Id; + Comp_Init : List_Id := No_List; + Fin_Block : Node_Id; + Fin_Call : Node_Id; + Init_Stmts : List_Id := No_List; + Obj_Init : Node_Id := Empty; + Obj_Ref : Node_Id; + + -- Start of processing for Default_Initialize_Object + + begin + -- Default initialization is suppressed for objects that are already + -- known to be imported (i.e. whose declaration specifies the Import + -- aspect). Note that for objects with a pragma Import, we generate + -- initialization here, and then remove it downstream when processing + -- the pragma. It is also suppressed for variables for which a pragma + -- Suppress_Initialization has been explicitly given + + if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then + return; + + -- Nothing to do if the object being initialized is of a task type + -- and restriction No_Tasking is in effect, because this is a direct + -- violation of the restriction. + + elsif Is_Task_Type (Base_Typ) + and then Restriction_Active (No_Tasking) + then + return; + end if; + + -- The expansion performed by this routine is as follows: + + -- begin + -- Abort_Defer; + -- Type_Init_Proc (Obj); + + -- begin + -- [Deep_]Initialize (Obj); + + -- exception + -- when others => + -- [Deep_]Finalize (Obj, Self => False); + -- raise; + -- end; + -- at end + -- Abort_Undefer_Direct; + -- end; + + -- Initialize the components of the object + + if Has_Non_Null_Base_Init_Proc (Typ) + and then not No_Initialization (N) + and then not Initialization_Suppressed (Typ) + then + -- Do not initialize the components if No_Default_Initialization + -- applies as the actual restriction check will occur later + -- when the object is frozen as it is not known yet whether the + -- object is imported or not. + + if not Restriction_Active (No_Default_Initialization) then + + -- If the values of the components are compile-time known, use + -- their prebuilt aggregate form directly. + + Aggr_Init := Static_Initialization (Base_Init_Proc (Typ)); + + if Present (Aggr_Init) then + Set_Expression + (N, New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope)); + + -- If type has discriminants, try to build an equivalent + -- aggregate using discriminant values from the declaration. + -- This is a useful optimization, in particular if restriction + -- No_Elaboration_Code is active. + + elsif Build_Equivalent_Aggregate then + null; + + -- Otherwise invoke the type init proc, generate: + -- Type_Init_Proc (Obj); + + else + Obj_Ref := New_Object_Reference; + + if Comes_From_Source (Def_Id) then + Initialization_Warning (Obj_Ref); + end if; + + Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ); + end if; + end if; + + -- Provide a default value if the object needs simple initialization + -- and does not already have an initial value. A generated temporary + -- does not require initialization because it will be assigned later. + + elsif Needs_Simple_Initialization + (Typ, Initialize_Scalars + and then No (Following_Address_Clause (N))) + and then not Is_Internal (Def_Id) + and then not Has_Init_Expression (N) + then + Set_No_Initialization (N, False); + Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id))); + Analyze_And_Resolve (Expression (N), Typ); + end if; + + -- Initialize the object, generate: + -- [Deep_]Initialize (Obj); + + if Needs_Finalization (Typ) and then not No_Initialization (N) then + Obj_Init := + Make_Init_Call + (Obj_Ref => New_Occurrence_Of (Def_Id, Loc), + Typ => Typ); + end if; + + -- Build a special finalization block when both the object and its + -- controlled components are to be initialized. The block finalizes + -- the components if the object initialization fails. Generate: + + -- begin + -- <Obj_Init> + + -- exception + -- when others => + -- <Fin_Call> + -- raise; + -- end; + + if Has_Controlled_Component (Typ) + and then Present (Comp_Init) + and then Present (Obj_Init) + and then Exceptions_OK + then + Init_Stmts := Comp_Init; + + Fin_Call := + Make_Final_Call + (Obj_Ref => New_Object_Reference, + Typ => Typ, + Skip_Self => True); + + if Present (Fin_Call) then + Fin_Block := + Make_Block_Statement (Loc, + Declarations => No_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Obj_Init), + + Exception_Handlers => New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List ( + Make_Others_Choice (Loc)), + + Statements => New_List ( + Fin_Call, + Make_Raise_Statement (Loc)))))); + + -- Signal the ABE mechanism that the block carries out + -- initialization actions. + + Set_Is_Initialization_Block (Fin_Block); + + Append_To (Init_Stmts, Fin_Block); + end if; + + -- Otherwise finalization is not required, the initialization calls + -- are passed to the abort block building circuitry, generate: + + -- Type_Init_Proc (Obj); + -- [Deep_]Initialize (Obj); + + else + if Present (Comp_Init) then + Init_Stmts := Comp_Init; + end if; + + if Present (Obj_Init) then + if No (Init_Stmts) then + Init_Stmts := New_List; + end if; + + Append_To (Init_Stmts, Obj_Init); + end if; + end if; + + -- Build an abort block to protect the initialization calls + + if Abort_Allowed + and then Present (Comp_Init) + and then Present (Obj_Init) + then + -- Generate: + -- Abort_Defer; + + Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); + + -- When exceptions are propagated, abort deferral must take place + -- in the presence of initialization or finalization exceptions. + -- Generate: + + -- begin + -- Abort_Defer; + -- <Init_Stmts> + -- at end + -- Abort_Undefer_Direct; + -- end; + + if Exceptions_OK then + Init_Stmts := New_List ( + Build_Abort_Undefer_Block (Loc, + Stmts => Init_Stmts, + Context => N)); + + -- Otherwise exceptions are not propagated. Generate: + + -- Abort_Defer; + -- <Init_Stmts> + -- Abort_Undefer; + + else + Append_To (Init_Stmts, + Build_Runtime_Call (Loc, RE_Abort_Undefer)); + end if; + end if; + + -- Insert the whole initialization sequence into the tree. If the + -- object has a delayed freeze, as will be the case when it has + -- aspect specifications, the initialization sequence is part of + -- the freeze actions. + + if Present (Init_Stmts) then + if Has_Delayed_Freeze (Def_Id) then + Append_Freeze_Actions (Def_Id, Init_Stmts); + else + Insert_Actions_After (After, Init_Stmts); + end if; + end if; + end Default_Initialize_Object; + + ------------------------- + -- Rewrite_As_Renaming -- + ------------------------- + + function Rewrite_As_Renaming return Boolean is + begin + -- If the object declaration appears in the form + + -- Obj : Ctrl_Typ := Func (...); + + -- where Ctrl_Typ is controlled but not immutably limited type, then + -- the expansion of the function call should use a dereference of the + -- result to reference the value on the secondary stack. + + -- Obj : Ctrl_Typ renames Func (...).all; + + -- As a result, the call avoids an extra copy. This an optimization, + -- but it is required for passing ACATS tests in some cases where it + -- would otherwise make two copies. The RM allows removing redunant + -- Adjust/Finalize calls, but does not allow insertion of extra ones. + + -- This part is disabled for now, because it breaks GPS builds + + return (False -- ??? + and then Nkind (Expr_Q) = N_Explicit_Dereference + and then not Comes_From_Source (Expr_Q) + and then Nkind (Original_Node (Expr_Q)) = N_Function_Call + and then Nkind (Object_Definition (N)) in N_Has_Entity + and then (Needs_Finalization (Entity (Object_Definition (N))))) + + -- If the initializing expression is for a variable with attribute + -- OK_To_Rename set, then transform: + + -- Obj : Typ := Expr; + + -- into + + -- Obj : Typ renames Expr; + + -- provided that Obj is not aliased. The aliased case has to be + -- excluded in general because Expr will not be aliased in + -- general. + + or else + (not Aliased_Present (N) + and then Is_Entity_Name (Expr_Q) + and then Ekind (Entity (Expr_Q)) = E_Variable + and then OK_To_Rename (Entity (Expr_Q)) + and then Is_Entity_Name (Obj_Def)); + end Rewrite_As_Renaming; + + -- Local variables + + Next_N : constant Node_Id := Next (N); + + Adj_Call : Node_Id; + Id_Ref : Node_Id; + Tag_Assign : Node_Id; + + Init_After : Node_Id := N; + -- Node after which the initialization actions are to be inserted. This + -- is normally N, except for the case of a shared passive variable, in + -- which case the init proc call must be inserted only after the bodies + -- of the shared variable procedures have been seen. + + -- Start of processing for Expand_N_Object_Declaration + + begin + -- Don't do anything for deferred constants. All proper actions will be + -- expanded during the full declaration. + + if No (Expr) and Constant_Present (N) then + return; + end if; + + -- The type of the object cannot be abstract. This is diagnosed at the + -- point the object is frozen, which happens after the declaration is + -- fully expanded, so simply return now. + + if Is_Abstract_Type (Typ) then + return; + end if; + + -- No action needed for the internal imported dummy object added by + -- Make_DT to compute the offset of the components that reference + -- secondary dispatch tables; required to avoid never-ending loop + -- processing this internal object declaration. + + if Tagged_Type_Expansion + and then Is_Internal (Def_Id) + and then Is_Imported (Def_Id) + and then Related_Type (Def_Id) = Implementation_Base_Type (Typ) + then + return; + end if; + + -- 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. + + -- Force construction of dispatch tables of library level tagged types + + if Tagged_Type_Expansion + and then Static_Dispatch_Tables + and then Is_Library_Level_Entity (Def_Id) + and then Is_Library_Level_Tagged_Type (Base_Typ) + and then Ekind_In (Base_Typ, E_Record_Type, + E_Protected_Type, + E_Task_Type) + and then not Has_Dispatch_Table (Base_Typ) + then + declare + New_Nodes : List_Id := No_List; + + begin + if Is_Concurrent_Type (Base_Typ) then + New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N); + else + New_Nodes := Make_DT (Base_Typ, N); + end if; + + if not Is_Empty_List (New_Nodes) then + Insert_List_Before (N, New_Nodes); + end if; + end; + end if; + + -- Make shared memory routines for shared passive variable + + if Is_Shared_Passive (Def_Id) then + Init_After := 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; + + Check_Large_Modular_Array; + + -- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations + -- restrictions are active then default-sized secondary stacks are + -- generated by the binder and allocated by SS_Init. To provide the + -- binder the number of stacks to generate, the number of default-sized + -- stacks required for task objects contained within the object + -- declaration N is calculated here as it is at this point where + -- unconstrained types become constrained. The result is stored in the + -- enclosing unit's Unit_Record. + + -- Note if N is an array object declaration that has an initialization + -- expression, a second object declaration for the initialization + -- expression is created by the compiler. To prevent double counting + -- of the stacks in this scenario, the stacks of the first array are + -- not counted. + + if Has_Task (Typ) + and then not Restriction_Active (No_Secondary_Stack) + and then (Restriction_Active (No_Implicit_Heap_Allocations) + or else Restriction_Active (No_Implicit_Task_Allocations)) + and then not (Ekind_In (Ekind (Typ), E_Array_Type, E_Array_Subtype) + and then (Has_Init_Expression (N))) + then + declare + PS_Count, SS_Count : Int := 0; + begin + Count_Default_Sized_Task_Stacks (Typ, PS_Count, SS_Count); + Increment_Primary_Stack_Count (PS_Count); + Increment_Sec_Stack_Count (SS_Count); + end; + end if; + + -- Default initialization required, and no expression present + + if No (Expr) then + + -- If we have a type with a variant part, the initialization proc + -- will contain implicit tests of the discriminant values, which + -- counts as a violation of the restriction No_Implicit_Conditionals. + + if Has_Variant_Part (Typ) then + declare + Msg : Boolean; + + begin + Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def); + + if Msg then + Error_Msg_N + ("\initialization of variant record tests discriminants", + Obj_Def); + return; + end if; + end; + end if; + + -- For the default initialization case, if we have a private type + -- with invariants, and invariant checks are enabled, then insert an + -- invariant check after the object declaration. Note that it is OK + -- to clobber the object with an invalid value since if the exception + -- is raised, then the object will go out of scope. In the case where + -- an array object is initialized with an aggregate, the expression + -- is removed. Check flag Has_Init_Expression to avoid generating a + -- junk invariant check and flag No_Initialization to avoid checking + -- an uninitialized object such as a compiler temporary used for an + -- aggregate. + + if Has_Invariants (Base_Typ) + and then Present (Invariant_Procedure (Base_Typ)) + and then not Has_Init_Expression (N) + and then not No_Initialization (N) + then + -- If entity has an address clause or aspect, make invariant + -- call into a freeze action for the explicit freeze node for + -- object. Otherwise insert invariant check after declaration. + + if Present (Following_Address_Clause (N)) + or else Has_Aspect (Def_Id, Aspect_Address) + then + Ensure_Freeze_Node (Def_Id); + Set_Has_Delayed_Freeze (Def_Id); + Set_Is_Frozen (Def_Id, False); + + if not Partial_View_Has_Unknown_Discr (Typ) then + Append_Freeze_Action (Def_Id, + Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); + end if; + + elsif not Partial_View_Has_Unknown_Discr (Typ) then + Insert_After (N, + Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); + end if; + end if; + + Default_Initialize_Object (Init_After); + + -- Generate attribute for Persistent_BSS if needed + + if Persistent_BSS_Mode + and then Comes_From_Source (N) + and then Is_Potentially_Persistent_Type (Typ) + and then not Has_Init_Expression (N) + and then Is_Library_Level_Entity (Def_Id) + then + declare + Prag : Node_Id; + begin + Prag := + Make_Linker_Section_Pragma + (Def_Id, Sloc (N), ".persistent.bss"); + Insert_After (N, Prag); + Analyze (Prag); + end; + end if; + + -- If access type, then we know it is null if not initialized + + if Is_Access_Type (Typ) then + Set_Is_Known_Null (Def_Id); + 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 temporary. + + if Is_Delayed_Aggregate (Expr_Q) then + Convert_Aggr_In_Object_Decl (N); + + -- Ada 2005 (AI-318-02): If the initialization expression is a call + -- to a build-in-place function, then access to the declared object + -- must be passed to the function. Currently we limit such functions + -- to those with constrained limited result subtypes, but eventually + -- plan to expand the allowed forms of functions that are treated as + -- build-in-place. + + elsif Is_Build_In_Place_Function_Call (Expr_Q) then + Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q); + + -- The previous call expands the expression initializing the + -- built-in-place object into further code that will be analyzed + -- later. No further expansion needed here. + + return; + + -- This is the same as the previous 'elsif', except that the call has + -- been transformed by other expansion activities into something like + -- F(...)'Reference. + + elsif Nkind (Expr_Q) = N_Reference + and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q)) + and then not Is_Expanded_Build_In_Place_Call + (Unqual_Conv (Prefix (Expr_Q))) + then + Make_Build_In_Place_Call_In_Anonymous_Context (Prefix (Expr_Q)); + + -- The previous call expands the expression initializing the + -- built-in-place object into further code that will be analyzed + -- later. No further expansion needed here. + + return; + + -- Ada 2005 (AI-318-02): Specialization of the previous case for + -- expressions containing a build-in-place function call whose + -- returned object covers interface types, and Expr_Q has calls to + -- Ada.Tags.Displace to displace the pointer to the returned build- + -- in-place object to reference the secondary dispatch table of a + -- covered interface type. + + elsif Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) then + Make_Build_In_Place_Iface_Call_In_Object_Declaration (N, Expr_Q); + + -- The previous call expands the expression initializing the + -- built-in-place object into further code that will be analyzed + -- later. No further expansion needed here. + + return; + + -- Ada 2005 (AI-251): Rewrite the expression that initializes a + -- class-wide interface object to ensure that we copy the full + -- object, unless we are targetting a VM where interfaces are handled + -- by VM itself. Note that if the root type of Typ is an ancestor of + -- Expr's type, both types share the same dispatch table and there is + -- no need to displace the pointer. + + elsif Is_Interface (Typ) + + -- Avoid never-ending recursion because if Equivalent_Type is set + -- then we've done it already and must not do it again. + + and then not + (Nkind (Obj_Def) = N_Identifier + and then Present (Equivalent_Type (Entity (Obj_Def)))) + then + pragma Assert (Is_Class_Wide_Type (Typ)); + + -- If the object is a return object of an inherently limited type, + -- which implies build-in-place treatment, bypass the special + -- treatment of class-wide interface initialization below. In this + -- case, the expansion of the return statement will take care of + -- creating the object (via allocator) and initializing it. + + if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then + null; + + elsif Tagged_Type_Expansion then + declare + Iface : constant Entity_Id := Root_Type (Typ); + Expr_N : Node_Id := Expr; + Expr_Typ : Entity_Id; + New_Expr : Node_Id; + Obj_Id : Entity_Id; + Tag_Comp : Node_Id; + + begin + -- If the original node of the expression was a conversion + -- to this specific class-wide interface type then restore + -- the original node because we must copy the object before + -- displacing the pointer to reference the secondary tag + -- component. This code must be kept synchronized with the + -- expansion done by routine Expand_Interface_Conversion + + if not Comes_From_Source (Expr_N) + and then Nkind (Expr_N) = N_Explicit_Dereference + and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion + and then Etype (Original_Node (Expr_N)) = Typ + then + Rewrite (Expr_N, Original_Node (Expression (N))); + end if; + + -- Avoid expansion of redundant interface conversion + + if Is_Interface (Etype (Expr_N)) + and then Nkind (Expr_N) = N_Type_Conversion + and then Etype (Expr_N) = Typ + then + Expr_N := Expression (Expr_N); + Set_Expression (N, Expr_N); + end if; + + Obj_Id := Make_Temporary (Loc, 'D', Expr_N); + Expr_Typ := Base_Type (Etype (Expr_N)); + + if Is_Class_Wide_Type (Expr_Typ) then + Expr_Typ := Root_Type (Expr_Typ); + end if; + + -- Replace + -- CW : I'Class := Obj; + -- by + -- Tmp : T := Obj; + -- type Ityp is not null access I'Class; + -- CW : I'Class renames Ityp (Tmp.I_Tag'Address).all; + + if Comes_From_Source (Expr_N) + and then Nkind (Expr_N) = N_Identifier + and then not Is_Interface (Expr_Typ) + and then Interface_Present_In_Ancestor (Expr_Typ, Typ) + and then (Expr_Typ = Etype (Expr_Typ) + or else not + Is_Variable_Size_Record (Etype (Expr_Typ))) + then + -- Copy the object + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => + New_Occurrence_Of (Expr_Typ, Loc), + Expression => Relocate_Node (Expr_N))); + + -- Statically reference the tag associated with the + -- interface + + Tag_Comp := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc), + Selector_Name => + New_Occurrence_Of + (Find_Interface_Tag (Expr_Typ, Iface), Loc)); + + -- Replace + -- IW : I'Class := Obj; + -- by + -- type Equiv_Record is record ... end record; + -- implicit subtype CW is <Class_Wide_Subtype>; + -- Tmp : CW := CW!(Obj); + -- type Ityp is not null access I'Class; + -- IW : I'Class renames + -- Ityp!(Displace (Temp'Address, I'Tag)).all; + + else + -- Generate the equivalent record type and update the + -- subtype indication to reference it. + + Expand_Subtype_From_Expr + (N => N, + Unc_Type => Typ, + Subtype_Indic => Obj_Def, + Exp => Expr_N); + + if not Is_Interface (Etype (Expr_N)) then + New_Expr := Relocate_Node (Expr_N); + + -- For interface types we use 'Address which displaces + -- the pointer to the base of the object (if required) + + else + New_Expr := + Unchecked_Convert_To (Etype (Obj_Def), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Expr_N), + Attribute_Name => Name_Address)))); + end if; + + -- Copy the object + + if not Is_Limited_Record (Expr_Typ) then + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => + New_Occurrence_Of (Etype (Obj_Def), Loc), + Expression => New_Expr)); + + -- Rename limited type object since they cannot be copied + -- This case occurs when the initialization expression + -- has been previously expanded into a temporary object. + + else pragma Assert (not Comes_From_Source (Expr_Q)); + Insert_Action (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Obj_Id, + Subtype_Mark => + New_Occurrence_Of (Etype (Obj_Def), Loc), + Name => + Unchecked_Convert_To + (Etype (Obj_Def), New_Expr))); + end if; + + -- Dynamically reference the tag associated with the + -- interface. + + Tag_Comp := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Displace), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc), + Attribute_Name => Name_Address), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Iface))), + Loc))); + end if; + + Rewrite (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'D'), + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => + Convert_Tag_To_Interface (Typ, Tag_Comp))); + + -- If the original entity comes from source, then mark the + -- new entity as needing debug information, even though it's + -- defined by a generated renaming that does not come from + -- source, so that Materialize_Entity will be set on the + -- entity when Debug_Renaming_Declaration is called during + -- analysis. + + if Comes_From_Source (Def_Id) then + Set_Debug_Info_Needed (Defining_Identifier (N)); + end if; + + Analyze (N, Suppress => All_Checks); + + -- Replace internal identifier of rewritten node by the + -- identifier found in the sources. We also have to exchange + -- entities containing their defining identifiers to ensure + -- the correct replacement of the object declaration by this + -- object renaming declaration because these identifiers + -- were previously added by Enter_Name to the current scope. + -- We must preserve the homonym chain of the source entity + -- as well. We must also preserve the kind of the entity, + -- which may be a constant. Preserve entity chain because + -- itypes may have been generated already, and the full + -- chain must be preserved for final freezing. Finally, + -- preserve Comes_From_Source setting, so that debugging + -- and cross-referencing information is properly kept, and + -- preserve source location, to prevent spurious errors when + -- entities are declared (they must have their own Sloc). + + declare + New_Id : constant Entity_Id := Defining_Identifier (N); + Next_Temp : constant Entity_Id := Next_Entity (New_Id); + S_Flag : constant Boolean := + Comes_From_Source (Def_Id); + + begin + Set_Next_Entity (New_Id, Next_Entity (Def_Id)); + Set_Next_Entity (Def_Id, Next_Temp); + + Set_Chars (Defining_Identifier (N), Chars (Def_Id)); + Set_Homonym (Defining_Identifier (N), Homonym (Def_Id)); + Set_Ekind (Defining_Identifier (N), Ekind (Def_Id)); + Set_Sloc (Defining_Identifier (N), Sloc (Def_Id)); + + Set_Comes_From_Source (Def_Id, False); + Exchange_Entities (Defining_Identifier (N), Def_Id); + Set_Comes_From_Source (Def_Id, S_Flag); + end; + end; + end if; + + return; + + -- Common case of explicit object initialization + + 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; + + -- Otherwise apply a constraint check now if no prev error + + elsif Nkind (Expr) /= N_Error then + Apply_Constraint_Check (Expr, Typ); + + -- Deal with possible range check + + if Do_Range_Check (Expr) then + + -- If assignment checks are suppressed, turn off flag + + if Suppress_Assignment_Checks (N) then + Set_Do_Range_Check (Expr, False); + + -- Otherwise generate the range check + + else + Generate_Range_Check + (Expr, Typ, CE_Range_Check_Failed); + end if; + end if; + end if; + end if; + + -- If the type is controlled and not inherently limited, then + -- the target is adjusted after the copy and attached to the + -- finalization list. However, no adjustment is done in the case + -- where the object was initialized by a call to a function whose + -- result is built in place, since no copy occurred. Similarly, no + -- adjustment is required if we are going to rewrite the object + -- declaration into a renaming declaration. + + if Needs_Finalization (Typ) + and then not Is_Limited_View (Typ) + and then not Rewrite_As_Renaming + then + Adj_Call := + Make_Adjust_Call ( + Obj_Ref => New_Occurrence_Of (Def_Id, Loc), + Typ => Base_Typ); + + -- Guard against a missing [Deep_]Adjust when the base type + -- was not properly frozen. + + if Present (Adj_Call) then + Insert_Action_After (Init_After, Adj_Call); + end if; + 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 not Tagged_Type_Expansion + -- because tags are represented implicitly in objects. Ditto for + -- types that are CPP_CLASS, and for initializations that are + -- aggregates, because they have to have the right tag. + + -- The re-assignment of the tag has to be done even if the object + -- is a constant. The assignment must be analyzed after the + -- declaration. If an address clause follows, this is handled as + -- part of the freeze actions for the object, otherwise insert + -- tag assignment here. + + Tag_Assign := Make_Tag_Assignment (N); + + if Present (Tag_Assign) then + if Present (Following_Address_Clause (N)) then + Ensure_Freeze_Node (Def_Id); + + else + Insert_Action_After (Init_After, Tag_Assign); + end if; + + -- Handle C++ constructor calls. Note that we do not check that + -- Typ is a tagged type since the equivalent Ada type of a C++ + -- class that has no virtual methods is an untagged limited + -- record type. + + elsif Is_CPP_Constructor_Call (Expr) then + + -- The call to the initialization procedure does NOT freeze the + -- object being initialized. + + Id_Ref := New_Occurrence_Of (Def_Id, Loc); + Set_Must_Not_Freeze (Id_Ref); + Set_Assignment_OK (Id_Ref); + + Insert_Actions_After (Init_After, + Build_Initialization_Call (Loc, Id_Ref, Typ, + Constructor_Ref => Expr)); + + -- We remove here the original call to the constructor + -- to avoid its management in the backend + + Set_Expression (N, Empty); + return; + + -- Handle initialization of limited tagged types + + elsif Is_Tagged_Type (Typ) + and then Is_Class_Wide_Type (Typ) + and then Is_Limited_Record (Typ) + and then not Is_Limited_Interface (Typ) + then + -- Given that the type is limited we cannot perform a copy. If + -- Expr_Q is the reference to a variable we mark the variable + -- as OK_To_Rename to expand this declaration into a renaming + -- declaration (see bellow). + + if Is_Entity_Name (Expr_Q) then + Set_OK_To_Rename (Entity (Expr_Q)); + + -- If we cannot convert the expression into a renaming we must + -- consider it an internal error because the backend does not + -- have support to handle it. + + else + pragma Assert (False); + raise Program_Error; + end if; + + -- For discrete types, set the Is_Known_Valid flag if the + -- initializing value is known to be valid. Only do this for + -- source assignments, since otherwise we can end up turning + -- on the known valid flag prematurely from inserted code. + + elsif Comes_From_Source (N) + and then Is_Discrete_Type (Typ) + and then Expr_Known_Valid (Expr) + then + Set_Is_Known_Valid (Def_Id); + + elsif Is_Access_Type (Typ) then + + -- For access types set the Is_Known_Non_Null flag if the + -- initializing value is known to be non-null. We can also set + -- Can_Never_Be_Null if this is a constant. + + if Known_Non_Null (Expr) then + Set_Is_Known_Non_Null (Def_Id, True); + + if Constant_Present (N) then + Set_Can_Never_Be_Null (Def_Id); + end if; + end if; + end if; + + -- If validity checking on copies, validate initial expression. + -- But skip this if declaration is for a generic type, since it + -- makes no sense to validate generic types. Not clear if this + -- can happen for legal programs, but it definitely can arise + -- from previous instantiation errors. + + if Validity_Checks_On + and then Comes_From_Source (N) + and then Validity_Check_Copies + and then not Is_Generic_Type (Etype (Def_Id)) + then + Ensure_Valid (Expr); + Set_Is_Known_Valid (Def_Id); + end if; + end if; + + -- Cases where the back end cannot handle the initialization + -- directly. In such cases, we expand an assignment that will + -- be appropriately handled by Expand_N_Assignment_Statement. + + -- The exclusion of the unconstrained case is wrong, but for now it + -- is too much trouble ??? + + if (Is_Possibly_Unaligned_Slice (Expr) + or else (Is_Possibly_Unaligned_Object (Expr) + and then not Represented_As_Scalar (Etype (Expr)))) + and then not (Is_Array_Type (Etype (Expr)) + and then not Is_Constrained (Etype (Expr))) + then + declare + Stat : constant Node_Id := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Def_Id, Loc), + Expression => Relocate_Node (Expr)); + begin + Set_Expression (N, Empty); + Set_No_Initialization (N); + Set_Assignment_OK (Name (Stat)); + Set_No_Ctrl_Actions (Stat); + Insert_After_And_Analyze (Init_After, Stat); + end; + end if; + end if; + + if Nkind (Obj_Def) = N_Access_Definition + and then not Is_Local_Anonymous_Access (Etype (Def_Id)) + then + -- An Ada 2012 stand-alone object of an anonymous access type + + declare + Loc : constant Source_Ptr := Sloc (N); + + Level : constant Entity_Id := + Make_Defining_Identifier (Sloc (N), + Chars => + New_External_Name (Chars (Def_Id), Suffix => "L")); + + Level_Expr : Node_Id; + Level_Decl : Node_Id; + + begin + Set_Ekind (Level, Ekind (Def_Id)); + Set_Etype (Level, Standard_Natural); + Set_Scope (Level, Scope (Def_Id)); + + if No (Expr) then + + -- Set accessibility level of null + + Level_Expr := + Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard)); + + else + Level_Expr := Dynamic_Accessibility_Level (Expr); + end if; + + Level_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Level, + Object_Definition => + New_Occurrence_Of (Standard_Natural, Loc), + Expression => Level_Expr, + Constant_Present => Constant_Present (N), + Has_Init_Expression => True); + + Insert_Action_After (Init_After, Level_Decl); + + Set_Extra_Accessibility (Def_Id, Level); + end; + end if; + + -- If the object is default initialized and its type is subject to + -- pragma Default_Initial_Condition, add a runtime check to verify + -- the assumption of the pragma (SPARK RM 7.3.3). Generate: + + -- <Base_Typ>DIC (<Base_Typ> (Def_Id)); + + -- Note that the check is generated for source objects only + + if Comes_From_Source (Def_Id) + and then Has_DIC (Typ) + and then Present (DIC_Procedure (Typ)) + and then not Has_Init_Expression (N) + then + declare + DIC_Call : constant Node_Id := Build_DIC_Call (Loc, Def_Id, Typ); + + begin + if Present (Next_N) then + Insert_Before_And_Analyze (Next_N, DIC_Call); + + -- The object declaration is the last node in a declarative or a + -- statement list. + + else + Append_To (List_Containing (N), DIC_Call); + Analyze (DIC_Call); + end if; + end; + end if; + + -- Final transformation - turn the object declaration into a renaming + -- if appropriate. If this is the completion of a deferred constant + -- declaration, then this transformation generates what would be + -- illegal code if written by hand, but that's OK. + + if Present (Expr) then + if Rewrite_As_Renaming then + Rewrite (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Defining_Identifier (N), + Subtype_Mark => Obj_Def, + Name => Expr_Q)); + + -- We do not analyze this renaming declaration, because all its + -- components have already been analyzed, and if we were to go + -- ahead and analyze it, we would in effect be trying to generate + -- another declaration of X, which won't do. + + Set_Renamed_Object (Defining_Identifier (N), Expr_Q); + Set_Analyzed (N); + + -- We do need to deal with debug issues for this renaming + + -- First, if entity comes from source, then mark it as needing + -- debug information, even though it is defined by a generated + -- renaming that does not come from source. + + if Comes_From_Source (Defining_Identifier (N)) then + Set_Debug_Info_Needed (Defining_Identifier (N)); + end if; + + -- Now call the routine to generate debug info for the renaming + + declare + Decl : constant Node_Id := Debug_Renaming_Declaration (N); + begin + if Present (Decl) then + Insert_Action (N, Decl); + end if; + end; + end if; + end if; + + -- Exception on library entity not available + + exception + when RE_Not_Available => + return; + 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. Also deal with validity checking. + + procedure Expand_N_Subtype_Indication (N : Node_Id) is + Ran : constant Node_Id := Range_Expression (Constraint (N)); + Typ : constant Entity_Id := Entity (Subtype_Mark (N)); + + begin + if Nkind (Constraint (N)) = N_Range_Constraint then + Validity_Check_Range (Range_Expression (Constraint (N))); + end if; + + if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then + Apply_Range_Check (Ran, Typ); + end if; + end Expand_N_Subtype_Indication; + + --------------------------- + -- Expand_N_Variant_Part -- + --------------------------- + + -- Note: this procedure no longer has any effect. It used to be that we + -- would replace the choices in the last variant by a when others, and + -- also expanded static predicates in variant choices here, but both of + -- those activities were being done too early, since we can't check the + -- choices until the statically predicated subtypes are frozen, which can + -- happen as late as the free point of the record, and we can't change the + -- last choice to an others before checking the choices, which is now done + -- at the freeze point of the record. + + procedure Expand_N_Variant_Part (N : Node_Id) is + begin + null; + end Expand_N_Variant_Part; + + --------------------------------- + -- Expand_Previous_Access_Type -- + --------------------------------- + + procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is + Ptr_Typ : Entity_Id; + + begin + -- Find all access types in the current scope whose designated type is + -- Def_Id and build master renamings for them. + + Ptr_Typ := First_Entity (Current_Scope); + while Present (Ptr_Typ) loop + if Is_Access_Type (Ptr_Typ) + and then Designated_Type (Ptr_Typ) = Def_Id + and then No (Master_Id (Ptr_Typ)) + then + -- Ensure that the designated type has a master + + Build_Master_Entity (Def_Id); + + -- Private and incomplete types complicate the insertion of master + -- renamings because the access type may precede the full view of + -- the designated type. For this reason, the master renamings are + -- inserted relative to the designated type. + + Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id)); + end if; + + Next_Entity (Ptr_Typ); + end loop; + end Expand_Previous_Access_Type; + + ----------------------------- + -- Expand_Record_Extension -- + ----------------------------- + + -- Add a field _parent at the beginning of the record extension. This is + -- used to implement inheritance. Here are some examples of expansion: + + -- 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_Record_Extension (T : Entity_Id; Def : Node_Id) is + Indic : constant Node_Id := Subtype_Indication (Def); + Loc : constant Source_Ptr := Sloc (Def); + Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); + 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_Record_Extension is called directly from the semantics, so + -- we must check to see whether expansion is active before proceeding, + -- because this affects the visibility of selected components in bodies + -- of instances. + + 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_Occurrence_Of (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, + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Occurrence_Of (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_Record_Extension; + + ------------------------ + -- 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 => First_Tag_Component (T), + Component_Definition => + Make_Component_Definition (Sloc_N, + Aliased_Present => False, + Subtype_Indication => New_Occurrence_Of (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 (Component_Definition (Comp_Decl))); + + exception + when RE_Not_Available => + return; + end Expand_Tagged_Root; + + ------------------------------ + -- Freeze_Stream_Operations -- + ------------------------------ + + procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is + Names : constant array (1 .. 4) of TSS_Name_Type := + (TSS_Stream_Input, + TSS_Stream_Output, + TSS_Stream_Read, + TSS_Stream_Write); + Stream_Op : Entity_Id; + + begin + -- Primitive operations of tagged types are frozen when the dispatch + -- table is constructed. + + if not Comes_From_Source (Typ) or else Is_Tagged_Type (Typ) then + return; + end if; + + for J in Names'Range loop + Stream_Op := TSS (Typ, Names (J)); + + if Present (Stream_Op) + and then Is_Subprogram (Stream_Op) + and then Nkind (Unit_Declaration_Node (Stream_Op)) = + N_Subprogram_Declaration + and then not Is_Frozen (Stream_Op) + then + Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N)); + end if; + end loop; + end Freeze_Stream_Operations; + + ----------------- + -- 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 Actions field list of the freeze + -- node using Append_Freeze_Actions. + + -- WARNING: This routine manages Ghost regions. Return statements must be + -- replaced by gotos which jump to the end of the routine and restore the + -- Ghost mode. + + function Freeze_Type (N : Node_Id) return Boolean is + procedure Process_RACW_Types (Typ : Entity_Id); + -- Validate and generate stubs for all RACW types associated with type + -- Typ. + + procedure Process_Pending_Access_Types (Typ : Entity_Id); + -- Associate type Typ's Finalize_Address primitive with the finalization + -- masters of pending access-to-Typ types. + + ------------------------ + -- Process_RACW_Types -- + ------------------------ + + procedure Process_RACW_Types (Typ : Entity_Id) is + List : constant Elist_Id := Access_Types_To_Process (N); + E : Elmt_Id; + Seen : Boolean := False; + + begin + if Present (List) then + E := First_Elmt (List); + while Present (E) loop + if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then + Validate_RACW_Primitives (Node (E)); + Seen := True; + end if; + + Next_Elmt (E); + end loop; + end if; + + -- If there are RACWs designating this type, make stubs now + + if Seen then + Remote_Types_Tagged_Full_View_Encountered (Typ); + end if; + end Process_RACW_Types; + + ---------------------------------- + -- Process_Pending_Access_Types -- + ---------------------------------- + + procedure Process_Pending_Access_Types (Typ : Entity_Id) is + E : Elmt_Id; + + begin + -- Finalize_Address is not generated in CodePeer mode because the + -- body contains address arithmetic. This processing is disabled. + + if CodePeer_Mode then + null; + + -- Certain itypes are generated for contexts that cannot allocate + -- objects and should not set primitive Finalize_Address. + + elsif Is_Itype (Typ) + and then Nkind (Associated_Node_For_Itype (Typ)) = + N_Explicit_Dereference + then + null; + + -- When an access type is declared after the incomplete view of a + -- Taft-amendment type, the access type is considered pending in + -- case the full view of the Taft-amendment type is controlled. If + -- this is indeed the case, associate the Finalize_Address routine + -- of the full view with the finalization masters of all pending + -- access types. This scenario applies to anonymous access types as + -- well. + + elsif Needs_Finalization (Typ) + and then Present (Pending_Access_Types (Typ)) + then + E := First_Elmt (Pending_Access_Types (Typ)); + while Present (E) loop + + -- Generate: + -- Set_Finalize_Address + -- (Ptr_Typ, <Typ>FD'Unrestricted_Access); + + Append_Freeze_Action (Typ, + Make_Set_Finalize_Address_Call + (Loc => Sloc (N), + Ptr_Typ => Node (E))); + + Next_Elmt (E); + end loop; + end if; + end Process_Pending_Access_Types; + + -- Local variables + + Def_Id : constant Entity_Id := Entity (N); + + Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; + -- Save the Ghost mode to restore on exit + + Result : Boolean := False; + + -- Start of processing for Freeze_Type + + begin + -- The type being frozen may be subject to pragma Ghost. Set the mode + -- now to ensure that any nodes generated during freezing are properly + -- marked as Ghost. + + Set_Ghost_Mode (Def_Id); + + -- Process any remote access-to-class-wide types designating the type + -- being frozen. + + Process_RACW_Types (Def_Id); + + -- Freeze processing for record types + + if Is_Record_Type (Def_Id) then + if Ekind (Def_Id) = E_Record_Type then + Expand_Freeze_Record_Type (N); + elsif Is_Class_Wide_Type (Def_Id) then + Expand_Freeze_Class_Wide_Type (N); + end if; + + -- Freeze processing for array types + + elsif Is_Array_Type (Def_Id) then + Expand_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_In (Def_Id, E_Access_Type, E_General_Access_Type) then + declare + Loc : constant Source_Ptr := Sloc (N); + Desig_Type : constant Entity_Id := Designated_Type (Def_Id); + + Freeze_Action_Typ : Entity_Id; + Pool_Object : Entity_Id; + + begin + -- Case 1 + + -- Rep Clause "for Def_Id'Storage_Size use 0;" + -- ---> don't use any storage pool + + if No_Pool_Assigned (Def_Id) 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_Align : Node_Id; + DT_Size : 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_Occurrence_Of (Desig_Type, Loc), + Attribute_Name => Name_Max_Size_In_Storage_Elements); + + DT_Align := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (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 access 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 (No (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_Occurrence_Of + (RTE (RE_Stack_Bounded_Pool), Loc), + + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + + -- First discriminant is the Pool Size + + New_Occurrence_Of ( + 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 + + -- When compiling in Ada 2012 mode, ensure that the accessibility + -- level of the subpool access type is not deeper than that of the + -- pool_with_subpools. + + elsif Ada_Version >= Ada_2012 + and then Present (Associated_Storage_Pool (Def_Id)) + + -- Omit this check for the case of a configurable run-time that + -- does not provide package System.Storage_Pools.Subpools. + + and then RTE_Available (RE_Root_Storage_Pool_With_Subpools) + then + declare + Loc : constant Source_Ptr := Sloc (Def_Id); + Pool : constant Entity_Id := + Associated_Storage_Pool (Def_Id); + RSPWS : constant Entity_Id := + RTE (RE_Root_Storage_Pool_With_Subpools); + + begin + -- It is known that the accessibility level of the access + -- type is deeper than that of the pool. + + if Type_Access_Level (Def_Id) > Object_Access_Level (Pool) + and then not Accessibility_Checks_Suppressed (Def_Id) + and then not Accessibility_Checks_Suppressed (Pool) + then + -- Static case: the pool is known to be a descendant of + -- Root_Storage_Pool_With_Subpools. + + if Is_Ancestor (RSPWS, Etype (Pool)) then + Error_Msg_N + ("??subpool access type has deeper accessibility " + & "level than pool", Def_Id); + + Append_Freeze_Action (Def_Id, + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)); + + -- Dynamic case: when the pool is of a class-wide type, + -- it may or may not support subpools depending on the + -- path of derivation. Generate: + + -- if Def_Id in RSPWS'Class then + -- raise Program_Error; + -- end if; + + elsif Is_Class_Wide_Type (Etype (Pool)) then + Append_Freeze_Action (Def_Id, + Make_If_Statement (Loc, + Condition => + Make_In (Loc, + Left_Opnd => New_Occurrence_Of (Pool, Loc), + Right_Opnd => + New_Occurrence_Of + (Class_Wide_Type (RSPWS), Loc)), + + Then_Statements => New_List ( + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)))); + end if; + end if; + end; + 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. Don't 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; + + -- 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. Another exception is if Restrictions + -- (No_Finalization) is active, since then we know nothing is + -- controlled. + + elsif Restriction_Active (No_Finalization) + or else In_Runtime (Def_Id) + then + null; + + -- Create a finalization master for an access-to-controlled type + -- or an access-to-incomplete type. It is assumed that the full + -- view will be controlled. + + elsif Needs_Finalization (Desig_Type) + or else (Is_Incomplete_Type (Desig_Type) + and then No (Full_View (Desig_Type))) + then + Build_Finalization_Master (Def_Id); + + -- Create a finalization master when the designated type contains + -- a private component. It is assumed that the full view will be + -- controlled. + + elsif Has_Private_Component (Desig_Type) then + Build_Finalization_Master + (Typ => Def_Id, + For_Private => True, + Context_Scope => Scope (Def_Id), + Insertion_Node => Declaration_Node (Desig_Type)); + 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 + Expand_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)); + Result := Freeze_Type (N); + Set_Entity (N, Def_Id); + + -- All other types require no expander action. There are such cases + -- (e.g. task types and protected types). In such cases, the freeze + -- nodes are there for use by Gigi. + + end if; + + -- Complete the initialization of all pending access types' finalization + -- masters now that the designated type has been is frozen and primitive + -- Finalize_Address generated. + + Process_Pending_Access_Types (Def_Id); + Freeze_Stream_Operations (N, Def_Id); + + -- Generate the [spec and] body of the procedure tasked with the runtime + -- verification of pragma Default_Initial_Condition's expression. + + if Has_DIC (Def_Id) then + Build_DIC_Procedure_Body (Def_Id, For_Freeze => True); + end if; + + -- Generate the [spec and] body of the invariant procedure tasked with + -- the runtime verification of all invariants that pertain to the type. + -- This includes invariants on the partial and full view, inherited + -- class-wide invariants from parent types or interfaces, and invariants + -- on array elements or record components. + + if Is_Interface (Def_Id) then + + -- Interfaces are treated as the partial view of a private type in + -- order to achieve uniformity with the general case. As a result, an + -- interface receives only a "partial" invariant procedure which is + -- never called. + + if Has_Own_Invariants (Def_Id) then + Build_Invariant_Procedure_Body + (Typ => Def_Id, + Partial_Invariant => Is_Interface (Def_Id)); + end if; + + -- Non-interface types + + -- Do not generate invariant procedure within other assertion + -- subprograms, which may involve local declarations of local + -- subtypes to which these checks do not apply. + + elsif Has_Invariants (Def_Id) then + if Within_Internal_Subprogram + or else (Ekind (Current_Scope) = E_Function + and then Is_Predicate_Function (Current_Scope)) + then + null; + else + Build_Invariant_Procedure_Body (Def_Id); + end if; + end if; + + Restore_Ghost_Mode (Saved_GM); + + return Result; + + exception + when RE_Not_Available => + Restore_Ghost_Mode (Saved_GM); + + return False; + end Freeze_Type; + + ------------------------- + -- Get_Simple_Init_Val -- + ------------------------- + + function Get_Simple_Init_Val + (T : Entity_Id; + N : Node_Id; + Size : Uint := No_Uint) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Val : Node_Id; + Result : Node_Id; + Val_RE : RE_Id; + + Size_To_Use : Uint; + -- This is the size to be used for computation of the appropriate + -- initial value for the Normalize_Scalars and Initialize_Scalars case. + + IV_Attribute : constant Boolean := + Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Invalid_Value; + + Lo_Bound : Uint; + Hi_Bound : Uint; + -- These are the values computed by the procedure Check_Subtype_Bounds + + procedure Check_Subtype_Bounds; + -- This procedure examines the subtype T, and its ancestor subtypes and + -- derived types to determine the best known information about the + -- bounds of the subtype. After the call Lo_Bound is set either to + -- No_Uint if no information can be determined, or to a value which + -- represents a known low bound, i.e. a valid value of the subtype can + -- not be less than this value. Hi_Bound is similarly set to a known + -- high bound (valid value cannot be greater than this). + + -------------------------- + -- Check_Subtype_Bounds -- + -------------------------- + + procedure Check_Subtype_Bounds is + ST1 : Entity_Id; + ST2 : Entity_Id; + Lo : Node_Id; + Hi : Node_Id; + Loval : Uint; + Hival : Uint; + + begin + Lo_Bound := No_Uint; + Hi_Bound := No_Uint; + + -- Loop to climb ancestor subtypes and derived types + + ST1 := T; + loop + if not Is_Discrete_Type (ST1) then + return; + end if; + + Lo := Type_Low_Bound (ST1); + Hi := Type_High_Bound (ST1); + + if Compile_Time_Known_Value (Lo) then + Loval := Expr_Value (Lo); + + if Lo_Bound = No_Uint or else Lo_Bound < Loval then + Lo_Bound := Loval; + end if; + end if; + + if Compile_Time_Known_Value (Hi) then + Hival := Expr_Value (Hi); + + if Hi_Bound = No_Uint or else Hi_Bound > Hival then + Hi_Bound := Hival; + end if; + end if; + + ST2 := Ancestor_Subtype (ST1); + + if No (ST2) then + ST2 := Etype (ST1); + end if; + + exit when ST1 = ST2; + ST1 := ST2; + end loop; + end Check_Subtype_Bounds; + + -- Start of processing for Get_Simple_Init_Val + + begin + -- For a private type, we should always have an underlying type (because + -- this was already checked in Needs_Simple_Initialization). What we do + -- is to get the value for the underlying type and then do an unchecked + -- conversion to the private type. + + if Is_Private_Type (T) then + Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size); + + -- A special case, if the underlying value is null, then qualify it + -- with the underlying type, so that the null is properly typed. + -- Similarly, if it is an aggregate it must be qualified, because an + -- unchecked conversion does not provide a context for it. + + if Nkind_In (Val, N_Null, N_Aggregate) then + Val := + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Underlying_Type (T), Loc), + Expression => Val); + end if; + + Result := Unchecked_Convert_To (T, Val); + + -- Don't truncate result (important for Initialize/Normalize_Scalars) + + if Nkind (Result) = N_Unchecked_Type_Conversion + and then Is_Scalar_Type (Underlying_Type (T)) + then + Set_No_Truncation (Result); + end if; + + return Result; + + -- Scalars with Default_Value aspect. The first subtype may now be + -- private, so retrieve value from underlying type. + + elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then + if Is_Private_Type (First_Subtype (T)) then + return Unchecked_Convert_To (T, + Default_Aspect_Value (Full_View (First_Subtype (T)))); + else + return + Convert_To (T, Default_Aspect_Value (First_Subtype (T))); + end if; + + -- Otherwise, for scalars, we must have normalize/initialize scalars + -- case, or if the node N is an 'Invalid_Value attribute node. + + elsif Is_Scalar_Type (T) then + pragma Assert (Init_Or_Norm_Scalars or IV_Attribute); + + -- Compute size of object. If it is given by the caller, we can use + -- it directly, otherwise we use Esize (T) as an estimate. As far as + -- we know this covers all cases correctly. + + if Size = No_Uint or else Size <= Uint_0 then + Size_To_Use := UI_Max (Uint_1, Esize (T)); + else + Size_To_Use := Size; + end if; + + -- Maximum size to use is 64 bits, since we will create values of + -- type Unsigned_64 and the range must fit this type. + + if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then + Size_To_Use := Uint_64; + end if; + + -- Check known bounds of subtype + + Check_Subtype_Bounds; + + -- Processing for Normalize_Scalars case + + if Normalize_Scalars and then not IV_Attribute then + + -- If zero is invalid, it is a convenient value to use that is + -- for sure an appropriate invalid value in all situations. + + if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then + Val := Make_Integer_Literal (Loc, 0); + + -- Cases where all one bits is the appropriate invalid value + + -- For modular types, all 1 bits is either invalid or valid. If + -- it is valid, then there is nothing that can be done since there + -- are no invalid values (we ruled out zero already). + + -- For signed integer types that have no negative values, either + -- there is room for negative values, or there is not. If there + -- is, then all 1-bits may be interpreted as minus one, which is + -- certainly invalid. Alternatively it is treated as the largest + -- positive value, in which case the observation for modular types + -- still applies. + + -- For float types, all 1-bits is a NaN (not a number), which is + -- certainly an appropriately invalid value. + + elsif Is_Unsigned_Type (T) + or else Is_Floating_Point_Type (T) + or else Is_Enumeration_Type (T) + then + Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1); + + -- Resolve as Unsigned_64, because the largest number we can + -- generate is out of range of universal integer. + + Analyze_And_Resolve (Val, RTE (RE_Unsigned_64)); + + -- Case of signed types + + else + declare + Signed_Size : constant Uint := + UI_Min (Uint_63, Size_To_Use - 1); + + begin + -- Normally we like to use the most negative number. The one + -- exception is when this number is in the known subtype + -- range and the largest positive number is not in the known + -- subtype range. + + -- For this exceptional case, use largest positive value + + if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint + and then Lo_Bound <= (-(2 ** Signed_Size)) + and then Hi_Bound < 2 ** Signed_Size + then + Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1); + + -- Normal case of largest negative value + + else + Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size)); + end if; + end; + end if; + + -- Here for Initialize_Scalars case (or Invalid_Value attribute used) + + else + -- For float types, use float values from System.Scalar_Values + + if Is_Floating_Point_Type (T) then + if Root_Type (T) = Standard_Short_Float then + Val_RE := RE_IS_Isf; + elsif Root_Type (T) = Standard_Float then + Val_RE := RE_IS_Ifl; + elsif Root_Type (T) = Standard_Long_Float then + Val_RE := RE_IS_Ilf; + else pragma Assert (Root_Type (T) = Standard_Long_Long_Float); + Val_RE := RE_IS_Ill; + end if; + + -- If zero is invalid, use zero values from System.Scalar_Values + + elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then + if Size_To_Use <= 8 then + Val_RE := RE_IS_Iz1; + elsif Size_To_Use <= 16 then + Val_RE := RE_IS_Iz2; + elsif Size_To_Use <= 32 then + Val_RE := RE_IS_Iz4; + else + Val_RE := RE_IS_Iz8; + end if; + + -- For unsigned, use unsigned values from System.Scalar_Values + + elsif Is_Unsigned_Type (T) then + if Size_To_Use <= 8 then + Val_RE := RE_IS_Iu1; + elsif Size_To_Use <= 16 then + Val_RE := RE_IS_Iu2; + elsif Size_To_Use <= 32 then + Val_RE := RE_IS_Iu4; + else + Val_RE := RE_IS_Iu8; + end if; + + -- For signed, use signed values from System.Scalar_Values + + else + if Size_To_Use <= 8 then + Val_RE := RE_IS_Is1; + elsif Size_To_Use <= 16 then + Val_RE := RE_IS_Is2; + elsif Size_To_Use <= 32 then + Val_RE := RE_IS_Is4; + else + Val_RE := RE_IS_Is8; + end if; + end if; + + Val := New_Occurrence_Of (RTE (Val_RE), Loc); + end if; + + -- The final expression is obtained by doing an unchecked conversion + -- of this result to the base type of the required subtype. Use the + -- base type to prevent 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); + + -- Ensure result is not truncated, since we want the "bad" bits, and + -- also kill range check on result. + + if Nkind (Result) = N_Unchecked_Type_Conversion then + Set_No_Truncation (Result); + Set_Kill_Range_Check (Result, True); + end if; + + return Result; + + -- String or Wide_[Wide]_String (must have Initialize_Scalars set) + + elsif Is_Standard_String_Type (T) then + pragma Assert (Init_Or_Norm_Scalars); + + return + 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), N, Esize (Root_Type (T)))))); + + -- Access type is initialized to null + + elsif Is_Access_Type (T) then + return Make_Null (Loc); + + -- No other possibilities should arise, since we should only be calling + -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True, + -- indicating one of the above cases held. + + else + raise Program_Error; + end if; + + exception + when RE_Not_Available => + return Empty; + 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; + + ---------------------- + -- Inline_Init_Proc -- + ---------------------- + + function Inline_Init_Proc (Typ : Entity_Id) return Boolean is + begin + -- The initialization proc 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 proc of records that need finalization contains + -- a nested clean-up procedure that makes it impractical to inline as + -- well, except for simple controlled types themselves. And similar + -- considerations apply to task types. + + if Is_Concurrent_Type (Typ) then + return False; + + elsif Needs_Finalization (Typ) and then not Is_Controlled (Typ) then + return False; + + elsif Has_Task (Typ) then + return False; + + else + return True; + end if; + end Inline_Init_Proc; + + ---------------- + -- In_Runtime -- + ---------------- + + function In_Runtime (E : Entity_Id) return Boolean is + S1 : Entity_Id; + + begin + S1 := Scope (E); + while Scope (S1) /= Standard_Standard loop + S1 := Scope (S1); + end loop; + + return Is_RTU (S1, System) or else Is_RTU (S1, Ada); + end In_Runtime; + + ---------------------------- + -- Initialization_Warning -- + ---------------------------- + + procedure Initialization_Warning (E : Entity_Id) is + Warning_Needed : Boolean; + + begin + Warning_Needed := False; + + if Ekind (Current_Scope) = E_Package + and then Static_Elaboration_Desired (Current_Scope) + then + if Is_Type (E) then + if Is_Record_Type (E) then + if Has_Discriminants (E) + or else Is_Limited_Type (E) + or else Has_Non_Standard_Rep (E) + then + Warning_Needed := True; + + else + -- Verify that at least one component has an initialization + -- expression. No need for a warning on a type if all its + -- components have no initialization. + + declare + Comp : Entity_Id; + + begin + Comp := First_Component (E); + while Present (Comp) loop + if Ekind (Comp) = E_Discriminant + or else + (Nkind (Parent (Comp)) = N_Component_Declaration + and then Present (Expression (Parent (Comp)))) + then + Warning_Needed := True; + exit; + end if; + + Next_Component (Comp); + end loop; + end; + end if; + + if Warning_Needed then + Error_Msg_N + ("Objects of the type cannot be initialized statically " + & "by default??", Parent (E)); + end if; + end if; + + else + Error_Msg_N ("Object cannot be initialized statically??", E); + end if; + end if; + end Initialization_Warning; + + ------------------ + -- 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_Occurrence_Of (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_Occurrence_Of (RTE (RE_Master_Id), Loc))); + + -- Add _Chain (not done for sequential elaboration policy, see + -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). + + if Partition_Elaboration_Policy /= 'S' then + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uChain), + In_Present => True, + Out_Present => True, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))); + end if; + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uTask_Name), + In_Present => True, + Parameter_Type => New_Occurrence_Of (Standard_String, Loc))); + end if; + + return Formals; + + exception + when RE_Not_Available => + return Empty_List; + end Init_Formals; + + ------------------------- + -- Init_Secondary_Tags -- + ------------------------- + + procedure Init_Secondary_Tags + (Typ : Entity_Id; + Target : Node_Id; + Init_Tags_List : List_Id; + Stmts_List : List_Id; + Fixed_Comps : Boolean := True; + Variable_Comps : Boolean := True) + is + Loc : constant Source_Ptr := Sloc (Target); + + -- Inherit the C++ tag of the secondary dispatch table of Typ associated + -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. + + procedure Initialize_Tag + (Typ : Entity_Id; + Iface : Entity_Id; + Tag_Comp : Entity_Id; + Iface_Tag : Node_Id); + -- Initialize the tag of the secondary dispatch table of Typ associated + -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. + -- Compiling under the CPP full ABI compatibility mode, if the ancestor + -- of Typ CPP tagged type we generate code to inherit the contents of + -- the dispatch table directly from the ancestor. + + -------------------- + -- Initialize_Tag -- + -------------------- + + procedure Initialize_Tag + (Typ : Entity_Id; + Iface : Entity_Id; + Tag_Comp : Entity_Id; + Iface_Tag : Node_Id) + is + Comp_Typ : Entity_Id; + Offset_To_Top_Comp : Entity_Id := Empty; + + begin + -- Initialize pointer to secondary DT associated with the interface + + if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then + Append_To (Init_Tags_List, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)), + Expression => + New_Occurrence_Of (Iface_Tag, Loc))); + end if; + + Comp_Typ := Scope (Tag_Comp); + + -- Initialize the entries of the table of interfaces. We generate a + -- different call when the parent of the type has variable size + -- components. + + if Comp_Typ /= Etype (Comp_Typ) + and then Is_Variable_Size_Record (Etype (Comp_Typ)) + and then Chars (Tag_Comp) /= Name_uTag + then + pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp))); + + -- Issue error if Set_Dynamic_Offset_To_Top is not available in a + -- configurable run-time environment. + + if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then + Error_Msg_CRT + ("variable size record with interface types", Typ); + return; + end if; + + -- Generate: + -- Set_Dynamic_Offset_To_Top + -- (This => Init, + -- Prim_T => Typ'Tag, + -- Interface_T => Iface'Tag, + -- Offset_Value => n, + -- Offset_Func => Fn'Address) + + Append_To (Stmts_List, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Set_Dynamic_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Target), + Attribute_Name => Name_Address), + + Unchecked_Convert_To (RTE (RE_Tag), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)), + + Unchecked_Convert_To (RTE (RE_Tag), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Iface))), + Loc)), + + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Occurrence_Of (Tag_Comp, Loc)), + Attribute_Name => Name_Position)), + + Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of + (DT_Offset_To_Top_Func (Tag_Comp), Loc), + Attribute_Name => Name_Address))))); + + -- In this case the next component stores the value of the offset + -- to the top. + + Offset_To_Top_Comp := Next_Entity (Tag_Comp); + pragma Assert (Present (Offset_To_Top_Comp)); + + Append_To (Init_Tags_List, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Occurrence_Of (Offset_To_Top_Comp, Loc)), + + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)), + Attribute_Name => Name_Position))); + + -- Normal case: No discriminants in the parent type + + else + -- Don't need to set any value if the offset-to-top field is + -- statically set or if this interface shares the primary + -- dispatch table. + + if not Building_Static_Secondary_DT (Typ) + and then not Is_Ancestor (Iface, Typ, Use_Full_View => True) + then + Append_To (Stmts_List, + Build_Set_Static_Offset_To_Top (Loc, + Iface_Tag => New_Occurrence_Of (Iface_Tag, Loc), + Offset_Value => + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Occurrence_Of (Tag_Comp, Loc)), + Attribute_Name => Name_Position)))); + end if; + + -- Generate: + -- Register_Interface_Offset + -- (Prim_T => Typ'Tag, + -- Interface_T => Iface'Tag, + -- Is_Constant => True, + -- Offset_Value => n, + -- Offset_Func => null); + + if RTE_Available (RE_Register_Interface_Offset) then + Append_To (Stmts_List, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Register_Interface_Offset), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)), + + Unchecked_Convert_To (RTE (RE_Tag), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)), + + New_Occurrence_Of (Standard_True, Loc), + + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Occurrence_Of (Tag_Comp, Loc)), + Attribute_Name => Name_Position)), + + Make_Null (Loc)))); + end if; + end if; + end Initialize_Tag; + + -- Local variables + + Full_Typ : Entity_Id; + Ifaces_List : Elist_Id; + Ifaces_Comp_List : Elist_Id; + Ifaces_Tag_List : Elist_Id; + Iface_Elmt : Elmt_Id; + Iface_Comp_Elmt : Elmt_Id; + Iface_Tag_Elmt : Elmt_Id; + Tag_Comp : Node_Id; + In_Variable_Pos : Boolean; + + -- Start of processing for Init_Secondary_Tags + + begin + -- Handle private types + + if Present (Full_View (Typ)) then + Full_Typ := Full_View (Typ); + else + Full_Typ := Typ; + end if; + + Collect_Interfaces_Info + (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List); + + Iface_Elmt := First_Elmt (Ifaces_List); + Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); + Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List); + while Present (Iface_Elmt) loop + Tag_Comp := Node (Iface_Comp_Elmt); + + -- Check if parent of record type has variable size components + + In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp)) + and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp))); + + -- If we are compiling under the CPP full ABI compatibility mode and + -- the ancestor is a CPP_Pragma tagged type then we generate code to + -- initialize the secondary tag components from tags that reference + -- secondary tables filled with copy of parent slots. + + if Is_CPP_Class (Root_Type (Full_Typ)) then + + -- Reject interface components located at variable offset in + -- C++ derivations. This is currently unsupported. + + if not Fixed_Comps and then In_Variable_Pos then + + -- Locate the first dynamic component of the record. Done to + -- improve the text of the warning. + + declare + Comp : Entity_Id; + Comp_Typ : Entity_Id; + + begin + Comp := First_Entity (Typ); + while Present (Comp) loop + Comp_Typ := Etype (Comp); + + if Ekind (Comp) /= E_Discriminant + and then not Is_Tag (Comp) + then + exit when + (Is_Record_Type (Comp_Typ) + and then + Is_Variable_Size_Record (Base_Type (Comp_Typ))) + or else + (Is_Array_Type (Comp_Typ) + and then Is_Variable_Size_Array (Comp_Typ)); + end if; + + Next_Entity (Comp); + end loop; + + pragma Assert (Present (Comp)); + Error_Msg_Node_2 := Comp; + Error_Msg_NE + ("parent type & with dynamic component & cannot be parent" + & " of 'C'P'P derivation if new interfaces are present", + Typ, Scope (Original_Record_Component (Comp))); + + Error_Msg_Sloc := + Sloc (Scope (Original_Record_Component (Comp))); + Error_Msg_NE + ("type derived from 'C'P'P type & defined #", + Typ, Scope (Original_Record_Component (Comp))); + + -- Avoid duplicated warnings + + exit; + end; + + -- Initialize secondary tags + + else + Append_To (Init_Tags_List, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Occurrence_Of (Node (Iface_Comp_Elmt), Loc)), + Expression => + New_Occurrence_Of (Node (Iface_Tag_Elmt), Loc))); + end if; + + -- Otherwise generate code to initialize the tag + + else + if (In_Variable_Pos and then Variable_Comps) + or else (not In_Variable_Pos and then Fixed_Comps) + then + Initialize_Tag (Full_Typ, + Iface => Node (Iface_Elmt), + Tag_Comp => Tag_Comp, + Iface_Tag => Node (Iface_Tag_Elmt)); + end if; + end if; + + Next_Elmt (Iface_Elmt); + Next_Elmt (Iface_Comp_Elmt); + Next_Elmt (Iface_Tag_Elmt); + end loop; + end Init_Secondary_Tags; + + ------------------------ + -- Is_User_Defined_Eq -- + ------------------------ + + function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is + begin + return Chars (Prim) = Name_Op_Eq + and then Etype (First_Formal (Prim)) = + Etype (Next_Formal (First_Formal (Prim))) + and then Base_Type (Etype (Prim)) = Standard_Boolean; + end Is_User_Defined_Equality; + + ---------------------------------------- + -- Make_Controlling_Function_Wrappers -- + ---------------------------------------- + + procedure Make_Controlling_Function_Wrappers + (Tag_Typ : Entity_Id; + Decl_List : out List_Id; + Body_List : out List_Id) + is + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Prim_Elmt : Elmt_Id; + Subp : Entity_Id; + Actual_List : List_Id; + Formal_List : List_Id; + Formal : Entity_Id; + Par_Formal : Entity_Id; + Formal_Node : Node_Id; + Func_Body : Node_Id; + Func_Decl : Node_Id; + Func_Spec : Node_Id; + Return_Stmt : Node_Id; + + begin + Decl_List := New_List; + Body_List := New_List; + + Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim_Elmt) loop + Subp := Node (Prim_Elmt); + + -- If a primitive function with a controlling result of the type has + -- not been overridden by the user, then we must create a wrapper + -- function here that effectively overrides it and invokes the + -- (non-abstract) parent function. This can only occur for a null + -- extension. Note that functions with anonymous controlling access + -- results don't qualify and must be overridden. We also exclude + -- Input attributes, since each type will have its own version of + -- Input constructed by the expander. The test for Comes_From_Source + -- is needed to distinguish inherited operations from renamings + -- (which also have Alias set). We exclude internal entities with + -- Interface_Alias to avoid generating duplicated wrappers since + -- the primitive which covers the interface is also available in + -- the list of primitive operations. + + -- The function may be abstract, or require_Overriding may be set + -- for it, because tests for null extensions may already have reset + -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not + -- set, functions that need wrappers are recognized by having an + -- alias that returns the parent type. + + if Comes_From_Source (Subp) + or else No (Alias (Subp)) + or else Present (Interface_Alias (Subp)) + or else Ekind (Subp) /= E_Function + or else not Has_Controlling_Result (Subp) + or else Is_Access_Type (Etype (Subp)) + or else Is_Abstract_Subprogram (Alias (Subp)) + or else Is_TSS (Subp, TSS_Stream_Input) + then + goto Next_Prim; + + elsif Is_Abstract_Subprogram (Subp) + or else Requires_Overriding (Subp) + or else + (Is_Null_Extension (Etype (Subp)) + and then Etype (Alias (Subp)) /= Etype (Subp)) + then + Formal_List := No_List; + Formal := First_Formal (Subp); + + if Present (Formal) then + Formal_List := New_List; + + while Present (Formal) loop + Append + (Make_Parameter_Specification + (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal)), + In_Present => In_Present (Parent (Formal)), + Out_Present => Out_Present (Parent (Formal)), + Null_Exclusion_Present => + Null_Exclusion_Present (Parent (Formal)), + Parameter_Type => + New_Occurrence_Of (Etype (Formal), Loc), + Expression => + New_Copy_Tree (Expression (Parent (Formal)))), + Formal_List); + + Next_Formal (Formal); + end loop; + end if; + + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Chars (Subp)), + Parameter_Specifications => Formal_List, + Result_Definition => + New_Occurrence_Of (Etype (Subp), Loc)); + + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + Append_To (Decl_List, Func_Decl); + + -- Build a wrapper body that calls the parent function. The body + -- contains a single return statement that returns an extension + -- aggregate whose ancestor part is a call to the parent function, + -- passing the formals as actuals (with any controlling arguments + -- converted to the types of the corresponding formals of the + -- parent function, which might be anonymous access types), and + -- having a null extension. + + Formal := First_Formal (Subp); + Par_Formal := First_Formal (Alias (Subp)); + Formal_Node := First (Formal_List); + + if Present (Formal) then + Actual_List := New_List; + else + Actual_List := No_List; + end if; + + while Present (Formal) loop + if Is_Controlling_Formal (Formal) then + Append_To (Actual_List, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Par_Formal), Loc), + Expression => + New_Occurrence_Of + (Defining_Identifier (Formal_Node), Loc))); + else + Append_To + (Actual_List, + New_Occurrence_Of + (Defining_Identifier (Formal_Node), Loc)); + end if; + + Next_Formal (Formal); + Next_Formal (Par_Formal); + Next (Formal_Node); + end loop; + + Return_Stmt := + Make_Simple_Return_Statement (Loc, + Expression => + Make_Extension_Aggregate (Loc, + Ancestor_Part => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Alias (Subp), Loc), + Parameter_Associations => Actual_List), + Null_Record_Present => True)); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => New_Copy_Tree (Func_Spec), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Return_Stmt))); + + Set_Defining_Unit_Name + (Specification (Func_Body), + Make_Defining_Identifier (Loc, Chars (Subp))); + + Append_To (Body_List, Func_Body); + + -- Replace the inherited function with the wrapper function in the + -- primitive operations list. We add the minimum decoration needed + -- to override interface primitives. + + Set_Ekind (Defining_Unit_Name (Func_Spec), E_Function); + + Override_Dispatching_Operation + (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec), + Is_Wrapper => True); + end if; + + <<Next_Prim>> + Next_Elmt (Prim_Elmt); + end loop; + end Make_Controlling_Function_Wrappers; + + ------------------- + -- Make_Eq_Body -- + ------------------- + + function Make_Eq_Body + (Typ : Entity_Id; + Eq_Name : Name_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Parent (Typ)); + Decl : Node_Id; + Def : constant Node_Id := Parent (Typ); + Stmts : constant List_Id := New_List; + Variant_Case : Boolean := Has_Discriminants (Typ); + Comps : Node_Id := Empty; + Typ_Def : Node_Id := Type_Definition (Def); + + begin + Decl := + Predef_Spec_Or_Body (Loc, + Tag_Typ => Typ, + Name => Eq_Name, + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => New_Occurrence_Of (Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + + Ret_Type => Standard_Boolean, + For_Body => True); + + 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 (Typ, Discriminant_Specifications (Def))); + Append_List_To (Stmts, Make_Eq_Case (Typ, Comps)); + Append_To (Stmts, + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_True, Loc))); + + else + Append_To (Stmts, + Make_Simple_Return_Statement (Loc, + Expression => + Expand_Record_Equality + (Typ, + Typ => 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)); + return Decl; + end Make_Eq_Body; + + ------------------ + -- 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 + (E : Entity_Id; + CL : Node_Id; + Discrs : Elist_Id := New_Elmt_List) return List_Id + is + Loc : constant Source_Ptr := Sloc (E); + Result : constant List_Id := New_List; + Variant : Node_Id; + Alt_List : List_Id; + + function Corresponding_Formal (C : Node_Id) return Entity_Id; + -- Given the discriminant that controls a given variant of an unchecked + -- union, find the formal of the equality function that carries the + -- inferred value of the discriminant. + + function External_Name (E : Entity_Id) return Name_Id; + -- The value of a given discriminant is conveyed in the corresponding + -- formal parameter of the equality routine. The name of this formal + -- parameter carries a one-character suffix which is removed here. + + -------------------------- + -- Corresponding_Formal -- + -------------------------- + + function Corresponding_Formal (C : Node_Id) return Entity_Id is + Discr : constant Entity_Id := Entity (Name (Variant_Part (C))); + Elm : Elmt_Id; + + begin + Elm := First_Elmt (Discrs); + while Present (Elm) loop + if Chars (Discr) = External_Name (Node (Elm)) then + return Node (Elm); + end if; + + Next_Elmt (Elm); + end loop; + + -- A formal of the proper name must be found + + raise Program_Error; + end Corresponding_Formal; + + ------------------- + -- External_Name -- + ------------------- + + function External_Name (E : Entity_Id) return Name_Id is + begin + Get_Name_String (Chars (E)); + Name_Len := Name_Len - 1; + return Name_Find; + end External_Name; + + -- Start of processing for Make_Eq_Case + + begin + Append_To (Result, Make_Eq_If (E, 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 (E, Component_List (Variant), Discrs))); + Next_Non_Pragma (Variant); + end loop; + + -- If we have an Unchecked_Union, use one of the parameters of the + -- enclosing equality routine that captures the discriminant, to use + -- as the expression in the generated case statement. + + if Is_Unchecked_Union (E) then + Append_To (Result, + Make_Case_Statement (Loc, + Expression => + New_Occurrence_Of (Corresponding_Formal (CL), Loc), + Alternatives => Alt_List)); + + else + Append_To (Result, + Make_Case_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_X), + Selector_Name => New_Copy (Name (Variant_Part (CL)))), + Alternatives => Alt_List)); + end if; + + return Result; + end Make_Eq_Case; + + ---------------- + -- 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 + (E : Entity_Id; + L : List_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (E); + C : Node_Id; + Field_Name : Name_Id; + Cond : Node_Id; + + 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. + -- Ditto for parent interfaces because their equality operator is + -- abstract. + + -- Note also that in the following, we use Make_Identifier for + -- the component names. Use of New_Occurrence_Of 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_uParent + and then Is_Interface (Etype (Defining_Identifier (C))) + then + null; + + elsif 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 (E, + Condition => Cond, + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_False, Loc)))); + end if; + end if; + end Make_Eq_If; + + ------------------- + -- Make_Neq_Body -- + ------------------- + + function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is + + function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean; + -- Returns true if Prim is a renaming of an unresolved predefined + -- inequality operation. + + -------------------------------- + -- Is_Predefined_Neq_Renaming -- + -------------------------------- + + function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is + begin + return Chars (Prim) /= Name_Op_Ne + 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_Ne; + end Is_Predefined_Neq_Renaming; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (Parent (Tag_Typ)); + Stmts : constant List_Id := New_List; + Decl : Node_Id; + Eq_Prim : Entity_Id; + Left_Op : Entity_Id; + Renaming_Prim : Entity_Id; + Right_Op : Entity_Id; + Target : Entity_Id; + + -- Start of processing for Make_Neq_Body + + begin + -- For a call on a renaming of a dispatching subprogram that is + -- overridden, if the overriding occurred before the renaming, then + -- the body executed is that of the overriding declaration, even if the + -- overriding declaration is not visible at the place of the renaming; + -- otherwise, the inherited or predefined subprogram is called, see + -- (RM 8.5.4(8)) + + -- Stage 1: Search for a renaming of the inequality primitive and also + -- search for an overriding of the equality primitive located before the + -- renaming declaration. + + declare + Elmt : Elmt_Id; + Prim : Node_Id; + + begin + Eq_Prim := Empty; + Renaming_Prim := Empty; + + Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + + if Is_User_Defined_Equality (Prim) and then No (Alias (Prim)) then + if No (Renaming_Prim) then + pragma Assert (No (Eq_Prim)); + Eq_Prim := Prim; + end if; + + elsif Is_Predefined_Neq_Renaming (Prim) then + Renaming_Prim := Prim; + end if; + + Next_Elmt (Elmt); + end loop; + end; + + -- No further action needed if no renaming was found + + if No (Renaming_Prim) then + return Empty; + end if; + + -- Stage 2: Replace the renaming declaration by a subprogram declaration + -- (required to add its body) + + Decl := Parent (Parent (Renaming_Prim)); + Rewrite (Decl, + Make_Subprogram_Declaration (Loc, + Specification => Specification (Decl))); + Set_Analyzed (Decl); + + -- Remove the decoration of intrinsic renaming subprogram + + Set_Is_Intrinsic_Subprogram (Renaming_Prim, False); + Set_Convention (Renaming_Prim, Convention_Ada); + Set_Alias (Renaming_Prim, Empty); + Set_Has_Completion (Renaming_Prim, False); + + -- Stage 3: Build the corresponding body + + Left_Op := First_Formal (Renaming_Prim); + Right_Op := Next_Formal (Left_Op); + + Decl := + Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Chars (Renaming_Prim), + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Left_Op)), + Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Right_Op)), + Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), + + Ret_Type => Standard_Boolean, + For_Body => True); + + -- If the overriding of the equality primitive occurred before the + -- renaming, then generate: + + -- function <Neq_Name> (X : Y : Typ) return Boolean is + -- begin + -- return not Oeq (X, Y); + -- end; + + if Present (Eq_Prim) then + Target := Eq_Prim; + + -- Otherwise build a nested subprogram which performs the predefined + -- evaluation of the equality operator. That is, generate: + + -- function <Neq_Name> (X : Y : Typ) return Boolean is + -- function Oeq (X : Y) return Boolean is + -- begin + -- <<body of default implementation>> + -- end; + -- begin + -- return not Oeq (X, Y); + -- end; + + else + declare + Local_Subp : Node_Id; + begin + Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq); + Set_Declarations (Decl, New_List (Local_Subp)); + Target := Defining_Entity (Local_Subp); + end; + end if; + + Append_To (Stmts, + Make_Simple_Return_Statement (Loc, + Expression => + Make_Op_Not (Loc, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Target, Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, Chars (Left_Op)), + Make_Identifier (Loc, Chars (Right_Op))))))); + + Set_Handled_Statement_Sequence + (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + return Decl; + end Make_Neq_Body; + + ------------------------------- + -- Make_Null_Procedure_Specs -- + ------------------------------- + + function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is + Decl_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Formal : Entity_Id; + Formal_List : List_Id; + New_Param_Spec : Node_Id; + Parent_Subp : Entity_Id; + Prim_Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim_Elmt) loop + Subp := Node (Prim_Elmt); + + -- If a null procedure inherited from an interface has not been + -- overridden, then we build a null procedure declaration to + -- override the inherited procedure. + + Parent_Subp := Alias (Subp); + + if Present (Parent_Subp) + and then Is_Null_Interface_Primitive (Parent_Subp) + then + Formal_List := No_List; + Formal := First_Formal (Subp); + + if Present (Formal) then + Formal_List := New_List; + + while Present (Formal) loop + + -- Copy the parameter spec including default expressions + + New_Param_Spec := + New_Copy_Tree (Parent (Formal), New_Sloc => Loc); + + -- Generate a new defining identifier for the new formal. + -- required because New_Copy_Tree does not duplicate + -- semantic fields (except itypes). + + Set_Defining_Identifier (New_Param_Spec, + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal))); + + -- For controlling arguments we must change their + -- parameter type to reference the tagged type (instead + -- of the interface type) + + if Is_Controlling_Formal (Formal) then + if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier + then + Set_Parameter_Type (New_Param_Spec, + New_Occurrence_Of (Tag_Typ, Loc)); + + else pragma Assert + (Nkind (Parameter_Type (Parent (Formal))) = + N_Access_Definition); + Set_Subtype_Mark (Parameter_Type (New_Param_Spec), + New_Occurrence_Of (Tag_Typ, Loc)); + end if; + end if; + + Append (New_Param_Spec, Formal_List); + + Next_Formal (Formal); + end loop; + end if; + + Append_To (Decl_List, + Make_Subprogram_Declaration (Loc, + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars (Subp)), + Parameter_Specifications => Formal_List, + Null_Present => True))); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + return Decl_List; + end Make_Null_Procedure_Specs; + + ------------------------------------- + -- Make_Predefined_Primitive_Specs -- + ------------------------------------- + + procedure Make_Predefined_Primitive_Specs + (Tag_Typ : Entity_Id; + Predef_List : out List_Id; + Renamed_Eq : out Entity_Id) + is + function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean; + -- Returns true if Prim is a renaming of an unresolved predefined + -- equality operation. + + ------------------------------- + -- Is_Predefined_Eq_Renaming -- + ------------------------------- + + 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; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Res : constant List_Id := New_List; + Eq_Name : Name_Id := Name_Op_Eq; + Eq_Needed : Boolean; + Eq_Spec : Node_Id; + Prim : Elmt_Id; + + Has_Predef_Eq_Renaming : Boolean := False; + -- Set to True if Tag_Typ has a primitive that renames the predefined + -- equality operator. Used to implement (RM 8-5-4(8)). + + -- 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_Occurrence_Of (Tag_Typ, Loc))), + + Ret_Type => Standard_Long_Long_Integer)); + + -- Specs for dispatching stream attributes + + declare + Stream_Op_TSS_Names : + constant array (Positive range <>) of TSS_Name_Type := + (TSS_Stream_Read, + TSS_Stream_Write, + TSS_Stream_Input, + TSS_Stream_Output); + + begin + for Op in Stream_Op_TSS_Names'Range loop + if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then + Append_To (Res, + Predef_Stream_Attr_Spec (Loc, Tag_Typ, + Stream_Op_TSS_Names (Op))); + end if; + end loop; + end; + + -- Spec of "=" is 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 + + if not Is_Limited_Type (Tag_Typ) then + 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 + Has_Predef_Eq_Renaming := True; + Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); + + -- User-defined equality + + elsif Is_User_Defined_Equality (Node (Prim)) then + if No (Alias (Node (Prim))) + or else Nkind (Unit_Declaration_Node (Node (Prim))) = + N_Subprogram_Renaming_Declaration + then + Eq_Needed := False; + exit; + + -- If the parent is not an interface type and has an abstract + -- equality function explicitly defined in the sources, then + -- the inherited equality is abstract as well, and no body can + -- be created for it. + + elsif not Is_Interface (Etype (Tag_Typ)) + and then Present (Alias (Node (Prim))) + and then Comes_From_Source (Alias (Node (Prim))) + and then Is_Abstract_Subprogram (Alias (Node (Prim))) + then + Eq_Needed := False; + exit; + + -- If the type has an equality function corresponding with + -- a primitive defined in an interface type, the inherited + -- equality is abstract as well, and no body can be created + -- for it. + + elsif Present (Alias (Node (Prim))) + and then Comes_From_Source (Ultimate_Alias (Node (Prim))) + and then + Is_Interface + (Find_Dispatching_Type (Ultimate_Alias (Node (Prim)))) + then + Eq_Needed := False; + exit; + end if; + 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_Occurrence_Of (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), + Ret_Type => Standard_Boolean); + Append_To (Res, Eq_Spec); + + if Has_Predef_Eq_Renaming 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_Occurrence_Of (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))))); + end if; + + -- Ada 2005: Generate declarations for the following primitive + -- operations for limited interfaces and synchronized types that + -- implement a limited interface. + + -- Disp_Asynchronous_Select + -- Disp_Conditional_Select + -- Disp_Get_Prim_Op_Kind + -- Disp_Get_Task_Id + -- Disp_Requeue + -- Disp_Timed_Select + + -- Disable the generation of these bodies if No_Dispatching_Calls, + -- Ravenscar or ZFP is active. + + if Ada_Version >= Ada_2005 + and then not Restriction_Active (No_Dispatching_Calls) + and then not Restriction_Active (No_Select_Statements) + and then RTE_Available (RE_Select_Specific_Data) + then + -- These primitives are defined abstract in interface types + + if Is_Interface (Tag_Typ) + and then Is_Limited_Record (Tag_Typ) + then + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); + + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Conditional_Select_Spec (Tag_Typ))); + + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); + + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Get_Task_Id_Spec (Tag_Typ))); + + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Requeue_Spec (Tag_Typ))); + + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Timed_Select_Spec (Tag_Typ))); + + -- If ancestor is an interface type, declare non-abstract primitives + -- to override the abstract primitives of the interface type. + + -- In VM targets we define these primitives in all root tagged types + -- that are not interface types. Done because in VM targets we don't + -- have secondary dispatch tables and any derivation of Tag_Typ may + -- cover limited interfaces (which always have these primitives since + -- they may be ancestors of synchronized interface types). + + elsif (not Is_Interface (Tag_Typ) + and then Is_Interface (Etype (Tag_Typ)) + and then Is_Limited_Record (Etype (Tag_Typ))) + or else + (Is_Concurrent_Record_Type (Tag_Typ) + and then Has_Interfaces (Tag_Typ)) + or else + (not Tagged_Type_Expansion + and then not Is_Interface (Tag_Typ) + and then Tag_Typ = Root_Type (Tag_Typ)) + then + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); + + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Conditional_Select_Spec (Tag_Typ))); + + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); + + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Get_Task_Id_Spec (Tag_Typ))); + + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Requeue_Spec (Tag_Typ))); + + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Timed_Select_Spec (Tag_Typ))); + end if; + end if; + + -- All tagged types receive their own Deep_Adjust and Deep_Finalize + -- regardless of whether they are controlled or may contain controlled + -- components. + + -- Do not generate the routines if finalization is disabled + + if Restriction_Active (No_Finalization) then + null; + + else + if not Is_Limited_Type (Tag_Typ) then + Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust)); + end if; + + Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize)); + end if; + + Predef_List := Res; + end Make_Predefined_Primitive_Specs; + + ------------------------- + -- Make_Tag_Assignment -- + ------------------------- + + function Make_Tag_Assignment (N : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Def_If : constant Entity_Id := Defining_Identifier (N); + Expr : constant Node_Id := Expression (N); + Typ : constant Entity_Id := Etype (Def_If); + Full_Typ : constant Entity_Id := Underlying_Type (Typ); + New_Ref : Node_Id; + + begin + -- This expansion activity is called during analysis, but cannot + -- be applied in ASIS mode when other expansion is disabled. + + if Is_Tagged_Type (Typ) + and then not Is_Class_Wide_Type (Typ) + and then not Is_CPP_Class (Typ) + and then Tagged_Type_Expansion + and then Nkind (Expr) /= N_Aggregate + and then not ASIS_Mode + and then (Nkind (Expr) /= N_Qualified_Expression + or else Nkind (Expression (Expr)) /= N_Aggregate) + then + New_Ref := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Def_If, Loc), + Selector_Name => + New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc)); + Set_Assignment_OK (New_Ref); + + return + Make_Assignment_Statement (Loc, + Name => New_Ref, + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Occurrence_Of (Node + (First_Elmt (Access_Disp_Table (Full_Typ))), Loc))); + else + return Empty; + end if; + end Make_Tag_Assignment; + + --------------------------------- + -- Needs_Simple_Initialization -- + --------------------------------- + + function Needs_Simple_Initialization + (T : Entity_Id; + Consider_IS : Boolean := True) return Boolean + is + Consider_IS_NS : constant Boolean := + Normalize_Scalars or (Initialize_Scalars and Consider_IS); + + begin + -- Never need initialization if it is suppressed + + if Initialization_Suppressed (T) then + return False; + end if; + + -- Check for private type, in which case test applies to the underlying + -- type of the private type. + + if 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; + + -- Scalar type with Default_Value aspect requires initialization + + elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then + return True; + + -- Cases needing simple initialization are access types, and, if pragma + -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar + -- types. + + elsif Is_Access_Type (T) + or else (Consider_IS_NS and then (Is_Scalar_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 Consider_IS_NS + and then Is_Standard_String_Type (T) + and then + (not Is_Itype (T) + or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate) + then + return True; + + else + return False; + end if; + end Needs_Simple_Initialization; + + ---------------------- + -- Predef_Deep_Spec -- + ---------------------- + + function Predef_Deep_Spec + (Loc : Source_Ptr; + Tag_Typ : Entity_Id; + Name : TSS_Name_Type; + For_Body : Boolean := False) return Node_Id + is + Formals : List_Id; + + begin + -- V : in out Tag_Typ + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + In_Present => True, + Out_Present => True, + Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))); + + -- F : Boolean := True + + if Name = TSS_Deep_Adjust + or else Name = TSS_Deep_Finalize + then + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_F), + Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), + Expression => New_Occurrence_Of (Standard_True, Loc))); + end if; + + return + Predef_Spec_Or_Body (Loc, + Name => Make_TSS_Name (Tag_Typ, Name), + Tag_Typ => Tag_Typ, + Profile => Formals, + For_Body => For_Body); + + exception + when RE_Not_Available => + return Empty; + 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 : constant 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). Second, 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, + Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); + end if; + + if Is_Interface (Tag_Typ) then + return Make_Abstract_Subprogram_Declaration (Loc, Spec); + + -- 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. + + elsif For_Body then + return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty); + + -- For the case of an Input attribute predefined for an abstract type, + -- generate an abstract specification. This will never be called, but we + -- need the slot allocated in the dispatching table so that attributes + -- typ'Class'Input and typ'Class'Output will work properly. + + elsif Is_TSS (Name, TSS_Stream_Input) + and then Is_Abstract_Type (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 : TSS_Name_Type; + For_Body : Boolean := False) return Node_Id + is + Ret_Type : Entity_Id; + + begin + if Name = TSS_Stream_Input then + Ret_Type := Tag_Typ; + else + Ret_Type := Empty; + end if; + + return + Predef_Spec_Or_Body + (Loc, + Name => Make_TSS_Name (Tag_Typ, 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 : Entity_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Res : constant List_Id := New_List; + Adj_Call : Node_Id; + Decl : Node_Id; + Fin_Call : Node_Id; + Prim : Elmt_Id; + Eq_Needed : Boolean; + Eq_Name : Name_Id; + Ent : Entity_Id; + + pragma Warnings (Off, Ent); + + begin + pragma Assert (not Is_Interface (Tag_Typ)); + + -- See if we have a predefined "=" operator + + if Present (Renamed_Eq) then + Eq_Needed := True; + Eq_Name := Chars (Renamed_Eq); + + -- If the parent is an interface type then it has defined all the + -- predefined primitives abstract and we need to check if the type + -- has some user defined "=" function which matches the profile of + -- the Ada predefined equality operator to avoid generating it. + + elsif Is_Interface (Etype (Tag_Typ)) then + Eq_Needed := True; + Eq_Name := Name_Op_Eq; + + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + if Chars (Node (Prim)) = Name_Op_Eq + and then not Is_Internal (Node (Prim)) + and then Present (First_Entity (Node (Prim))) + + -- The predefined equality primitive must have exactly two + -- formals whose type is this tagged type + + and then Present (Last_Entity (Node (Prim))) + and then Next_Entity (First_Entity (Node (Prim))) + = Last_Entity (Node (Prim)) + and then Etype (First_Entity (Node (Prim))) = Tag_Typ + and then Etype (Last_Entity (Node (Prim))) = Tag_Typ + then + Eq_Needed := False; + Eq_Name := No_Name; + exit; + end if; + + Next_Elmt (Prim); + end loop; + + 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; + exit; + 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_Occurrence_Of (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_Simple_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). + -- We also skip them if dispatching or finalization are not available + -- or if stream operations are prohibited by restriction No_Streams or + -- from use of pragma/aspect No_Tagged_Streams. + + if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read) + and then No (TSS (Tag_Typ, TSS_Stream_Read)) + then + Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + + if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write) + and then No (TSS (Tag_Typ, TSS_Stream_Write)) + then + Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + + -- Skip body of _Input for the abstract case, since the corresponding + -- spec is abstract (see Predef_Spec_Or_Body). + + if not Is_Abstract_Type (Tag_Typ) + and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input) + and then No (TSS (Tag_Typ, TSS_Stream_Input)) + then + Build_Record_Or_Elementary_Input_Function + (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + + if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output) + and then No (TSS (Tag_Typ, TSS_Stream_Output)) + then + Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent); + Append_To (Res, Decl); + end if; + + -- Ada 2005: Generate bodies for the following primitive operations for + -- limited interfaces and synchronized types that implement a limited + -- interface. + + -- disp_asynchronous_select + -- disp_conditional_select + -- disp_get_prim_op_kind + -- disp_get_task_id + -- disp_timed_select + + -- The interface versions will have null bodies + + -- Disable the generation of these bodies if No_Dispatching_Calls, + -- Ravenscar or ZFP is active. + + -- In VM targets we define these primitives in all root tagged types + -- that are not interface types. Done because in VM targets we don't + -- have secondary dispatch tables and any derivation of Tag_Typ may + -- cover limited interfaces (which always have these primitives since + -- they may be ancestors of synchronized interface types). + + if Ada_Version >= Ada_2005 + and then not Is_Interface (Tag_Typ) + and then + ((Is_Interface (Etype (Tag_Typ)) + and then Is_Limited_Record (Etype (Tag_Typ))) + or else + (Is_Concurrent_Record_Type (Tag_Typ) + and then Has_Interfaces (Tag_Typ)) + or else + (not Tagged_Type_Expansion + and then Tag_Typ = Root_Type (Tag_Typ))) + and then not Restriction_Active (No_Dispatching_Calls) + and then not Restriction_Active (No_Select_Statements) + and then RTE_Available (RE_Select_Specific_Data) + then + Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Requeue_Body (Tag_Typ)); + Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ)); + end if; + + if not Is_Limited_Type (Tag_Typ) and then not Is_Interface (Tag_Typ) then + + -- Body for equality + + if Eq_Needed then + Decl := Make_Eq_Body (Tag_Typ, Eq_Name); + Append_To (Res, Decl); + end if; + + -- Body for inequality (if required) + + Decl := Make_Neq_Body (Tag_Typ); + + if Present (Decl) then + 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_Occurrence_Of (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), + Parameter_Type => New_Occurrence_Of (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 empty bodies of routines Deep_Adjust and Deep_Finalize for + -- tagged types which do not contain controlled components. + + -- Do not generate the routines if finalization is disabled + + if Restriction_Active (No_Finalization) then + null; + + elsif not Has_Controlled_Component (Tag_Typ) then + if not Is_Limited_Type (Tag_Typ) then + Adj_Call := Empty; + Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True); + + if Is_Controlled (Tag_Typ) then + Adj_Call := + Make_Adjust_Call ( + Obj_Ref => Make_Identifier (Loc, Name_V), + Typ => Tag_Typ); + end if; + + if No (Adj_Call) then + Adj_Call := Make_Null_Statement (Loc); + end if; + + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Adj_Call))); + + Append_To (Res, Decl); + end if; + + Fin_Call := Empty; + Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True); + + if Is_Controlled (Tag_Typ) then + Fin_Call := + Make_Final_Call + (Obj_Ref => Make_Identifier (Loc, Name_V), + Typ => Tag_Typ); + end if; + + if No (Fin_Call) then + Fin_Call := Make_Null_Statement (Loc); + end if; + + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Fin_Call))); + + 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 + Res : constant List_Id := New_List; + Prim : Elmt_Id; + Frnodes : List_Id; + + begin + Prim := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim) loop + if Is_Predefined_Dispatching_Operation (Node (Prim)) then + Frnodes := Freeze_Entity (Node (Prim), Tag_Typ); + + if Present (Frnodes) then + Append_List_To (Res, Frnodes); + end if; + end if; + + Next_Elmt (Prim); + end loop; + + return Res; + end Predefined_Primitive_Freeze; + + ------------------------- + -- Stream_Operation_OK -- + ------------------------- + + function Stream_Operation_OK + (Typ : Entity_Id; + Operation : TSS_Name_Type) return Boolean + is + Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False; + + begin + -- Special case of a limited type extension: a default implementation + -- of the stream attributes Read or Write exists if that attribute + -- has been specified or is available for an ancestor type; a default + -- implementation of the attribute Output (resp. Input) exists if the + -- attribute has been specified or Write (resp. Read) is available for + -- an ancestor type. The last condition only applies under Ada 2005. + + if Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ) then + if Operation = TSS_Stream_Read then + Has_Predefined_Or_Specified_Stream_Attribute := + Has_Specified_Stream_Read (Typ); + + elsif Operation = TSS_Stream_Write then + Has_Predefined_Or_Specified_Stream_Attribute := + Has_Specified_Stream_Write (Typ); + + elsif Operation = TSS_Stream_Input then + Has_Predefined_Or_Specified_Stream_Attribute := + Has_Specified_Stream_Input (Typ) + or else + (Ada_Version >= Ada_2005 + and then Stream_Operation_OK (Typ, TSS_Stream_Read)); + + elsif Operation = TSS_Stream_Output then + Has_Predefined_Or_Specified_Stream_Attribute := + Has_Specified_Stream_Output (Typ) + or else + (Ada_Version >= Ada_2005 + and then Stream_Operation_OK (Typ, TSS_Stream_Write)); + end if; + + -- Case of inherited TSS_Stream_Read or TSS_Stream_Write + + if not Has_Predefined_Or_Specified_Stream_Attribute + and then Is_Derived_Type (Typ) + and then (Operation = TSS_Stream_Read + or else Operation = TSS_Stream_Write) + then + Has_Predefined_Or_Specified_Stream_Attribute := + Present + (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation)); + end if; + end if; + + -- If the type is not limited, or else is limited but the attribute is + -- explicitly specified or is predefined for the type, then return True, + -- unless other conditions prevail, such as restrictions prohibiting + -- streams or dispatching operations. We also return True for limited + -- interfaces, because they may be extended by nonlimited types and + -- permit inheritance in this case (addresses cases where an abstract + -- extension doesn't get 'Input declared, as per comments below, but + -- 'Class'Input must still be allowed). Note that attempts to apply + -- stream attributes to a limited interface or its class-wide type + -- (or limited extensions thereof) will still get properly rejected + -- by Check_Stream_Attribute. + + -- We exclude the Input operation from being a predefined subprogram in + -- the case where the associated type is an abstract extension, because + -- the attribute is not callable in that case, per 13.13.2(49/2). Also, + -- we don't want an abstract version created because types derived from + -- the abstract type may not even have Input available (for example if + -- derived from a private view of the abstract type that doesn't have + -- a visible Input). + + -- Do not generate stream routines for type Finalization_Master because + -- a master may never appear in types and therefore cannot be read or + -- written. + + return + (not Is_Limited_Type (Typ) + or else Is_Interface (Typ) + or else Has_Predefined_Or_Specified_Stream_Attribute) + and then + (Operation /= TSS_Stream_Input + or else not Is_Abstract_Type (Typ) + or else not Is_Derived_Type (Typ)) + and then not Has_Unknown_Discriminants (Typ) + and then not + (Is_Interface (Typ) + and then + (Is_Task_Interface (Typ) + or else Is_Protected_Interface (Typ) + or else Is_Synchronized_Interface (Typ))) + and then not Restriction_Active (No_Streams) + and then not Restriction_Active (No_Dispatch) + and then No (No_Tagged_Streams_Pragma (Typ)) + and then not No_Run_Time_Mode + and then RTE_Available (RE_Tag) + and then No (Type_Without_Stream_Operation (Typ)) + and then RTE_Available (RE_Root_Stream_Type) + and then not Is_RTE (Typ, RE_Finalization_Master); + end Stream_Operation_OK; + +end Exp_Ch3;