| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ C H 3 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2019, 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 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_Null_Statement_List (Stmts : List_Id) return Boolean; |
| -- Returns true if Stmts is made of null statements only, possibly wrapped |
| -- in a case statement, recursively. This latter pattern may occur for the |
| -- initialization procedure of an unchecked union. |
| |
| 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 |
| (Typ => 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; |
| Parameters : List_Id; |
| 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 |
| (Typ => Comp_Type, |
| N => Nod, |
| Size => Component_Size (A_Type)))); |
| |
| else |
| Clean_Task_Names (Comp_Type, Proc_Id); |
| return |
| Build_Initialization_Call |
| (Loc => Loc, |
| Id_Ref => Comp, |
| Typ => 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); |
| Parameters := Init_Formals (A_Type); |
| |
| Discard_Node ( |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Proc_Id, |
| Parameter_Specifications => Parameters), |
| 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. Kill also warnings for the _Init |
| -- out parameter, which is left entirely uninitialized. |
| |
| Set_Init_Proc (A_Type, Proc_Id); |
| |
| if Is_Null_Statement_List (Body_Stmts) then |
| Set_Is_Null_Init_Proc (Proc_Id); |
| Set_Warnings_Off (Defining_Identifier (First (Parameters))); |
| |
| 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; |
| |
| -- Handle the optionally generated formal *_skip_null_excluding_checks |
| |
| if Needs_Conditional_Null_Excluding_Check (Full_Init_Type) then |
| |
| -- Look at the associated node for the object we are referencing |
| -- and verify that we are expanding a call to an Init_Proc for an |
| -- internally generated object declaration before passing True and |
| -- skipping the relevant checks. |
| |
| if Nkind (Id_Ref) in N_Has_Entity |
| and then Comes_From_Source (Associated_Node (Id_Ref)) |
| then |
| Append_To (Args, New_Occurrence_Of (Standard_True, Loc)); |
| |
| -- Otherwise, we pass False to perform null-excluding checks |
| |
| else |
| Append_To (Args, New_Occurrence_Of (Standard_False, Loc)); |
| end if; |
| 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_Op_Minus (Loc, |
| 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; |
| Elab_List : 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); |
| |
| Elab_List := New_List ( |
| Make_If_Statement (Loc, |
| Condition => New_Occurrence_Of (Set_Tag, Loc), |
| Then_Statements => Init_Tags_List)); |
| |
| if Elab_Flag_Needed (Rec_Type) then |
| 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))); |
| |
| Append_To (Elab_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 if; |
| |
| Prepend_List_To (Body_Stmts, Elab_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_Call : Node_Id; |
| 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)); |
| |
| DF_Call := |
| 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))); |
| |
| -- Do not emit warnings related to the elaboration order when a |
| -- controlled object is declared before the body of Finalize is |
| -- seen. |
| |
| if Legacy_Elaboration_Checks then |
| Set_No_Elaboration_Check (DF_Call); |
| end if; |
| |
| Set_Exception_Handlers (Handled_Stmt_Node, New_List ( |
| Make_Exception_Handler (Loc, |
| Exception_Choices => New_List ( |
| Make_Others_Choice (Loc)), |
| Statements => New_List ( |
| DF_Call, |
| 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. Kill also warnings for the _Init |
| -- out parameter, which is left entirely uninitialized. |
| |
| Set_Init_Proc (Rec_Type, Proc_Id); |
| |
| if Is_Null_Statement_List (Body_Stmts) then |
| Set_Is_Null_Init_Proc (Proc_Id); |
| Set_Warnings_Off (Defining_Identifier (First (Parameters))); |
| 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 => Id, |
| Default => |
| Get_Simple_Init_Val |
| (Typ => Typ, |
| N => N, |
| Size => 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 => Id, |
| Default => |
| Get_Simple_Init_Val |
| (Typ => Typ, |
| N => N, |
| Size => 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 Present (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 -- |
| |