| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ C H 3 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 2, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING. If not, write -- |
| -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- |
| -- Boston, MA 02110-1301, USA. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Atree; use Atree; |
| with Checks; use Checks; |
| with Einfo; use Einfo; |
| with Errout; use Errout; |
| with Exp_Aggr; use Exp_Aggr; |
| with Exp_Ch4; use Exp_Ch4; |
| with Exp_Ch7; use Exp_Ch7; |
| with Exp_Ch9; use Exp_Ch9; |
| with Exp_Ch11; use Exp_Ch11; |
| with Exp_Disp; use Exp_Disp; |
| with Exp_Dist; use Exp_Dist; |
| with Exp_Smem; use Exp_Smem; |
| with Exp_Strm; use Exp_Strm; |
| with Exp_Tss; use Exp_Tss; |
| with Exp_Util; use Exp_Util; |
| with Freeze; use Freeze; |
| with Hostparm; use Hostparm; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Opt; use Opt; |
| with Restrict; use Restrict; |
| with Rident; use Rident; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_Attr; use Sem_Attr; |
| with Sem_Ch3; use Sem_Ch3; |
| with Sem_Ch8; use Sem_Ch8; |
| with Sem_Disp; use Sem_Disp; |
| with Sem_Eval; use Sem_Eval; |
| with Sem_Mech; use Sem_Mech; |
| with Sem_Res; use Sem_Res; |
| with Sem_Util; use Sem_Util; |
| with Sinfo; use Sinfo; |
| with Stand; use Stand; |
| with Snames; use Snames; |
| with Tbuild; use Tbuild; |
| with Ttypes; use Ttypes; |
| with 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 the following function. If the flag Use_Dl |
| -- is set, the list is built using the already defined discriminals |
| -- of the type. Otherwise new identifiers are created, with the source |
| -- names of the discriminants. |
| |
| procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id); |
| -- If the designated type of an access type is a task type or contains |
| -- tasks, we make sure that a _Master variable is declared in the current |
| -- scope, and then declare a renaming for it: |
| -- |
| -- atypeM : Master_Id renames _Master; |
| -- |
| -- where atyp is the name of the access type. This declaration is |
| -- used when an allocator for the access type is expanded. The node N |
| -- is the full declaration of the designated type that contains tasks. |
| -- The renaming declaration is inserted before N, and after the Master |
| -- declaration. |
| |
| procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id); |
| -- Build record initialization procedure. N is the type declaration |
| -- node, and Pe is the corresponding entity for the record type. |
| |
| procedure Build_Slice_Assignment (Typ : Entity_Id); |
| -- Build assignment procedure for one-dimensional arrays of controlled |
| -- types. Other array and slice assignments are expanded in-line, but |
| -- the code expansion for controlled components (when control actions |
| -- are active) can lead to very large blocks that GCC3 handles poorly. |
| |
| procedure Build_Variant_Record_Equality (Typ : Entity_Id); |
| -- Create An Equality function for the non-tagged variant record 'Typ' |
| -- and attach it to the TSS list |
| |
| procedure Check_Stream_Attributes (Typ : Entity_Id); |
| -- Check that if a limited extension has a parent with user-defined |
| -- stream attributes, and does not itself have user-definer |
| -- stream-attributes, then any limited component of the extension also |
| -- has the corresponding user-defined stream attributes. |
| |
| procedure Expand_Tagged_Root (T : Entity_Id); |
| -- Add a field _Tag at the beginning of the record. This field carries |
| -- the value of the access to the Dispatch table. This procedure is only |
| -- called on root (non CPP_Class) types, the _Tag field being inherited |
| -- by the descendants. |
| |
| procedure Expand_Record_Controller (T : Entity_Id); |
| -- T must be a record type that Has_Controlled_Component. Add a field |
| -- _controller of type Record_Controller or Limited_Record_Controller |
| -- in the record T. |
| |
| procedure Freeze_Array_Type (N : Node_Id); |
| -- Freeze an array type. Deals with building the initialization procedure, |
| -- creating the packed array type for a packed array and also with the |
| -- creation of the controlling procedures for the controlled case. The |
| -- argument N is the N_Freeze_Entity node for the type. |
| |
| procedure Freeze_Enumeration_Type (N : Node_Id); |
| -- Freeze enumeration type with non-standard representation. Builds the |
| -- array and function needed to convert between enumeration pos and |
| -- enumeration representation values. N is the N_Freeze_Entity node |
| -- for the type. |
| |
| procedure Freeze_Record_Type (N : Node_Id); |
| -- Freeze record type. Builds all necessary discriminant checking |
| -- and other ancillary functions, and builds dispatch tables where |
| -- needed. The argument N is the N_Freeze_Entity node. This processing |
| -- applies only to E_Record_Type entities, not to class wide types, |
| -- record subtypes, or private types. |
| |
| 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. |
| |
| 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 In_Runtime (E : Entity_Id) return Boolean; |
| -- Check if E is defined in the RTL (in a child of Ada or System). Used |
| -- to avoid to bring in the overhead of _Input, _Output for tagged types. |
| |
| function Make_Eq_Case |
| (E : Entity_Id; |
| CL : Node_Id; |
| Discr : Entity_Id := Empty) return List_Id; |
| -- Building block for variant record equality. Defined to share the |
| -- code between the tagged and non-tagged case. Given a Component_List |
| -- node CL, it generates an 'if' followed by a 'case' statement that |
| -- compares all components of local temporaries named X and Y (that |
| -- are declared as formals at some upper level). E provides the Sloc to be |
| -- used for the generated code. Discr is used as the case statement switch |
| -- in the case of Unchecked_Union equality. |
| |
| function Make_Eq_If |
| (E : Entity_Id; |
| L : List_Id) return Node_Id; |
| -- Building block for variant record equality. Defined to share the |
| -- code between the tagged and non-tagged case. Given the list of |
| -- components (or discriminants) L, it generates a return statement |
| -- that compares all components of local temporaries named X and Y |
| -- (that are declared as formals at some upper level). E provides the Sloc |
| -- to be used for the generated code. |
| |
| procedure Make_Predefined_Primitive_Specs |
| (Tag_Typ : Entity_Id; |
| Predef_List : out List_Id; |
| Renamed_Eq : out Node_Id); |
| -- Create a list with the specs of the predefined primitive operations. |
| -- 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. |
| -- |
| -- _alignment provides result of 'Alignment attribute |
| -- _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 adust |
| -- |
| -- 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 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 : Node_Id) return List_Id; |
| -- Create the bodies of the predefined primitives that are described in |
| -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote |
| -- the defining unit name of the type's predefined equality as returned |
| -- by Make_Predefined_Primitive_Specs. |
| |
| function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id; |
| -- Freeze entities of all predefined primitive operations. This is needed |
| -- because the bodies of these operations do not normally do any freezeing. |
| |
| function Stream_Operation_OK |
| (Typ : Entity_Id; |
| Operation : TSS_Name_Type) return Boolean; |
| -- Check whether the named stream operation must be emitted for a given |
| -- type. The rules for inheritance of stream attributes by type extensions |
| -- are enforced by this function. Furthermore, various restrictions prevent |
| -- the generation of these operations, as a useful optimization or for |
| -- certification purposes. |
| |
| -------------------------- |
| -- Adjust_Discriminants -- |
| -------------------------- |
| |
| -- This procedure attempts to define subtypes for discriminants that |
| -- are more restrictive than those declared. Such a replacement is |
| -- possible if we can demonstrate that values outside the restricted |
| -- range would cause constraint errors in any case. The advantage of |
| -- restricting the discriminant types in this way is tha the maximum |
| -- size of the variant record can be calculated more conservatively. |
| |
| -- An example of a situation in which we can perform this type of |
| -- restriction is the following: |
| |
| -- subtype B is range 1 .. 10; |
| -- type Q is array (B range <>) of Integer; |
| |
| -- type V (N : Natural) is record |
| -- C : Q (1 .. N); |
| -- end record; |
| |
| -- In this situation, we can restrict the upper bound of N to 10, since |
| -- any larger value would cause a constraint error in any case. |
| |
| -- There are many situations in which such restriction is possible, but |
| -- for now, we just look for cases like the above, where the component |
| -- in question is a one dimensional array whose upper bound is one of |
| -- the record discriminants. Also the component must not be part of |
| -- any variant part, since then the component does not always exist. |
| |
| procedure Adjust_Discriminants (Rtype : Entity_Id) is |
| Loc : constant Source_Ptr := Sloc (Rtype); |
| Comp : Entity_Id; |
| Ctyp : Entity_Id; |
| Ityp : Entity_Id; |
| Lo : Node_Id; |
| Hi : Node_Id; |
| P : Node_Id; |
| Loval : Uint; |
| Discr : Entity_Id; |
| Dtyp : Entity_Id; |
| Dhi : Node_Id; |
| Dhiv : Uint; |
| Ahi : Node_Id; |
| Ahiv : Uint; |
| Tnn : Entity_Id; |
| |
| begin |
| Comp := First_Component (Rtype); |
| while Present (Comp) loop |
| |
| -- If our parent is a variant, quit, we do not look at components |
| -- that are in variant parts, because they may not always exist. |
| |
| P := Parent (Comp); -- component declaration |
| P := Parent (P); -- component list |
| |
| exit when Nkind (Parent (P)) = N_Variant; |
| |
| -- We are looking for a one dimensional array type |
| |
| Ctyp := Etype (Comp); |
| |
| if not Is_Array_Type (Ctyp) |
| or else Number_Dimensions (Ctyp) > 1 |
| then |
| goto Continue; |
| end if; |
| |
| -- The lower bound must be constant, and the upper bound is a |
| -- discriminant (which is a discriminant of the current record). |
| |
| Ityp := Etype (First_Index (Ctyp)); |
| Lo := Type_Low_Bound (Ityp); |
| Hi := Type_High_Bound (Ityp); |
| |
| if not Compile_Time_Known_Value (Lo) |
| or else Nkind (Hi) /= N_Identifier |
| or else No (Entity (Hi)) |
| or else Ekind (Entity (Hi)) /= E_Discriminant |
| then |
| goto Continue; |
| end if; |
| |
| -- We have an array with appropriate bounds |
| |
| Loval := Expr_Value (Lo); |
| Discr := Entity (Hi); |
| Dtyp := Etype (Discr); |
| |
| -- See if the discriminant has a known upper bound |
| |
| Dhi := Type_High_Bound (Dtyp); |
| |
| if not Compile_Time_Known_Value (Dhi) then |
| goto Continue; |
| end if; |
| |
| Dhiv := Expr_Value (Dhi); |
| |
| -- See if base type of component array has known upper bound |
| |
| Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp)))); |
| |
| if not Compile_Time_Known_Value (Ahi) then |
| goto Continue; |
| end if; |
| |
| Ahiv := Expr_Value (Ahi); |
| |
| -- The condition for doing the restriction is that the high bound |
| -- of the discriminant is greater than the low bound of the array, |
| -- and is also greater than the high bound of the base type index. |
| |
| if Dhiv > Loval and then Dhiv > Ahiv then |
| |
| -- We can reset the upper bound of the discriminant type to |
| -- whichever is larger, the low bound of the component, or |
| -- the high bound of the base type array index. |
| |
| -- We build a subtype that is declared as |
| |
| -- subtype Tnn is discr_type range discr_type'First .. max; |
| |
| -- And insert this declaration into the tree. The type of the |
| -- discriminant is then reset to this more restricted subtype. |
| |
| Tnn := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); |
| |
| Insert_Action (Declaration_Node (Rtype), |
| Make_Subtype_Declaration (Loc, |
| Defining_Identifier => Tnn, |
| Subtype_Indication => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => New_Occurrence_Of (Dtyp, Loc), |
| Constraint => |
| Make_Range_Constraint (Loc, |
| Range_Expression => |
| Make_Range (Loc, |
| Low_Bound => |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Name_First, |
| Prefix => New_Occurrence_Of (Dtyp, Loc)), |
| High_Bound => |
| Make_Integer_Literal (Loc, |
| Intval => UI_Max (Loval, Ahiv))))))); |
| |
| Set_Etype (Discr, Tnn); |
| end if; |
| |
| <<Continue>> |
| Next_Component (Comp); |
| end loop; |
| end Adjust_Discriminants; |
| |
| --------------------------- |
| -- Build_Array_Init_Proc -- |
| --------------------------- |
| |
| procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (Nod); |
| Comp_Type : constant Entity_Id := Component_Type (A_Type); |
| Index_List : List_Id; |
| Proc_Id : Entity_Id; |
| Body_Stmts : List_Id; |
| |
| function Init_Component return List_Id; |
| -- Create one statement to initialize one array component, designated |
| -- by a full set of indices. |
| |
| function Init_One_Dimension (N : Int) return List_Id; |
| -- Create loop to initialize one dimension of the array. The single |
| -- statement in the loop body initializes the inner dimensions if any, |
| -- or else the single component. Note that this procedure is called |
| -- recursively, with N being the dimension to be initialized. A call |
| -- with N greater than the number of dimensions simply generates the |
| -- component initialization, terminating the recursion. |
| |
| -------------------- |
| -- Init_Component -- |
| -------------------- |
| |
| function Init_Component return List_Id is |
| Comp : Node_Id; |
| |
| begin |
| Comp := |
| Make_Indexed_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Expressions => Index_List); |
| |
| if Needs_Simple_Initialization (Comp_Type) then |
| Set_Assignment_OK (Comp); |
| return New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => Comp, |
| Expression => |
| Get_Simple_Init_Val |
| (Comp_Type, Loc, Component_Size (A_Type)))); |
| |
| else |
| return |
| Build_Initialization_Call (Loc, Comp, Comp_Type, True, A_Type); |
| end if; |
| end Init_Component; |
| |
| ------------------------ |
| -- Init_One_Dimension -- |
| ------------------------ |
| |
| function Init_One_Dimension (N : Int) return List_Id is |
| Index : Entity_Id; |
| |
| begin |
| -- If the component does not need initializing, then there is nothing |
| -- to do here, so we return a null body. This occurs when generating |
| -- the dummy Init_Proc needed for Initialize_Scalars processing. |
| |
| if not Has_Non_Null_Base_Init_Proc (Comp_Type) |
| and then not Needs_Simple_Initialization (Comp_Type) |
| and then not Has_Task (Comp_Type) |
| then |
| return New_List (Make_Null_Statement (Loc)); |
| |
| -- If all dimensions dealt with, we simply initialize the component |
| |
| elsif N > Number_Dimensions (A_Type) then |
| return Init_Component; |
| |
| -- Here we generate the required loop |
| |
| else |
| Index := |
| Make_Defining_Identifier (Loc, New_External_Name ('J', N)); |
| |
| Append (New_Reference_To (Index, Loc), Index_List); |
| |
| return New_List ( |
| Make_Implicit_Loop_Statement (Nod, |
| Identifier => Empty, |
| Iteration_Scheme => |
| Make_Iteration_Scheme (Loc, |
| Loop_Parameter_Specification => |
| Make_Loop_Parameter_Specification (Loc, |
| Defining_Identifier => Index, |
| Discrete_Subtype_Definition => |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Attribute_Name => Name_Range, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, N))))), |
| Statements => Init_One_Dimension (N + 1))); |
| end if; |
| end Init_One_Dimension; |
| |
| -- Start of processing for Build_Array_Init_Proc |
| |
| begin |
| if Suppress_Init_Proc (A_Type) then |
| return; |
| end if; |
| |
| Index_List := New_List; |
| |
| -- We need an initialization procedure if any of the following is true: |
| |
| -- 1. The component type has an initialization procedure |
| -- 2. The component type needs simple initialization |
| -- 3. Tasks are present |
| -- 4. The type is marked as a publc entity |
| |
| -- The reason for the public entity test is to deal properly with the |
| -- Initialize_Scalars pragma. This pragma can be set in the client and |
| -- not in the declaring package, this means the client will make a call |
| -- to the initialization procedure (because one of conditions 1-3 must |
| -- apply in this case), and we must generate a procedure (even if it is |
| -- null) to satisfy the call in this case. |
| |
| -- Exception: do not build an array init_proc for a type whose root |
| -- type is Standard.String or Standard.Wide_[Wide_]String, since there |
| -- is no place to put the code, and in any case we handle initialization |
| -- of such types (in the Initialize_Scalars case, that's the only time |
| -- the issue arises) in a special manner anyway which does not need an |
| -- init_proc. |
| |
| if Has_Non_Null_Base_Init_Proc (Comp_Type) |
| or else Needs_Simple_Initialization (Comp_Type) |
| or else Has_Task (Comp_Type) |
| or else (not Restriction_Active (No_Initialize_Scalars) |
| and then Is_Public (A_Type) |
| and then Root_Type (A_Type) /= Standard_String |
| and then Root_Type (A_Type) /= Standard_Wide_String |
| and then Root_Type (A_Type) /= Standard_Wide_Wide_String) |
| then |
| Proc_Id := |
| Make_Defining_Identifier (Loc, Make_Init_Proc_Name (A_Type)); |
| |
| Body_Stmts := Init_One_Dimension (1); |
| |
| Discard_Node ( |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Proc_Id, |
| Parameter_Specifications => Init_Formals (A_Type)), |
| Declarations => New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Body_Stmts))); |
| |
| Set_Ekind (Proc_Id, E_Procedure); |
| Set_Is_Public (Proc_Id, Is_Public (A_Type)); |
| Set_Is_Internal (Proc_Id); |
| Set_Has_Completion (Proc_Id); |
| |
| if not Debug_Generated_Code then |
| Set_Debug_Info_Off (Proc_Id); |
| end if; |
| |
| -- Set inlined unless controlled stuff or tasks around, in which |
| -- case we do not want to inline, because nested stuff may cause |
| -- difficulties in interunit inlining, and furthermore there is |
| -- in any case no point in inlining such complex init procs. |
| |
| if not Has_Task (Proc_Id) |
| and then not Controlled_Type (Proc_Id) |
| then |
| Set_Is_Inlined (Proc_Id); |
| end if; |
| |
| -- Associate Init_Proc with type, and determine if the procedure |
| -- is null (happens because of the Initialize_Scalars pragma case, |
| -- where we have to generate a null procedure in case it is called |
| -- by a client with Initialize_Scalars set). Such procedures have |
| -- to be generated, but do not have to be called, so we mark them |
| -- as null to suppress the call. |
| |
| Set_Init_Proc (A_Type, Proc_Id); |
| |
| if List_Length (Body_Stmts) = 1 |
| and then Nkind (First (Body_Stmts)) = N_Null_Statement |
| then |
| Set_Is_Null_Init_Proc (Proc_Id); |
| end if; |
| end if; |
| end Build_Array_Init_Proc; |
| |
| ----------------------------- |
| -- Build_Class_Wide_Master -- |
| ----------------------------- |
| |
| procedure Build_Class_Wide_Master (T : Entity_Id) is |
| Loc : constant Source_Ptr := Sloc (T); |
| M_Id : Entity_Id; |
| Decl : Node_Id; |
| P : Node_Id; |
| Par : Node_Id; |
| |
| begin |
| -- Nothing to do if there is no task hierarchy |
| |
| if Restriction_Active (No_Task_Hierarchy) then |
| return; |
| end if; |
| |
| -- Find declaration that created the access type: either a |
| -- type declaration, or an object declaration with an |
| -- access definition, in which case the type is anonymous. |
| |
| if Is_Itype (T) then |
| P := Associated_Node_For_Itype (T); |
| else |
| P := Parent (T); |
| end if; |
| |
| -- Nothing to do if we already built a master entity for this scope |
| |
| if not Has_Master_Entity (Scope (T)) then |
| |
| -- first build the master entity |
| -- _Master : constant Master_Id := Current_Master.all; |
| -- and insert it just before the current declaration |
| |
| Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uMaster), |
| Constant_Present => True, |
| Object_Definition => New_Reference_To (Standard_Integer, Loc), |
| Expression => |
| Make_Explicit_Dereference (Loc, |
| New_Reference_To (RTE (RE_Current_Master), Loc))); |
| |
| Insert_Before (P, Decl); |
| Analyze (Decl); |
| Set_Has_Master_Entity (Scope (T)); |
| |
| -- Now mark the containing scope as a task master |
| |
| Par := P; |
| while Nkind (Par) /= N_Compilation_Unit loop |
| Par := Parent (Par); |
| |
| -- If we fall off the top, we are at the outer level, and the |
| -- environment task is our effective master, so nothing to mark. |
| |
| if Nkind (Par) = N_Task_Body |
| or else Nkind (Par) = N_Block_Statement |
| or else Nkind (Par) = N_Subprogram_Body |
| then |
| Set_Is_Task_Master (Par, True); |
| exit; |
| end if; |
| end loop; |
| end if; |
| |
| -- Now define the renaming of the master_id |
| |
| M_Id := |
| Make_Defining_Identifier (Loc, |
| New_External_Name (Chars (T), 'M')); |
| |
| Decl := |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => M_Id, |
| Subtype_Mark => New_Reference_To (Standard_Integer, Loc), |
| Name => Make_Identifier (Loc, Name_uMaster)); |
| Insert_Before (P, Decl); |
| Analyze (Decl); |
| |
| Set_Master_Id (T, M_Id); |
| |
| exception |
| when RE_Not_Available => |
| return; |
| end Build_Class_Wide_Master; |
| |
| -------------------------------- |
| -- Build_Discr_Checking_Funcs -- |
| -------------------------------- |
| |
| procedure Build_Discr_Checking_Funcs (N : Node_Id) is |
| Rec_Id : Entity_Id; |
| Loc : Source_Ptr; |
| Enclosing_Func_Id : Entity_Id; |
| Sequence : Nat := 1; |
| Type_Def : Node_Id; |
| V : Node_Id; |
| |
| function Build_Case_Statement |
| (Case_Id : Entity_Id; |
| Variant : Node_Id) return Node_Id; |
| -- 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_Return_Statement (Loc, |
| Expression => |
| Make_Function_Call (Loc, |
| Name => |
| New_Reference_To (Enclosing_Func_Id, Loc), |
| Parameter_Associations => |
| Actuals_List)); |
| |
| else |
| Return_Node := |
| Make_Return_Statement (Loc, |
| Expression => |
| New_Reference_To (Standard_False, Loc)); |
| end if; |
| |
| Set_Statements (Case_Alt_Node, New_List (Return_Node)); |
| Append (Case_Alt_Node, Alt_List); |
| end if; |
| |
| Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); |
| Choice_List := New_List (New_Node (N_Others_Choice, Loc)); |
| Set_Discrete_Choices (Case_Alt_Node, Choice_List); |
| |
| Return_Node := |
| Make_Return_Statement (Loc, |
| Expression => |
| New_Reference_To (Standard_True, Loc)); |
| |
| Set_Statements (Case_Alt_Node, New_List (Return_Node)); |
| Append (Case_Alt_Node, Alt_List); |
| |
| Set_Alternatives (Case_Node, Alt_List); |
| return Case_Node; |
| end Build_Case_Statement; |
| |
| --------------------------- |
| -- Build_Dcheck_Function -- |
| --------------------------- |
| |
| function Build_Dcheck_Function |
| (Case_Id : Entity_Id; |
| Variant : Node_Id) return Entity_Id |
| is |
| Body_Node : Node_Id; |
| Func_Id : Entity_Id; |
| Parameter_List : List_Id; |
| Spec_Node : Node_Id; |
| |
| begin |
| Body_Node := New_Node (N_Subprogram_Body, Loc); |
| Sequence := Sequence + 1; |
| |
| Func_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence)); |
| |
| Spec_Node := New_Node (N_Function_Specification, Loc); |
| Set_Defining_Unit_Name (Spec_Node, Func_Id); |
| |
| Parameter_List := Build_Discriminant_Formals (Rec_Id, False); |
| |
| Set_Parameter_Specifications (Spec_Node, Parameter_List); |
| Set_Result_Definition (Spec_Node, |
| New_Reference_To (Standard_Boolean, Loc)); |
| Set_Specification (Body_Node, Spec_Node); |
| Set_Declarations (Body_Node, New_List); |
| |
| Set_Handled_Statement_Sequence (Body_Node, |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Build_Case_Statement (Case_Id, Variant)))); |
| |
| Set_Ekind (Func_Id, E_Function); |
| Set_Mechanism (Func_Id, Default_Mechanism); |
| Set_Is_Inlined (Func_Id, True); |
| Set_Is_Pure (Func_Id, True); |
| Set_Is_Public (Func_Id, Is_Public (Rec_Id)); |
| Set_Is_Internal (Func_Id, True); |
| |
| if not Debug_Generated_Code then |
| Set_Debug_Info_Off (Func_Id); |
| end if; |
| |
| 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, label |
| -- all components of that variant with the function's name. |
| |
| Discr_Name := Entity (Name (Variant_Part_Node)); |
| Variant := First_Non_Pragma (Variants (Variant_Part_Node)); |
| |
| while Present (Variant) loop |
| Func_Id := Build_Dcheck_Function (Discr_Name, Variant); |
| Component_List_Node := Component_List (Variant); |
| |
| if not Null_Present (Component_List_Node) then |
| Decl := |
| First_Non_Pragma (Component_Items (Component_List_Node)); |
| |
| while Present (Decl) loop |
| Set_Discriminant_Checking_Func |
| (Defining_Identifier (Decl), Func_Id); |
| |
| Next_Non_Pragma (Decl); |
| end loop; |
| |
| if Present (Variant_Part (Component_List_Node)) then |
| Saved_Enclosing_Func_Id := Enclosing_Func_Id; |
| Enclosing_Func_Id := Func_Id; |
| Build_Dcheck_Functions (Variant_Part (Component_List_Node)); |
| Enclosing_Func_Id := Saved_Enclosing_Func_Id; |
| end if; |
| end if; |
| |
| Next_Non_Pragma (Variant); |
| end loop; |
| end Build_Dcheck_Functions; |
| |
| -- Start of processing for Build_Discr_Checking_Funcs |
| |
| begin |
| -- Only build if not done already |
| |
| if not Discr_Check_Funcs_Built (N) then |
| Type_Def := Type_Definition (N); |
| |
| if Nkind (Type_Def) = N_Record_Definition then |
| if No (Component_List (Type_Def)) then -- null record. |
| return; |
| else |
| V := Variant_Part (Component_List (Type_Def)); |
| end if; |
| |
| else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition); |
| if No (Component_List (Record_Extension_Part (Type_Def))) then |
| return; |
| else |
| V := Variant_Part |
| (Component_List (Record_Extension_Part (Type_Def))); |
| end if; |
| end if; |
| |
| Rec_Id := Defining_Identifier (N); |
| |
| if Present (V) and then not Is_Unchecked_Union (Rec_Id) then |
| Loc := Sloc (N); |
| Enclosing_Func_Id := Empty; |
| Build_Dcheck_Functions (V); |
| end if; |
| |
| Set_Discr_Check_Funcs_Built (N); |
| end if; |
| end Build_Discr_Checking_Funcs; |
| |
| -------------------------------- |
| -- Build_Discriminant_Formals -- |
| -------------------------------- |
| |
| function Build_Discriminant_Formals |
| (Rec_Id : Entity_Id; |
| Use_Dl : Boolean) return List_Id |
| is |
| Loc : Source_Ptr := Sloc (Rec_Id); |
| Parameter_List : constant List_Id := New_List; |
| D : Entity_Id; |
| Formal : 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); |
| else |
| Formal := Make_Defining_Identifier (Loc, Chars (D)); |
| end if; |
| |
| Param_Spec_Node := |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Formal, |
| Parameter_Type => |
| New_Reference_To (Etype (D), Loc)); |
| Append (Param_Spec_Node, Parameter_List); |
| Next_Discriminant (D); |
| end loop; |
| end if; |
| |
| return Parameter_List; |
| end Build_Discriminant_Formals; |
| |
| ------------------------------- |
| -- Build_Initialization_Call -- |
| ------------------------------- |
| |
| -- References to a discriminant inside the record type declaration |
| -- can appear either in the subtype_indication to constrain a |
| -- record or an array, or as part of a larger expression given for |
| -- the initial value of a component. In both of these cases N appears |
| -- in the record initialization procedure and needs to be replaced by |
| -- the formal parameter of the initialization procedure which |
| -- corresponds to that discriminant. |
| |
| -- In the example below, references to discriminants D1 and D2 in proc_1 |
| -- are replaced by references to formals with the same name |
| -- (discriminals) |
| |
| -- A similar replacement is done for calls to any record |
| -- initialization procedure for any components that are themselves |
| -- of a record type. |
| |
| -- type R (D1, D2 : Integer) is record |
| -- X : Integer := F * D1; |
| -- Y : Integer := F * D2; |
| -- end record; |
| |
| -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is |
| -- begin |
| -- Out_2.D1 := D1; |
| -- Out_2.D2 := D2; |
| -- Out_2.X := F * D1; |
| -- Out_2.Y := F * D2; |
| -- end; |
| |
| function Build_Initialization_Call |
| (Loc : Source_Ptr; |
| Id_Ref : Node_Id; |
| Typ : Entity_Id; |
| In_Init_Proc : Boolean := False; |
| Enclos_Type : Entity_Id := Empty; |
| Discr_Map : Elist_Id := New_Elmt_List; |
| With_Default_Init : Boolean := False) return List_Id |
| is |
| First_Arg : Node_Id; |
| Args : List_Id; |
| Decls : List_Id; |
| Decl : Node_Id; |
| Discr : Entity_Id; |
| Arg : Node_Id; |
| Proc : constant Entity_Id := Base_Init_Proc (Typ); |
| Init_Type : constant Entity_Id := Etype (First_Formal (Proc)); |
| Full_Init_Type : constant Entity_Id := Underlying_Type (Init_Type); |
| Res : constant List_Id := New_List; |
| Full_Type : Entity_Id := Typ; |
| Controller_Typ : Entity_Id; |
| |
| begin |
| -- Nothing to do if the Init_Proc is null, unless Initialize_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; |
| end if; |
| |
| -- Go to full view if private type. In the case of successive |
| -- private derivations, this can require more than one step. |
| |
| while Is_Private_Type (Full_Type) |
| and then Present (Full_View (Full_Type)) |
| loop |
| Full_Type := Full_View (Full_Type); |
| 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 |
| |
| -- See comments in System.Tasking.Initialization.Init_RTS |
| -- for the value 3 (should be rtsfindable constant ???) |
| |
| Append_To (Args, Make_Integer_Literal (Loc, 3)); |
| else |
| Append_To (Args, Make_Identifier (Loc, Name_uMaster)); |
| end if; |
| |
| Append_To (Args, Make_Identifier (Loc, Name_uChain)); |
| |
| -- 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); |
| Decl := Last (Decls); |
| |
| Append_To (Args, |
| New_Occurrence_Of (Defining_Identifier (Decl), Loc)); |
| Append_List (Decls, Res); |
| end if; |
| |
| else |
| Decls := No_List; |
| Decl := Empty; |
| end if; |
| |
| -- Add discriminant values if discriminants are present |
| |
| if Has_Discriminants (Full_Init_Type) then |
| Discr := First_Discriminant (Full_Init_Type); |
| |
| while Present (Discr) loop |
| |
| -- If this is a discriminated concurrent type, the init_proc |
| -- for the corresponding record is being called. Use that |
| -- type directly to find the discriminant value, to handle |
| -- properly intervening renamed discriminants. |
| |
| declare |
| T : Entity_Id := Full_Type; |
| |
| begin |
| if Is_Protected_Type (T) then |
| T := Corresponding_Record_Type (T); |
| |
| elsif Is_Private_Type (T) |
| and then Present (Underlying_Full_View (T)) |
| and then Is_Protected_Type (Underlying_Full_View (T)) |
| then |
| T := Corresponding_Record_Type (Underlying_Full_View (T)); |
| end if; |
| |
| Arg := |
| Get_Discriminant_Value ( |
| Discr, |
| T, |
| Discriminant_Constraint (Full_Type)); |
| end; |
| |
| if In_Init_Proc then |
| |
| -- Replace any possible references to the discriminant in the |
| -- call to the record initialization procedure with references |
| -- to the appropriate formal parameter. |
| |
| if Nkind (Arg) = N_Identifier |
| and then Ekind (Entity (Arg)) = E_Discriminant |
| then |
| Arg := New_Reference_To (Discriminal (Entity (Arg)), Loc); |
| |
| -- Case of access discriminants. We replace the reference |
| -- to the type by a reference to the actual object |
| |
| elsif Nkind (Arg) = N_Attribute_Reference |
| and then Is_Access_Type (Etype (Arg)) |
| and then Is_Entity_Name (Prefix (Arg)) |
| and then Is_Type (Entity (Prefix (Arg))) |
| then |
| Arg := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Copy (Prefix (Id_Ref)), |
| Attribute_Name => Name_Unrestricted_Access); |
| |
| -- Otherwise make a copy of the default expression. Note |
| -- that we use the current Sloc for this, because we do not |
| -- want the call to appear to be at the declaration point. |
| -- Within the expression, replace discriminants with their |
| -- discriminals. |
| |
| else |
| Arg := |
| New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc); |
| end if; |
| |
| else |
| if Is_Constrained (Full_Type) then |
| Arg := Duplicate_Subexpr_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). |
| |
| Arg := New_Copy_Tree (Arg, New_Sloc => Loc); |
| end if; |
| end if; |
| |
| -- Ada 2005 (AI-287) In case of default initialized components, |
| -- we need to generate the corresponding selected component node |
| -- to access the discriminant value. In other cases this is not |
| -- required because we are inside the init proc and we use the |
| -- corresponding formal. |
| |
| if With_Default_Init |
| and then Nkind (Id_Ref) = N_Selected_Component |
| and then Nkind (Arg) = N_Identifier |
| 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)); |
| end if; |
| |
| Append_To (Res, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Proc, Loc), |
| Parameter_Associations => Args)); |
| |
| if Controlled_Type (Typ) |
| and then Nkind (Id_Ref) = N_Selected_Component |
| then |
| if Chars (Selector_Name (Id_Ref)) /= Name_uParent then |
| Append_List_To (Res, |
| Make_Init_Call ( |
| Ref => New_Copy_Tree (First_Arg), |
| Typ => Typ, |
| Flist_Ref => |
| Find_Final_List (Typ, New_Copy_Tree (First_Arg)), |
| With_Attach => Make_Integer_Literal (Loc, 1))); |
| |
| -- If the enclosing type is an extension with new controlled |
| -- components, it has his own record controller. If the parent |
| -- also had a record controller, attach it to the new one. |
| -- Build_Init_Statements relies on the fact that in this specific |
| -- case the last statement of the result is the attach call to |
| -- the controller. If this is changed, it must be synchronized. |
| |
| elsif Present (Enclos_Type) |
| and then Has_New_Controlled_Component (Enclos_Type) |
| and then Has_Controlled_Component (Typ) |
| then |
| if Is_Return_By_Reference_Type (Typ) then |
| Controller_Typ := RTE (RE_Limited_Record_Controller); |
| else |
| Controller_Typ := RTE (RE_Record_Controller); |
| end if; |
| |
| Append_List_To (Res, |
| Make_Init_Call ( |
| Ref => |
| Make_Selected_Component (Loc, |
| Prefix => New_Copy_Tree (First_Arg), |
| Selector_Name => Make_Identifier (Loc, Name_uController)), |
| Typ => Controller_Typ, |
| Flist_Ref => Find_Final_List (Typ, New_Copy_Tree (First_Arg)), |
| With_Attach => Make_Integer_Literal (Loc, 1))); |
| end if; |
| end if; |
| |
| return Res; |
| |
| exception |
| when RE_Not_Available => |
| return Empty_List; |
| end Build_Initialization_Call; |
| |
| --------------------------- |
| -- Build_Master_Renaming -- |
| --------------------------- |
| |
| procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| M_Id : Entity_Id; |
| Decl : Node_Id; |
| |
| begin |
| -- Nothing to do if there is no task hierarchy |
| |
| if Restriction_Active (No_Task_Hierarchy) then |
| return; |
| end if; |
| |
| M_Id := |
| Make_Defining_Identifier (Loc, |
| New_External_Name (Chars (T), 'M')); |
| |
| Decl := |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => M_Id, |
| Subtype_Mark => New_Reference_To (RTE (RE_Master_Id), Loc), |
| Name => Make_Identifier (Loc, Name_uMaster)); |
| Insert_Before (N, Decl); |
| Analyze (Decl); |
| |
| Set_Master_Id (T, M_Id); |
| |
| exception |
| when RE_Not_Available => |
| return; |
| end Build_Master_Renaming; |
| |
| ---------------------------- |
| -- Build_Record_Init_Proc -- |
| ---------------------------- |
| |
| procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is |
| Loc : Source_Ptr := Sloc (N); |
| Discr_Map : constant Elist_Id := New_Elmt_List; |
| Proc_Id : Entity_Id; |
| Rec_Type : Entity_Id; |
| Set_Tag : Entity_Id := Empty; |
| |
| function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; |
| -- Build a assignment statement node which assigns to record |
| -- component its default expression if defined. The left hand side |
| -- of the assignment is marked Assignment_OK so that initialization |
| -- of limited private records works correctly, Return also the |
| -- adjustment call for controlled objects |
| |
| procedure Build_Discriminant_Assignments (Statement_List : List_Id); |
| -- If the record has discriminants, adds assignment statements to |
| -- statement list to initialize the discriminant values from the |
| -- arguments of the initialization procedure. |
| |
| function Build_Init_Statements (Comp_List : Node_Id) return List_Id; |
| -- Build a list representing a sequence of statements which initialize |
| -- components of the given component list. This may involve building |
| -- case statements for the variant parts. |
| |
| function Build_Init_Call_Thru (Parameters : List_Id) return List_Id; |
| -- Given a non-tagged type-derivation that declares discriminants, |
| -- such as |
| -- |
| -- type R (R1, R2 : Integer) is record ... end record; |
| -- |
| -- type D (D1 : Integer) is new R (1, D1); |
| -- |
| -- we make the _init_proc of D be |
| -- |
| -- procedure _init_proc(X : D; D1 : Integer) is |
| -- begin |
| -- _init_proc( R(X), 1, D1); |
| -- end _init_proc; |
| -- |
| -- This function builds the call statement in this _init_proc. |
| |
| procedure Build_Init_Procedure; |
| -- Build the tree corresponding to the procedure specification and body |
| -- of the initialization procedure (by calling all the preceding |
| -- auxiliary routines), and install it as the _init TSS. |
| |
| procedure Build_Offset_To_Top_Functions; |
| -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec |
| -- and body of the Offset_To_Top function that is generated when the |
| -- parent of a type with discriminants has secondary dispatch tables. |
| |
| procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id); |
| -- Add range checks to components of disciminated 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; |
| -- Determines if a component needs simple initialization, given its type |
| -- T. This is the same as Needs_Simple_Initialization except for the |
| -- following difference: the types Tag, Interface_Tag, and Vtable_Ptr |
| -- which are access types which would normally require simple |
| -- initialization to null, do not require initialization as components, |
| -- since they are explicitly initialized by other means. |
| |
| procedure Constrain_Array |
| (SI : Node_Id; |
| Check_List : List_Id); |
| -- Called from Build_Record_Checks. |
| -- Apply a list of index constraints to an unconstrained array type. |
| -- The first parameter is the entity for the resulting subtype. |
| -- Check_List is a list to which the check actions are appended. |
| |
| procedure Constrain_Index |
| (Index : Node_Id; |
| S : Node_Id; |
| Check_List : List_Id); |
| -- Called from Build_Record_Checks. |
| -- Process an index constraint in a constrained array declaration. |
| -- The constraint can be a subtype name, or a range with or without |
| -- an explicit subtype mark. The index is the corresponding index of the |
| -- unconstrained array. S is the range expression. Check_List is a list |
| -- to which the check actions are appended. |
| |
| function Parent_Subtype_Renaming_Discrims return Boolean; |
| -- Returns True for base types N that rename discriminants, else False |
| |
| function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean; |
| -- Determines whether a record initialization procedure needs to be |
| -- generated for the given record type. |
| |
| ---------------------- |
| -- Build_Assignment -- |
| ---------------------- |
| |
| function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is |
| Exp : Node_Id := N; |
| Lhs : Node_Id; |
| Typ : constant Entity_Id := Underlying_Type (Etype (Id)); |
| Kind : Node_Kind := Nkind (N); |
| Res : List_Id; |
| |
| begin |
| Loc := Sloc (N); |
| Lhs := |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => New_Occurrence_Of (Id, Loc)); |
| Set_Assignment_OK (Lhs); |
| |
| -- Case of an access attribute applied to the current instance. |
| -- Replace the reference to the type by a reference to the actual |
| -- object. (Note that this handles the case of the top level of |
| -- the expression being given by such an attribute, but does not |
| -- cover uses nested within an initial value expression. Nested |
| -- uses are unlikely to occur in practice, but are theoretically |
| -- possible. It is not clear how to handle them without fully |
| -- traversing the expression. ??? |
| |
| if Kind = N_Attribute_Reference |
| and then (Attribute_Name (N) = Name_Unchecked_Access |
| or else |
| Attribute_Name (N) = Name_Unrestricted_Access) |
| and then Is_Entity_Name (Prefix (N)) |
| and then Is_Type (Entity (Prefix (N))) |
| and then Entity (Prefix (N)) = Rec_Type |
| then |
| Exp := |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Attribute_Name => Name_Unrestricted_Access); |
| end if; |
| |
| -- Ada 2005 (AI-231): Add the run-time check if required |
| |
| if Ada_Version >= Ada_05 |
| and then Can_Never_Be_Null (Etype (Id)) -- Lhs |
| then |
| if Nkind (Exp) = N_Null then |
| return New_List ( |
| Make_Raise_Constraint_Error (Sloc (Exp), |
| Reason => CE_Null_Not_Allowed)); |
| |
| elsif Present (Etype (Exp)) |
| and then not Can_Never_Be_Null (Etype (Exp)) |
| then |
| Install_Null_Excluding_Check (Exp); |
| end if; |
| end if; |
| |
| -- Take a copy of Exp to ensure that later copies of this |
| -- component_declaration in derived types see the original tree, |
| -- not a node rewritten during expansion of the init_proc. |
| |
| Exp := New_Copy_Tree (Exp); |
| |
| Res := New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => Lhs, |
| Expression => Exp)); |
| |
| Set_No_Ctrl_Actions (First (Res)); |
| |
| -- Adjust the tag if tagged (because of possible view conversions). |
| -- Suppress the tag adjustment when Java_VM because JVM tags are |
| -- represented implicitly in objects. |
| |
| if Is_Tagged_Type (Typ) and then not Java_VM then |
| Append_To (Res, |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => New_Copy_Tree (Lhs), |
| Selector_Name => |
| New_Reference_To (First_Tag_Component (Typ), Loc)), |
| |
| Expression => |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To |
| (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)))); |
| end if; |
| |
| -- Adjust the component if controlled except if it is an |
| -- aggregate that will be expanded inline |
| |
| if Kind = N_Qualified_Expression then |
| Kind := Nkind (Expression (N)); |
| end if; |
| |
| if Controlled_Type (Typ) |
| and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate) |
| then |
| Append_List_To (Res, |
| Make_Adjust_Call ( |
| Ref => New_Copy_Tree (Lhs), |
| Typ => Etype (Id), |
| Flist_Ref => |
| Find_Final_List (Etype (Id), New_Copy_Tree (Lhs)), |
| With_Attach => Make_Integer_Literal (Loc, 1))); |
| end if; |
| |
| return Res; |
| |
| exception |
| when RE_Not_Available => |
| return Empty_List; |
| end Build_Assignment; |
| |
| ------------------------------------ |
| -- Build_Discriminant_Assignments -- |
| ------------------------------------ |
| |
| procedure Build_Discriminant_Assignments (Statement_List : List_Id) is |
| D : Entity_Id; |
| Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type); |
| |
| begin |
| if Has_Discriminants (Rec_Type) |
| and then not Is_Unchecked_Union (Rec_Type) |
| then |
| D := First_Discriminant (Rec_Type); |
| |
| while Present (D) loop |
| -- Don't generate the assignment for discriminants in derived |
| -- tagged types if the discriminant is a renaming of some |
| -- ancestor discriminant. This initialization will be done |
| -- when initializing the _parent field of the derived record. |
| |
| if Is_Tagged and then |
| Present (Corresponding_Discriminant (D)) |
| then |
| null; |
| |
| else |
| Loc := Sloc (D); |
| Append_List_To (Statement_List, |
| Build_Assignment (D, |
| New_Reference_To (Discriminal (D), Loc))); |
| end if; |
| |
| Next_Discriminant (D); |
| end loop; |
| end if; |
| end Build_Discriminant_Assignments; |
| |
| -------------------------- |
| -- Build_Init_Call_Thru -- |
| -------------------------- |
| |
| function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is |
| Parent_Proc : constant Entity_Id := |
| Base_Init_Proc (Etype (Rec_Type)); |
| |
| Parent_Type : constant Entity_Id := |
| Etype (First_Formal (Parent_Proc)); |
| |
| Uparent_Type : constant Entity_Id := |
| Underlying_Type (Parent_Type); |
| |
| First_Discr_Param : Node_Id; |
| |
| Parent_Discr : Entity_Id; |
| First_Arg : Node_Id; |
| Args : List_Id; |
| Arg : Node_Id; |
| Res : List_Id; |
| |
| begin |
| -- First argument (_Init) is the object to be initialized. |
| -- ??? not sure where to get a reasonable Loc for First_Arg |
| |
| First_Arg := |
| OK_Convert_To (Parent_Type, |
| New_Reference_To (Defining_Identifier (First (Parameters)), Loc)); |
| |
| Set_Etype (First_Arg, Parent_Type); |
| |
| Args := New_List (Convert_Concurrent (First_Arg, Rec_Type)); |
| |
| -- In the tasks case, |
| -- add _Master as the value of the _Master parameter |
| -- add _Chain as the value of the _Chain parameter. |
| -- add _Task_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 |
| |
| -- See comments in System.Tasking.Initialization.Init_RTS |
| -- for the value 3. |
| |
| Append_To (Args, Make_Integer_Literal (Loc, 3)); |
| else |
| Append_To (Args, Make_Identifier (Loc, Name_uMaster)); |
| end if; |
| |
| Append_To (Args, Make_Identifier (Loc, Name_uChain)); |
| Append_To (Args, Make_Identifier (Loc, Name_uTask_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_Value : Elmt_Id := |
| First_Elmt |
| (Stored_Constraint (Rec_Type)); |
| |
| Discr : Entity_Id := |
| First_Stored_Discriminant (Uparent_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_Reference_To (Discriminal (Entity (Arg)), Loc)); |
| |
| -- Case of access discriminants. We replace the reference |
| -- to the type by a reference to the actual object |
| |
| -- ??? why is this code deleted without comment |
| |
| -- elsif Nkind (Arg) = N_Attribute_Reference |
| -- and then Is_Entity_Name (Prefix (Arg)) |
| -- and then Is_Type (Entity (Prefix (Arg))) |
| -- then |
| -- Append_To (Args, |
| -- Make_Attribute_Reference (Loc, |
| -- Prefix => New_Copy (Prefix (Id_Ref)), |
| -- Attribute_Name => Name_Unrestricted_Access)); |
| |
| else |
| Append_To (Args, New_Copy (Arg)); |
| end if; |
| |
| Next_Discriminant (Parent_Discr); |
| end loop; |
| end if; |
| |
| Res := |
| New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Parent_Proc, Loc), |
| Parameter_Associations => Args)); |
| |
| return Res; |
| end Build_Init_Call_Thru; |
| |
| ----------------------------------- |
| -- Build_Offset_To_Top_Functions -- |
| ----------------------------------- |
| |
| procedure Build_Offset_To_Top_Functions is |
| ADT : Elmt_Id; |
| Body_Node : Node_Id; |
| Func_Id : Entity_Id; |
| Spec_Node : Node_Id; |
| E : Entity_Id; |
| |
| procedure Build_Offset_To_Top_Internal (Typ : Entity_Id); |
| -- Internal subprogram used to recursively traverse all the ancestors |
| |
| ---------------------------------- |
| -- Build_Offset_To_Top_Internal -- |
| ---------------------------------- |
| |
| procedure Build_Offset_To_Top_Internal (Typ : Entity_Id) is |
| begin |
| -- Climb to the ancestor (if any) handling private types |
| |
| if Present (Full_View (Etype (Typ))) then |
| if Full_View (Etype (Typ)) /= Typ then |
| Build_Offset_To_Top_Internal (Full_View (Etype (Typ))); |
| end if; |
| |
| elsif Etype (Typ) /= Typ then |
| Build_Offset_To_Top_Internal (Etype (Typ)); |
| end if; |
| |
| if Present (Abstract_Interfaces (Typ)) |
| and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) |
| then |
| E := First_Entity (Typ); |
| while Present (E) loop |
| if Is_Tag (E) |
| and then Chars (E) /= Name_uTag |
| then |
| if Typ = Rec_Type then |
| Body_Node := New_Node (N_Subprogram_Body, Loc); |
| |
| Func_Id := Make_Defining_Identifier (Loc, |
| New_Internal_Name ('F')); |
| |
| Set_DT_Offset_To_Top_Func (E, Func_Id); |
| |
| 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_Reference_To (Typ, Loc)))); |
| Set_Result_Definition (Spec_Node, |
| New_Reference_To (RTE (RE_Storage_Offset), 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 ( |
| Make_Return_Statement (Loc, |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, |
| Name_uO), |
| Selector_Name => New_Reference_To |
| (E, 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 if; |
| |
| Next_Elmt (ADT); |
| end if; |
| |
| Next_Entity (E); |
| end loop; |
| end if; |
| end Build_Offset_To_Top_Internal; |
| |
| -- Start of processing for Build_Offset_To_Top_Functions |
| |
| begin |
| if Etype (Rec_Type) = Rec_Type |
| or else not Has_Discriminants (Etype (Rec_Type)) |
| or else No (Abstract_Interfaces (Rec_Type)) |
| or else Is_Empty_Elmt_List (Abstract_Interfaces (Rec_Type)) |
| then |
| return; |
| end if; |
| |
| -- Skip the first _Tag, which is the main tag of the |
| -- tagged type. Following tags correspond with abstract |
| -- interfaces. |
| |
| ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Rec_Type))); |
| |
| -- Handle private types |
| |
| if Present (Full_View (Rec_Type)) then |
| Build_Offset_To_Top_Internal (Full_View (Rec_Type)); |
| else |
| Build_Offset_To_Top_Internal (Rec_Type); |
| end if; |
| end Build_Offset_To_Top_Functions; |
| |
| -------------------------- |
| -- Build_Init_Procedure -- |
| -------------------------- |
| |
| procedure Build_Init_Procedure is |
| Body_Node : Node_Id; |
| Handled_Stmt_Node : Node_Id; |
| Parameters : List_Id; |
| Proc_Spec_Node : Node_Id; |
| Body_Stmts : List_Id; |
| Record_Extension_Node : Node_Id; |
| Init_Tag : Node_Id; |
| |
| procedure Init_Secondary_Tags (Typ : Entity_Id); |
| -- Ada 2005 (AI-251): Initialize the tags of all the secondary |
| -- tables associated with abstract interface types |
| |
| ------------------------- |
| -- Init_Secondary_Tags -- |
| ------------------------- |
| |
| procedure Init_Secondary_Tags (Typ : Entity_Id) is |
| ADT : Elmt_Id; |
| |
| procedure Init_Secondary_Tags_Internal (Typ : Entity_Id); |
| -- Internal subprogram used to recursively climb to the root type |
| |
| ---------------------------------- |
| -- Init_Secondary_Tags_Internal -- |
| ---------------------------------- |
| |
| procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is |
| Aux_N : Node_Id; |
| E : Entity_Id; |
| Iface : Entity_Id; |
| Prev_E : Entity_Id; |
| |
| begin |
| -- Climb to the ancestor (if any) handling private types |
| |
| if Present (Full_View (Etype (Typ))) then |
| if Full_View (Etype (Typ)) /= Typ then |
| Init_Secondary_Tags_Internal (Full_View (Etype (Typ))); |
| end if; |
| |
| elsif Etype (Typ) /= Typ then |
| Init_Secondary_Tags_Internal (Etype (Typ)); |
| end if; |
| |
| if Present (Abstract_Interfaces (Typ)) |
| and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) |
| then |
| E := First_Entity (Typ); |
| while Present (E) loop |
| if Is_Tag (E) |
| and then Chars (E) /= Name_uTag |
| then |
| Aux_N := Node (ADT); |
| pragma Assert (Present (Aux_N)); |
| |
| Iface := Find_Interface (Typ, E); |
| |
| -- Initialize the pointer to the secondary DT |
| -- associated with the interface |
| |
| Append_To (Body_Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => |
| New_Reference_To (E, Loc)), |
| Expression => |
| New_Reference_To (Aux_N, Loc))); |
| |
| -- Issue error if Set_Offset_To_Top is not available |
| -- in a configurable run-time environment. |
| |
| if not RTE_Available (RE_Set_Offset_To_Top) then |
| Error_Msg_CRT ("abstract interface types", Typ); |
| return; |
| end if; |
| |
| -- We generate a different call to Set_Offset_To_Top |
| -- when the parent of the type has discriminants |
| |
| if Typ /= Etype (Typ) |
| and then Has_Discriminants (Etype (Typ)) |
| then |
| pragma Assert (Present (DT_Offset_To_Top_Func (E))); |
| |
| -- Generate: |
| -- Set_Offset_To_Top |
| -- (This => Init, |
| -- Interface_T => Iface'Tag, |
| -- Is_Constant => False, |
| -- Offset_Value => n, |
| -- Offset_Func => Fn'Address) |
| |
| Append_To (Body_Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Reference_To |
| (RTE (RE_Set_Offset_To_Top), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, |
| Name_uInit), |
| Attribute_Name => Name_Address), |
| |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To |
| (Node (First_Elmt |
| (Access_Disp_Table (Iface))), |
| Loc)), |
| |
| New_Occurrence_Of (Standard_False, Loc), |
| |
| Unchecked_Convert_To (RTE (RE_Storage_Offset), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, |
| Name_uInit), |
| Selector_Name => New_Reference_To |
| (E, Loc)), |
| Attribute_Name => Name_Position)), |
| |
| Unchecked_Convert_To (RTE (RE_Address), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To |
| (DT_Offset_To_Top_Func (E), |
| Loc), |
| Attribute_Name => |
| Name_Address))))); |
| |
| -- In this case the next component stores the value |
| -- of the offset to the top |
| |
| Prev_E := E; |
| Next_Entity (E); |
| pragma Assert (Present (E)); |
| |
| Append_To (Body_Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, |
| Name_uInit), |
| Selector_Name => |
| New_Reference_To (E, Loc)), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, |
| Name_uInit), |
| Selector_Name => New_Reference_To |
| (Prev_E, Loc)), |
| Attribute_Name => Name_Position))); |
| |
| -- Normal case: No discriminants in the parent type |
| |
| else |
| -- Generate: |
| -- Set_Offset_To_Top |
| -- (This => Init, |
| -- Interface_T => Iface'Tag, |
| -- Is_Constant => True, |
| -- Offset_Value => n, |
| -- Offset_Func => null); |
| |
| Append_To (Body_Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Reference_To |
| (RTE (RE_Set_Offset_To_Top), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Attribute_Name => Name_Address), |
| |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To |
| (Node (First_Elmt |
| (Access_Disp_Table (Iface))), |
| Loc)), |
| |
| New_Occurrence_Of (Standard_True, Loc), |
| |
| Unchecked_Convert_To (RTE (RE_Storage_Offset), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, |
| Name_uInit), |
| Selector_Name => New_Reference_To |
| (E, Loc)), |
| Attribute_Name => Name_Position)), |
| |
| New_Reference_To |
| (RTE (RE_Null_Address), Loc)))); |
| end if; |
| |
| Next_Elmt (ADT); |
| end if; |
| |
| Next_Entity (E); |
| end loop; |
| end if; |
| end Init_Secondary_Tags_Internal; |
| |
| -- Start of processing for Init_Secondary_Tags |
| |
| begin |
| -- Skip the first _Tag, which is the main tag of the |
| -- tagged type. Following tags correspond with abstract |
| -- interfaces. |
| |
| ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); |
| |
| -- Handle private types |
| |
| if Present (Full_View (Typ)) then |
| Init_Secondary_Tags_Internal (Full_View (Typ)); |
| else |
| Init_Secondary_Tags_Internal (Typ); |
| end if; |
| end Init_Secondary_Tags; |
| |
| -- Start of processing for Build_Init_Procedure |
| |
| begin |
| Body_Stmts := New_List; |
| Body_Node := New_Node (N_Subprogram_Body, Loc); |
| |
| Proc_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Make_Init_Proc_Name (Rec_Type)); |
| Set_Ekind (Proc_Id, E_Procedure); |
| |
| Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); |
| Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); |
| |
| Parameters := Init_Formals (Rec_Type); |
| Append_List_To (Parameters, |
| Build_Discriminant_Formals (Rec_Type, True)); |
| |
| -- For tagged types, we add a flag to indicate whether the routine |
| -- is called to initialize a parent component in the init_proc of |
| -- a type extension. If the flag is false, we do not set the tag |
| -- because it has been set already in the extension. |
| |
| if Is_Tagged_Type (Rec_Type) |
| and then not Is_CPP_Class (Rec_Type) |
| then |
| Set_Tag := |
| Make_Defining_Identifier (Loc, New_Internal_Name ('P')); |
| |
| Append_To (Parameters, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Set_Tag, |
| Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), |
| Expression => New_Occurrence_Of (Standard_True, Loc))); |
| end if; |
| |
| Set_Parameter_Specifications (Proc_Spec_Node, Parameters); |
| Set_Specification (Body_Node, Proc_Spec_Node); |
| Set_Declarations (Body_Node, New_List); |
| |
| if Parent_Subtype_Renaming_Discrims then |
| |
| -- N is a Derived_Type_Definition that renames the parameters |
| -- of the ancestor type. We initialize it by expanding our |
| -- discriminants and call the ancestor _init_proc with a |
| -- type-converted object |
| |
| Append_List_To (Body_Stmts, |
| Build_Init_Call_Thru (Parameters)); |
| |
| elsif Nkind (Type_Definition (N)) = N_Record_Definition then |
| Build_Discriminant_Assignments (Body_Stmts); |
| |
| if not Null_Present (Type_Definition (N)) then |
| Append_List_To (Body_Stmts, |
| Build_Init_Statements ( |
| Component_List (Type_Definition (N)))); |
| end if; |
| |
| else |
| -- N is a Derived_Type_Definition with a possible non-empty |
| -- extension. The initialization of a type extension consists |
| -- in the initialization of the components in the extension. |
| |
| Build_Discriminant_Assignments (Body_Stmts); |
| |
| Record_Extension_Node := |
| Record_Extension_Part (Type_Definition (N)); |
| |
| if not Null_Present (Record_Extension_Node) then |
| declare |
| Stmts : 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 |
| |
| Prepend_To (Body_Stmts, Remove_Head (Stmts)); |
| Append_List_To (Body_Stmts, Stmts); |
| end; |
| end if; |
| end if; |
| |
| -- Add here the assignment to instantiate the Tag |
| |
| -- The assignement corresponds to the code: |
| |
| -- _Init._Tag := Typ'Tag; |
| |
| -- Suppress the tag assignment when Java_VM because JVM tags are |
| -- represented implicitly in objects. 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 not Is_CPP_Class (Rec_Type) |
| and then not Java_VM |
| then |
| Init_Tag := |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => |
| New_Reference_To (First_Tag_Component (Rec_Type), Loc)), |
| |
| Expression => |
| New_Reference_To |
| (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)); |
| |
| -- The tag must be inserted before the assignments to other |
| -- components, because the initial value of the component may |
| -- depend ot the tag (eg. through a dispatching operation on |
| -- an access to the current type). The tag assignment is not done |
| -- when initializing the parent component of a type extension, |
| -- because in that case the tag is set in the extension. |
| -- Extensions of imported C++ classes add a final complication, |
| -- because we cannot inhibit tag setting in the constructor for |
| -- the parent. In that case we insert the tag initialization |
| -- after the calls to initialize the parent. |
| |
| Init_Tag := |
| Make_If_Statement (Loc, |
| Condition => New_Occurrence_Of (Set_Tag, Loc), |
| Then_Statements => New_List (Init_Tag)); |
| |
| if not Is_CPP_Class (Etype (Rec_Type)) then |
| Prepend_To (Body_Stmts, Init_Tag); |
| |
| -- Ada 2005 (AI-251): Initialization of all the tags |
| -- corresponding with abstract interfaces |
| |
| if Ada_Version >= Ada_05 |
| and then not Is_Interface (Rec_Type) |
| then |
| Init_Secondary_Tags (Rec_Type); |
| end if; |
| |
| else |
| declare |
| Nod : Node_Id := First (Body_Stmts); |
| |
| begin |
| -- We assume the first init_proc call is for the parent |
| |
| while Present (Next (Nod)) |
| and then (Nkind (Nod) /= N_Procedure_Call_Statement |
| or else not Is_Init_Proc (Name (Nod))) |
| loop |
| Nod := Next (Nod); |
| end loop; |
| |
| Insert_After (Nod, Init_Tag); |
| end; |
| end if; |
| end if; |
| |
| Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc); |
| Set_Statements (Handled_Stmt_Node, Body_Stmts); |
| Set_Exception_Handlers (Handled_Stmt_Node, No_List); |
| Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); |
| |
| if not Debug_Generated_Code then |
| Set_Debug_Info_Off (Proc_Id); |
| end if; |
| |
| -- Associate Init_Proc with type, and determine if the procedure |
| -- is null (happens because of the Initialize_Scalars pragma case, |
| -- where we have to generate a null procedure in case it is called |
| -- by a client with Initialize_Scalars set). Such procedures have |
| -- to be generated, but do not have to be called, so we mark them |
| -- as null to suppress the call. |
| |
| Set_Init_Proc (Rec_Type, Proc_Id); |
| |
| if List_Length (Body_Stmts) = 1 |
| and then Nkind (First (Body_Stmts)) = N_Null_Statement |
| then |
| Set_Is_Null_Init_Proc (Proc_Id); |
| end if; |
| end Build_Init_Procedure; |
| |
| --------------------------- |
| -- Build_Init_Statements -- |
| --------------------------- |
| |
| function Build_Init_Statements (Comp_List : Node_Id) return List_Id is |
| Check_List : constant List_Id := New_List; |
| Alt_List : List_Id; |
| Statement_List : List_Id; |
| Stmts : List_Id; |
| |
| Per_Object_Constraint_Components : Boolean; |
| |
| Decl : Node_Id; |
| Variant : Node_Id; |
| |
| Id : Entity_Id; |
| Typ : Entity_Id; |
| |
| function Has_Access_Constraint (E : Entity_Id) return Boolean; |
| -- Components with access discriminants that depend on the current |
| -- instance must be initialized after all other components. |
| |
| --------------------------- |
| -- Has_Access_Constraint -- |
| --------------------------- |
| |
| function Has_Access_Constraint (E : Entity_Id) return Boolean is |
| Disc : Entity_Id; |
| T : constant Entity_Id := Etype (E); |
| |
| begin |
| if Has_Per_Object_Constraint (E) |
| and then Has_Discriminants (T) |
| then |
| Disc := First_Discriminant (T); |
| while Present (Disc) loop |
| if Is_Access_Type (Etype (Disc)) then |
| return True; |
| end if; |
| |
| Next_Discriminant (Disc); |
| end loop; |
| |
| return False; |
| else |
| return False; |
| end if; |
| end Has_Access_Constraint; |
| |
| -- Start of processing for Build_Init_Statements |
| |
| begin |
| if Null_Present (Comp_List) then |
| return New_List (Make_Null_Statement (Loc)); |
| end if; |
| |
| Statement_List := New_List; |
| |
| -- Loop through components, skipping pragmas, in 2 steps. The first |
| -- step deals with regular components. The second step deals with |
| -- components have per object constraints, and no explicit initia- |
| -- lization. |
| |
| Per_Object_Constraint_Components := False; |
| |
| -- First step : regular components |
| |
| Decl := First_Non_Pragma (Component_Items (Comp_List)); |
| while Present (Decl) loop |
| Loc := Sloc (Decl); |
| Build_Record_Checks |
| (Subtype_Indication (Component_Definition (Decl)), Check_List); |
| |
| Id := Defining_Identifier (Decl); |
| Typ := Etype (Id); |
| |
| if Has_Access_Constraint (Id) |
| and then No (Expression (Decl)) |
| then |
| -- Skip processing for now and ask for a second pass |
| |
| Per_Object_Constraint_Components := True; |
| |
| else |
| -- Case of explicit initialization |
| |
| if Present (Expression (Decl)) then |
| Stmts := Build_Assignment (Id, Expression (Decl)); |
| |
| -- Case of composite component with its own Init_Proc |
| |
| elsif not Is_Interface (Typ) |
| and then Has_Non_Null_Base_Init_Proc (Typ) |
| then |
| Stmts := |
| Build_Initialization_Call |
| (Loc, |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => New_Occurrence_Of (Id, Loc)), |
| Typ, |
| True, |
| Rec_Type, |
| Discr_Map => Discr_Map); |
| |
| -- Case of component needing simple initialization |
| |
| elsif Component_Needs_Simple_Initialization (Typ) then |
| Stmts := |
| Build_Assignment |
| (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id))); |
| |
| -- Nothing needed for this case |
| |
| else |
| Stmts := No_List; |
| end if; |
| |
| if Present (Check_List) then |
| Append_List_To (Statement_List, Check_List); |
| end if; |
| |
| if Present (Stmts) then |
| |
| -- Add the initialization of the record controller before |
| -- the _Parent field is attached to it when the attachment |
| -- can occur. It does not work to simply initialize the |
| -- controller first: it must be initialized after the parent |
| -- if the parent holds discriminants that can be used |
| -- to compute the offset of the controller. We assume here |
| -- that the last statement of the initialization call is the |
| -- attachement of the parent (see Build_Initialization_Call) |
| |
| if Chars (Id) = Name_uController |
| and then Rec_Type /= Etype (Rec_Type) |
| and then Has_Controlled_Component (Etype (Rec_Type)) |
| and then Has_New_Controlled_Component (Rec_Type) |
| then |
| Insert_List_Before (Last (Statement_List), Stmts); |
| else |
| Append_List_To (Statement_List, Stmts); |
| end if; |
| end if; |
| end if; |
| |
| Next_Non_Pragma (Decl); |
| end loop; |
| |
| if Per_Object_Constraint_Components then |
| |
| -- Second pass: components with per-object constraints |
| |
| Decl := First_Non_Pragma (Component_Items (Comp_List)); |
| |
| while Present (Decl) loop |
| Loc := Sloc (Decl); |
| Id := Defining_Identifier (Decl); |
| Typ := Etype (Id); |
| |
| if Has_Access_Constraint (Id) |
| and then No (Expression (Decl)) |
| then |
| if Has_Non_Null_Base_Init_Proc (Typ) then |
| Append_List_To (Statement_List, |
| Build_Initialization_Call (Loc, |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => New_Occurrence_Of (Id, Loc)), |
| Typ, True, Rec_Type, Discr_Map => Discr_Map)); |
| |
| elsif Component_Needs_Simple_Initialization (Typ) then |
| Append_List_To (Statement_List, |
| Build_Assignment |
| (Id, Get_Simple_Init_Val (Typ, Loc, 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 |
| Alt_List := New_List; |
| Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); |
| |
| while Present (Variant) loop |
| Loc := Sloc (Variant); |
| Append_To (Alt_List, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => |
| New_Copy_List (Discrete_Choices (Variant)), |
| Statements => |
| Build_Init_Statements (Component_List (Variant)))); |
| |
| Next_Non_Pragma (Variant); |
| end loop; |
| |
| -- The expression of the case statement which is a reference |
| -- to one of the discriminants is replaced by the appropriate |
| -- formal parameter of the initialization procedure. |
| |
| Append_To (Statement_List, |
| Make_Case_Statement (Loc, |
| Expression => |
| New_Reference_To (Discriminal ( |
| Entity (Name (Variant_Part (Comp_List)))), Loc), |
| Alternatives => Alt_List)); |
| end if; |
| |
| -- For a task record type, add the task create call and calls |
| -- to bind any interrupt (signal) entries. |
| |
| if Is_Task_Record_Type (Rec_Type) then |
| |
| -- In the case of the restricted run time the ATCB has already |
| -- been preallocated. |
| |
| if Restricted_Profile then |
| Append_To (Statement_List, |
| Make_Assignment_Statement (Loc, |
| Name => Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), |
| Expression => Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uATCB)), |
| Attribute_Name => Name_Unchecked_Access))); |
| end if; |
| |
| Append_To (Statement_List, Make_Task_Create_Call (Rec_Type)); |
| |
| declare |
| Task_Type : constant Entity_Id := |
| Corresponding_Concurrent_Type (Rec_Type); |
| Task_Decl : constant Node_Id := Parent (Task_Type); |
| Task_Def : constant Node_Id := Task_Definition (Task_Decl); |
| Vis_Decl : Node_Id; |
| Ent : Entity_Id; |
| |
| begin |
| if Present (Task_Def) then |
| Vis_Decl := First (Visible_Declarations (Task_Def)); |
| while Present (Vis_Decl) loop |
| Loc := Sloc (Vis_Decl); |
| |
| if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then |
| if Get_Attribute_Id (Chars (Vis_Decl)) = |
| Attribute_Address |
| then |
| Ent := Entity (Name (Vis_Decl)); |
| |
| if Ekind (Ent) = E_Entry then |
| Append_To (Statement_List, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Reference_To ( |
| RTE (RE_Bind_Interrupt_To_Entry), Loc), |
| Parameter_Associations => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Identifier (Loc, Name_uInit), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uTask_Id)), |
| Entry_Index_Expression ( |
| Loc, Ent, Empty, Task_Type), |
| Expression (Vis_Decl)))); |
| end if; |
| end if; |
| end if; |
| |
| Next (Vis_Decl); |
| end loop; |
| end if; |
| end; |
| end if; |
| |
| -- For a protected type, add statements generated by |
| -- Make_Initialize_Protection. |
| |
| if Is_Protected_Record_Type (Rec_Type) then |
| Append_List_To (Statement_List, |
| Make_Initialize_Protection (Rec_Type)); |
| end if; |
| |
| -- If no initializations when generated for component declarations |
| -- corresponding to this Statement_List, append a null statement |
| -- to the Statement_List to make it a valid Ada tree. |
| |
| if Is_Empty_List (Statement_List) then |
| Append (New_Node (N_Null_Statement, Loc), Statement_List); |
| end if; |
| |
| return Statement_List; |
| |
| 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; |
| |
| 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) |
| and then not Is_RTE (T, RE_Vtable_Ptr) |
| |
| -- 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; |
| |
| --------------------- |
| -- 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; |
| |
| begin |
| T := Entity (Subtype_Mark (SI)); |
| |
| if Ekind (T) in Access_Kind then |
| T := Designated_Type (T); |
| end if; |
| |
| S := First (Constraints (C)); |
| |
| while Present (S) loop |
| Number_Of_Constraints := Number_Of_Constraints + 1; |
| Next (S); |
| end loop; |
| |
| -- In either case, the index constraint must provide a discrete |
| -- range for each index of the array type and the type of each |
| -- discrete range must be the same as that of the corresponding |
| -- index. (RM 3.6.1) |
| |
| S := First (Constraints (C)); |
| Index := First_Index (T); |
| Analyze (Index); |
| |
| -- Apply constraints to each index type |
| |
| for J in 1 .. Number_Of_Constraints loop |
| Constrain_Index (Index, S, Check_List); |
| Next (Index); |
| Next (S); |
| end loop; |
| |
| end Constrain_Array; |
| |
| --------------------- |
| -- 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); |
| end if; |
| end Constrain_Index; |
| |
| -------------------------------------- |
| -- Parent_Subtype_Renaming_Discrims -- |
| -------------------------------------- |
| |
| function Parent_Subtype_Renaming_Discrims return Boolean is |
| De : Entity_Id; |
| Dp : Entity_Id; |
| |
| begin |
| if Base_Type (Pe) /= Pe then |
| return False; |
| end if; |
| |
| if Etype (Pe) = Pe |
| or else not Has_Discriminants (Pe) |
| or else Is_Constrained (Pe) |
| or else Is_Tagged_Type (Pe) |
| then |
| return False; |
| end if; |
| |
| -- If there are no explicit stored discriminants we have inherited |
| -- the root type discriminants so far, so no renamings occurred. |
| |
| if First_Discriminant (Pe) = First_Stored_Discriminant (Pe) then |
| return False; |
| end if; |
| |
| -- Check if we have done some trivial renaming of the parent |
| -- discriminants, i.e. someting like |
| -- |
| -- type DT (X1,X2: int) is new PT (X1,X2); |
| |
| De := First_Discriminant (Pe); |
| Dp := First_Discriminant (Etype (Pe)); |
| |
| while Present (De) loop |
| pragma Assert (Present (Dp)); |
| |
| if Corresponding_Discriminant (De) /= Dp then |
| return True; |
| end if; |
| |
| Next_Discriminant (De); |
| Next_Discriminant (Dp); |
| end loop; |
| |
| return Present (Dp); |
| end Parent_Subtype_Renaming_Discrims; |
| |
| ------------------------ |
| -- Requires_Init_Proc -- |
| ------------------------ |
| |
| function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is |
| Comp_Decl : Node_Id; |
| Id : Entity_Id; |
| Typ : Entity_Id; |
| |
| begin |
| -- Definitely do not need one if specifically suppressed |
| |
| if Suppress_Init_Proc (Rec_Id) then |
| return False; |
| end if; |
| |
| -- 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) 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 in the C++ side. |
| |
| if Is_CPP_Class (Rec_Id) then |
| return False; |
| |
| elsif not Restriction_Active (No_Initialize_Scalars) |
| and then Is_Public (Rec_Id) |
| then |
| return True; |
| |
| elsif (Has_Discriminants (Rec_Id) |
| and then not Is_Unchecked_Union (Rec_Id)) |
| or else Is_Tagged_Type (Rec_Id) |
| or else Is_Concurrent_Record_Type (Rec_Id) |
| or else Has_Task (Rec_Id) |
| then |
| return True; |
| end if; |
| |
| Id := First_Component (Rec_Id); |
| |
| while Present (Id) loop |
| Comp_Decl := Parent (Id); |
| Typ := Etype (Id); |
| |
| if Present (Expression (Comp_Decl)) |
| or else Has_Non_Null_Base_Init_Proc (Typ) |
| or else Component_Needs_Simple_Initialization (Typ) |
| then |
| return True; |
| end if; |
| |
| Next_Component (Id); |
| end loop; |
| |
| return False; |
| end Requires_Init_Proc; |
| |
| -- Start of processing for Build_Record_Init_Proc |
| |
| begin |
| Rec_Type := Defining_Identifier (N); |
| |
| -- This may be full declaration of a private type, in which case |
| -- the visible entity is a record, and the private entity has been |
| -- exchanged with it in the private part of the current package. |
| -- The initialization procedure is built for the record type, which |
| -- is retrievable from the private entity. |
| |
| if Is_Incomplete_Or_Private_Type (Rec_Type) then |
| Rec_Type := Underlying_Type (Rec_Type); |
| end if; |
| |
| -- If there are discriminants, build the discriminant map to replace |
| -- discriminants by their discriminals in complex bound expressions. |
| -- These only arise for the corresponding records of protected types. |
| |
| if Is_Concurrent_Record_Type (Rec_Type) |
| and then Has_Discriminants (Rec_Type) |
| then |
| declare |
| Disc : Entity_Id; |
| |
| begin |
| Disc := First_Discriminant (Rec_Type); |
| |
| while Present (Disc) loop |
| Append_Elmt (Disc, Discr_Map); |
| Append_Elmt (Discriminal (Disc), Discr_Map); |
| Next_Discriminant (Disc); |
| end loop; |
| end; |
| end if; |
| |
| -- Derived types that have no type extension can use the initialization |
| -- procedure of their parent and do not need a procedure of their own. |
| -- This is only correct if there are no representation clauses for the |
| -- type or its parent, and if the parent has in fact been frozen so |
| -- that its initialization procedure exists. |
| |
| if Is_Derived_Type (Rec_Type) |
| and then not Is_Tagged_Type (Rec_Type) |
| and then not Is_Unchecked_Union (Rec_Type) |
| and then not Has_New_Non_Standard_Rep (Rec_Type) |
| and then not Parent_Subtype_Renaming_Discrims |
| and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type)) |
| then |
| Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type); |
| |
| -- Otherwise if we need an initialization procedure, then build one, |
| -- mark it as public and inlinable and as having a completion. |
| |
| elsif Requires_Init_Proc (Rec_Type) |
| or else Is_Unchecked_Union (Rec_Type) |
| then |
| Build_Offset_To_Top_Functions; |
| Build_Init_Procedure; |
| Set_Is_Public (Proc_Id, Is_Public (Pe)); |
| |
| -- The initialization of protected records is not worth inlining. |
| -- In addition, when compiled for another unit for inlining purposes, |
| -- it may make reference to entities that have not been elaborated |
| -- yet. The initialization of controlled records contains a nested |
| -- clean-up procedure that makes it impractical to inline as well, |
| -- and leads to undefined symbols if inlined in a different unit. |
| -- Similar considerations apply to task types. |
| |
| if not Is_Concurrent_Type (Rec_Type) |
| and then not Has_Task (Rec_Type) |
| and then not Controlled_Type (Rec_Type) |
| then |
| Set_Is_Inlined (Proc_Id); |
| end if; |
| |
| Set_Is_Internal (Proc_Id); |
| Set_Has_Completion (Proc_Id); |
| |
| if not Debug_Generated_Code then |
| Set_Debug_Info_Off (Proc_Id); |
| end if; |
| end if; |
| end Build_Record_Init_Proc; |
| |
| ---------------------------- |
| -- Build_Slice_Assignment -- |
| ---------------------------- |
| |
| -- Generates the following subprogram: |
| |
| -- procedure Assign |
| -- (Source, Target : Array_Type, |
| -- Left_Lo, Left_Hi, Right_Lo, Right_Hi : Index; |
| -- Rev : Boolean) |
| -- is |
| -- Li1 : Index; |
| -- Ri1 : Index; |
| |
| -- begin |
| -- if Rev then |
| -- Li1 := Left_Hi; |
| -- Ri1 := Right_Hi; |
| -- else |
| -- Li1 := Left_Lo; |
| -- Ri1 := Right_Lo; |
| -- end if; |
| |
| -- loop |
| -- if Rev then |
| -- exit when Li1 < Left_Lo; |
| -- else |
| -- exit when Li1 > Left_Hi; |
| -- end if; |
| |
| -- Target (Li1) := Source (Ri1); |
| |
| -- if Rev then |
| -- Li1 := Index'pred (Li1); |
| -- Ri1 := Index'pred (Ri1); |
| -- else |
| -- Li1 := Index'succ (Li1); |
| -- Ri1 := Index'succ (Ri1); |
| -- end if; |
| -- end loop; |
| -- end Assign; |
| |
| procedure Build_Slice_Assignment (Typ : Entity_Id) is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); |
| |
| -- Build formal parameters of procedure |
| |
| Larray : constant Entity_Id := |
| Make_Defining_Identifier |
| (Loc, Chars => New_Internal_Name ('A')); |
| Rarray : constant Entity_Id := |
| Make_Defining_Identifier |
| (Loc, Chars => New_Internal_Name ('R')); |
| Left_Lo : constant Entity_Id := |
| Make_Defining_Identifier |
| (Loc, Chars => New_Internal_Name ('L')); |
| Left_Hi : constant Entity_Id := |
| Make_Defining_Identifier |
| (Loc, Chars => New_Internal_Name ('L')); |
| Right_Lo : constant Entity_Id := |
| Make_Defining_Identifier |
| (Loc, Chars => New_Internal_Name ('R')); |
| Right_Hi : constant Entity_Id := |
| Make_Defining_Identifier |
| (Loc, Chars => New_Internal_Name ('R')); |
| Rev : constant Entity_Id := |
| Make_Defining_Identifier |
| (Loc, Chars => New_Internal_Name ('D')); |
| Proc_Name : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Make_TSS_Name (Typ, TSS_Slice_Assign)); |
| |
| Lnn : constant Entity_Id := |
| Make_Defining_Identifier (Loc, New_Internal_Name ('L')); |
| Rnn : constant Entity_Id := |
| Make_Defining_Identifier (Loc, New_Internal_Name ('R')); |
| -- Subscripts for left and right sides |
| |
| Decls : List_Id; |
| Loops : Node_Id; |
| Stats : List_Id; |
| |
| begin |
| -- Build declarations for indices |
| |
| Decls := New_List; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Lnn, |
| Object_Definition => |
| New_Occurrence_Of (Index, Loc))); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Rnn, |
| Object_Definition => |
| New_Occurrence_Of (Index, Loc))); |
| |
| Stats := New_List; |
| |
| -- Build initializations for indices |
| |
| declare |
| F_Init : constant List_Id := New_List; |
| B_Init : constant List_Id := New_List; |
| |
| begin |
| Append_To (F_Init, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Lnn, Loc), |
| Expression => New_Occurrence_Of (Left_Lo, Loc))); |
| |
| Append_To (F_Init, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Rnn, Loc), |
| Expression => New_Occurrence_Of (Right_Lo, Loc))); |
| |
| Append_To (B_Init, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Lnn, Loc), |
| Expression => New_Occurrence_Of (Left_Hi, Loc))); |
| |
| Append_To (B_Init, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Rnn, Loc), |
| Expression => New_Occurrence_Of (Right_Hi, Loc))); |
| |
| Append_To (Stats, |
| Make_If_Statement (Loc, |
| Condition => New_Occurrence_Of (Rev, Loc), |
| Then_Statements => B_Init, |
| Else_Statements => F_Init)); |
| end; |
| |
| -- Now construct the assignment statement |
| |
| Loops := |
| Make_Loop_Statement (Loc, |
| Statements => New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Indexed_Component (Loc, |
| Prefix => New_Occurrence_Of (Larray, Loc), |
| Expressions => New_List (New_Occurrence_Of (Lnn, Loc))), |
| Expression => |
| Make_Indexed_Component (Loc, |
| Prefix => New_Occurrence_Of (Rarray, Loc), |
| Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))), |
| End_Label => Empty); |
| |
| -- Build exit condition |
| |
| declare |
| F_Ass : constant List_Id := New_List; |
| B_Ass : constant List_Id := New_List; |
| |
| begin |
| Append_To (F_Ass, |
| Make_Exit_Statement (Loc, |
| Condition => |
| Make_Op_Gt (Loc, |
| Left_Opnd => New_Occurrence_Of (Lnn, Loc), |
| Right_Opnd => New_Occurrence_Of (Left_Hi, Loc)))); |
| |
| Append_To (B_Ass, |
| Make_Exit_Statement (Loc, |
| Condition => |
| Make_Op_Lt (Loc, |
| Left_Opnd => New_Occurrence_Of (Lnn, Loc), |
| Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)))); |
| |
| Prepend_To (Statements (Loops), |
| Make_If_Statement (Loc, |
| Condition => New_Occurrence_Of (Rev, Loc), |
| Then_Statements => B_Ass, |
| Else_Statements => F_Ass)); |
| end; |
| |
| -- Build the increment/decrement statements |
| |
| declare |
| F_Ass : constant List_Id := New_List; |
| B_Ass : constant List_Id := New_List; |
| |
| begin |
| Append_To (F_Ass, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Lnn, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Index, Loc), |
| Attribute_Name => Name_Succ, |
| Expressions => New_List ( |
| New_Occurrence_Of (Lnn, Loc))))); |
| |
| Append_To (F_Ass, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Rnn, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Index, Loc), |
| Attribute_Name => Name_Succ, |
| Expressions => New_List ( |
| New_Occurrence_Of (Rnn, Loc))))); |
| |
| Append_To (B_Ass, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Lnn, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Index, Loc), |
| Attribute_Name => Name_Pred, |
| Expressions => New_List ( |
| New_Occurrence_Of (Lnn, Loc))))); |
| |
| Append_To (B_Ass, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Rnn, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Index, Loc), |
| Attribute_Name => Name_Pred, |
| Expressions => New_List ( |
| New_Occurrence_Of (Rnn, Loc))))); |
| |
| Append_To (Statements (Loops), |
| Make_If_Statement (Loc, |
| Condition => New_Occurrence_Of (Rev, Loc), |
| Then_Statements => B_Ass, |
| Else_Statements => F_Ass)); |
| end; |
| |
| Append_To (Stats, Loops); |
| |
| declare |
| Spec : Node_Id; |
| Formals : List_Id := New_List; |
| |
| begin |
| Formals := New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Larray, |
| Out_Present => True, |
| Parameter_Type => |
| New_Reference_To (Base_Type (Typ), Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Rarray, |
| Parameter_Type => |
| New_Reference_To (Base_Type (Typ), Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Left_Lo, |
| Parameter_Type => |
| New_Reference_To (Index, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Left_Hi, |
| Parameter_Type => |
| New_Reference_To (Index, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Right_Lo, |
| Parameter_Type => |
| New_Reference_To (Index, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Right_Hi, |
| Parameter_Type => |
| New_Reference_To (Index, Loc))); |
| |
| Append_To (Formals, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Rev, |
| Parameter_Type => |
| New_Reference_To (Standard_Boolean, Loc))); |
| |
| Spec := |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Proc_Name, |
| Parameter_Specifications => Formals); |
| |
| Discard_Node ( |
| Make_Subprogram_Body (Loc, |
| Specification => Spec, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stats))); |
| end; |
| |
| Set_TSS (Typ, Proc_Name); |
| Set_Is_Pure (Proc_Name); |
| end Build_Slice_Assignment; |
| |
| ------------------------------------ |
| -- Build_Variant_Record_Equality -- |
| ------------------------------------ |
| |
| -- Generates: |
| |
| -- function _Equality (X, Y : T) return Boolean is |
| -- begin |
| -- -- Compare discriminants |
| |
| -- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then |
| -- return False; |
| -- end if; |
| |
| -- -- Compare components |
| |
| -- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then |
| -- return False; |
| -- end if; |
| |
| -- -- Compare variant part |
| |
| -- case X.D1 is |
| -- when V1 => |
| -- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then |
| -- return False; |
| -- end if; |
| -- ... |
| -- when Vn => |
| -- if False or else X.Cn /= Y.Cn then |
| -- return False; |
| -- end if; |
| -- end case; |
| -- return True; |
| -- end _Equality; |
| |
| procedure Build_Variant_Record_Equality (Typ : Entity_Id) is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| |
| F : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Make_TSS_Name (Typ, TSS_Composite_Equality)); |
| |
| X : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Name_X); |
| |
| Y : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Name_Y); |
| |
| Def : constant Node_Id := Parent (Typ); |
| Comps : constant Node_Id := Component_List (Type_Definition (Def)); |
| Stmts : constant List_Id := New_List; |
| Pspecs : constant List_Id := New_List; |
| |
| begin |
| -- Derived Unchecked_Union types no longer inherit the equality function |
| -- of their parent. |
| |
| if Is_Derived_Type (Typ) |
| and then not Is_Unchecked_Union (Typ) |
| and then not Has_New_Non_Standard_Rep (Typ) |
| then |
| declare |
| Parent_Eq : constant Entity_Id := |
| TSS (Root_Type (Typ), TSS_Composite_Equality); |
| |
| begin |
| if Present (Parent_Eq) then |
| Copy_TSS (Parent_Eq, Typ); |
| return; |
| end if; |
| end; |
| end if; |
| |
| Discard_Node ( |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => F, |
| Parameter_Specifications => Pspecs, |
| Result_Definition => New_Reference_To (Standard_Boolean, Loc)), |
| Declarations => New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stmts))); |
| |
| Append_To (Pspecs, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => X, |
| Parameter_Type => New_Reference_To (Typ, Loc))); |
| |
| Append_To (Pspecs, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Y, |
| Parameter_Type => New_Reference_To (Typ, Loc))); |
| |
| -- Unchecked_Unions require additional machinery to support equality. |
| -- Two extra parameters (A and B) are added to the equality function |
| -- parameter list in order to capture the inferred values of the |
| -- discriminants in later calls. |
| |
| if Is_Unchecked_Union (Typ) then |
| declare |
| Discr_Type : constant Node_Id := Etype (First_Discriminant (Typ)); |
| |
| A : constant Node_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Name_A); |
| |
| B : constant Node_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Name_B); |
| |
| begin |
| -- Add A and B to the parameter list |
| |
| Append_To (Pspecs, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => A, |
| Parameter_Type => New_Reference_To (Discr_Type, Loc))); |
| |
| Append_To (Pspecs, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => B, |
| Parameter_Type => New_Reference_To (Discr_Type, Loc))); |
| |
| -- Generate the following header code to compare the inferred |
| -- discriminants: |
| |
| -- if a /= b then |
| -- return False; |
| -- end if; |
| |
| Append_To (Stmts, |
| Make_If_Statement (Loc, |
| Condition => |
| Make_Op_Ne (Loc, |
| Left_Opnd => New_Reference_To (A, Loc), |
| Right_Opnd => New_Reference_To (B, Loc)), |
| Then_Statements => New_List ( |
| Make_Return_Statement (Loc, |
| Expression => New_Occurrence_Of (Standard_False, Loc))))); |
| |
| -- Generate component-by-component comparison. Note that we must |
| -- propagate one of the inferred discriminant formals to act as |
| -- the case statement switch. |
| |
| Append_List_To (Stmts, |
| Make_Eq_Case (Typ, Comps, A)); |
| |
| end; |
| |
| -- Normal case (not unchecked union) |
| |
| else |
| Append_To (Stmts, |
| Make_Eq_If (Typ, |
| Discriminant_Specifications (Def))); |
| |
| Append_List_To (Stmts, |
| Make_Eq_Case (Typ, Comps)); |
| end if; |
| |
| Append_To (Stmts, |
| Make_Return_Statement (Loc, |
| Expression => New_Reference_To (Standard_True, Loc))); |
| |
| Set_TSS (Typ, F); |
| Set_Is_Pure (F); |
| |
| if not Debug_Generated_Code then |
| Set_Debug_Info_Off (F); |
| end if; |
| end Build_Variant_Record_Equality; |
| |
| ----------------------------- |
| -- Check_Stream_Attributes -- |
| ----------------------------- |
| |
| procedure Check_Stream_Attributes (Typ : Entity_Id) is |
| Comp : Entity_Id; |
| Par_Read : constant Boolean := |
| Stream_Attribute_Available (Typ, TSS_Stream_Read) |
| and then not Has_Specified_Stream_Read (Typ); |
| Par_Write : constant Boolean := |
| Stream_Attribute_Available (Typ, TSS_Stream_Write) |
| and then not Has_Specified_Stream_Write (Typ); |
| |
| procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type); |
| -- Check that Comp has a user-specified Nam stream attribute |
| |
| ---------------- |
| -- Check_Attr -- |
| ---------------- |
| |
| procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is |
| begin |
| if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then |
| Error_Msg_Name_1 := Nam; |
| Error_Msg_N |
| ("|component& in limited extension must have% attribute", Comp); |
| end if; |
| end Check_Attr; |
| |
| -- Start of processing for Check_Stream_Attributes |
| |
| begin |
| if Par_Read or else Par_Write then |
| Comp := First_Component (Typ); |
| while Present (Comp) loop |
| if Comes_From_Source (Comp) |
| and then Original_Record_Component (Comp) = Comp |
| and then Is_Limited_Type (Etype (Comp)) |
| then |
| if Par_Read then |
| Check_Attr (Name_Read, TSS_Stream_Read); |
| end if; |
| |
| if Par_Write then |
| Check_Attr (Name_Write, TSS_Stream_Write); |
| end if; |
| end if; |
| |
| Next_Component (Comp); |
| end loop; |
| end if; |
| end Check_Stream_Attributes; |
| |
| ----------------------------- |
| -- Expand_Record_Extension -- |
| ----------------------------- |
| |
| -- Add a field _parent at the beginning of the record extension. This is |
| -- used to implement inheritance. Here are some examples of expansion: |
| |
| -- 1. no discriminants |
| -- type T2 is new T1 with null record; |
| -- gives |
| -- type T2 is new T1 with record |
| -- _Parent : T1; |
| -- end record; |
| |
| -- 2. renamed discriminants |
| -- type T2 (B, C : Int) is new T1 (A => B) with record |
| -- _Parent : T1 (A => B); |
| -- D : Int; |
| -- end; |
| |
| -- 3. inherited discriminants |
| -- type T2 is new T1 with record -- discriminant A inherited |
| -- _Parent : T1 (A); |
| -- D : Int; |
| -- end; |
| |
| procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is |
| Indic : constant Node_Id := Subtype_Indication (Def); |
| Loc : constant Source_Ptr := Sloc (Def); |
| Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); |
| Par_Subtype : Entity_Id; |
| Comp_List : Node_Id; |
| Comp_Decl : Node_Id; |
| Parent_N : Node_Id; |
| D : Entity_Id; |
| List_Constr : constant List_Id := New_List; |
| |
| begin |
| -- Expand_Record_Extension is called directly from the semantics, so |
| -- we must check to see whether expansion is active before proceeding |
| |
| if not Expander_Active then |
| return; |
| end if; |
| |
| -- This may be a derivation of an untagged private type whose full |
| -- view is tagged, in which case the Derived_Type_Definition has no |
| -- extension part. Build an empty one now. |
| |
| if No (Rec_Ext_Part) then |
| Rec_Ext_Part := |
| Make_Record_Definition (Loc, |
| End_Label => Empty, |
| Component_List => Empty, |
| Null_Present => True); |
| |
| Set_Record_Extension_Part (Def, Rec_Ext_Part); |
| Mark_Rewrite_Insertion (Rec_Ext_Part); |
| end if; |
| |
| Comp_List := Component_List (Rec_Ext_Part); |
| |
| Parent_N := Make_Defining_Identifier (Loc, Name_uParent); |
| |
| -- If the derived type inherits its discriminants the type of the |
| -- _parent field must be constrained by the inherited discriminants |
| |
| if Has_Discriminants (T) |
| and then Nkind (Indic) /= N_Subtype_Indication |
| and then not Is_Constrained (Entity (Indic)) |
| then |
| D := First_Discriminant (T); |
| while Present (D) loop |
| Append_To (List_Constr, New_Occurrence_Of (D, Loc)); |
| Next_Discriminant (D); |
| end loop; |
| |
| Par_Subtype := |
| Process_Subtype ( |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => New_Reference_To (Entity (Indic), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => List_Constr)), |
| Def); |
| |
| -- Otherwise the original subtype_indication is just what is needed |
| |
| else |
| Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); |
| end if; |
| |
| Set_Parent_Subtype (T, Par_Subtype); |
| |
| Comp_Decl := |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => Parent_N, |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => False, |
| Subtype_Indication => New_Reference_To (Par_Subtype, Loc))); |
| |
| if Null_Present (Rec_Ext_Part) then |
| Set_Component_List (Rec_Ext_Part, |
| Make_Component_List (Loc, |
| Component_Items => New_List (Comp_Decl), |
| Variant_Part => Empty, |
| Null_Present => False)); |
| Set_Null_Present (Rec_Ext_Part, False); |
| |
| elsif Null_Present (Comp_List) |
| or else Is_Empty_List (Component_Items (Comp_List)) |
| then |
| Set_Component_Items (Comp_List, New_List (Comp_Decl)); |
| Set_Null_Present (Comp_List, False); |
| |
| else |
| Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); |
| end if; |
| |
| Analyze (Comp_Decl); |
| end Expand_Record_Extension; |
| |
| ------------------------------------ |
| -- Expand_N_Full_Type_Declaration -- |
| ------------------------------------ |
| |
| procedure Expand_N_Full_Type_Declaration (N : Node_Id) is |
| Def_Id : constant Entity_Id := Defining_Identifier (N); |
| B_Id : constant Entity_Id := Base_Type (Def_Id); |
| Par_Id : Entity_Id; |
| FN : Node_Id; |
| |
| begin |
| if Is_Access_Type (Def_Id) then |
| |
| -- Anonymous access types are created for the components of the |
| -- record parameter for an entry declaration. No master is created |
| -- for such a type. |
| |
| if Has_Task (Designated_Type (Def_Id)) |
| and then Comes_From_Source (N) |
| then |
| Build_Master_Entity (Def_Id); |
| Build_Master_Renaming (Parent (Def_Id), Def_Id); |
| |
| -- Create a class-wide master because a Master_Id must be generated |
| -- for access-to-limited-class-wide types whose root may be extended |
| -- with task components, and for access-to-limited-interfaces because |
| -- they can be used to reference tasks implementing such interface. |
| |
| elsif Is_Class_Wide_Type (Designated_Type (Def_Id)) |
| and then (Is_Limited_Type (Designated_Type (Def_Id)) |
| or else |
| (Is_Interface (Designated_Type (Def_Id)) |
| and then |
| Is_Limited_Interface (Designated_Type (Def_Id)))) |
| and then Tasking_Allowed |
| |
| -- Do not create a class-wide master for types whose convention is |
| -- Java since these types cannot embed Ada tasks anyway. Note that |
| -- the following test cannot catch the following case: |
| |
| -- package java.lang.Object is |
| -- type Typ is tagged limited private; |
| -- type Ref is access all Typ'Class; |
| -- private |
| -- type Typ is tagged limited ...; |
| -- pragma Convention (Typ, Java) |
| -- end; |
| |
| -- Because the convention appears after we have done the |
| -- processing for type Ref. |
| |
| and then Convention (Designated_Type (Def_Id)) /= Convention_Java |
| then |
| Build_Class_Wide_Master (Def_Id); |
| |
| elsif Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then |
| Expand_Access_Protected_Subprogram_Type (N); |
| end if; |
| |
| elsif Has_Task (Def_Id) then |
| Expand_Previous_Access_Type (Def_Id); |
| end if; |
| |
| Par_Id := Etype (B_Id); |
| |
| -- The parent type is private then we need to inherit |
| -- any TSS operations from the full view. |
| |
| if Ekind (Par_Id) in Private_Kind |
| and then Present (Full_View (Par_Id)) |
| then |
| Par_Id := Base_Type (Full_View (Par_Id)); |
| end if; |
| |
| if Nkind (Type_Definition (Original_Node (N))) |
| = N_Derived_Type_Definition |
| and then not Is_Tagged_Type (Def_Id) |
| and then Present (Freeze_Node (Par_Id)) |
| and then Present (TSS_Elist (Freeze_Node (Par_Id))) |
| then |
| Ensure_Freeze_Node (B_Id); |
| FN := Freeze_Node (B_Id); |
| |
| if No (TSS_Elist (FN)) then |
| Set_TSS_Elist (FN, New_Elmt_List); |
| end if; |
| |
| declare |
| T_E : constant Elist_Id := TSS_Elist (FN); |
| Elmt : Elmt_Id; |
| |
| begin |
| Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id))); |
| |
| while Present (Elmt) loop |
| if Chars (Node (Elmt)) /= Name_uInit then |
| Append_Elmt (Node (Elmt), T_E); |
| end if; |
| |
| Next_Elmt (Elmt); |
| end loop; |
| |
| -- If the derived type itself is private with a full view, then |
| -- associate the full view with the inherited TSS_Elist as well. |
| |
| if Ekind (B_Id) in Private_Kind |
| and then Present (Full_View (B_Id)) |
| then |
| Ensure_Freeze_Node (Base_Type (Full_View (B_Id))); |
| Set_TSS_Elist |
| (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN)); |
| end if; |
| end; |
| end if; |
| end Expand_N_Full_Type_Declaration; |
| |
| --------------------------------- |
| -- Expand_N_Object_Declaration -- |
| --------------------------------- |
| |
| -- First we do special processing for objects of a tagged type where this |
| -- is the point at which the type is frozen. The creation of the dispatch |
| -- table and the initialization procedure have to be deferred to this |
| -- point, since we reference previously declared primitive subprograms. |
| |
| -- For all types, we call an initialization procedure if there is one |
| |
| procedure Expand_N_Object_Declaration (N : Node_Id) is |
| Def_Id : constant Entity_Id := Defining_Identifier (N); |
| Typ : constant Entity_Id := Etype (Def_Id); |
| Loc : constant Source_Ptr := Sloc (N); |
| Expr : constant Node_Id := Expression (N); |
| New_Ref : Node_Id; |
| Id_Ref : Node_Id; |
| Expr_Q : Node_Id; |
| |
| begin |
| -- Don't do anything for deferred constants. All proper actions will |
| -- be expanded during the full declaration. |
| |
| if No (Expr) and Constant_Present (N) then |
| return; |
| end if; |
| |
| -- Make shared memory routines for shared passive variable |
| |
| if Is_Shared_Passive (Def_Id) then |
| Make_Shared_Var_Procs (N); |
| end if; |
| |
| -- If tasks being declared, make sure we have an activation chain |
| -- defined for the tasks (has no effect if we already have one), and |
| -- also that a Master variable is established and that the appropriate |
| -- enclosing construct is established as a task master. |
| |
| if Has_Task (Typ) then |
| Build_Activation_Chain_Entity (N); |
| Build_Master_Entity (Def_Id); |
| end if; |
| |
| -- Default initialization required, and no expression present |
| |
| if No (Expr) then |
| |
| -- Expand Initialize call for controlled objects. One may wonder why |
| -- the Initialize Call is not done in the regular Init procedure |
| -- attached to the record type. That's because the init procedure is |
| -- recursively called on each component, including _Parent, thus the |
| -- Init call for a controlled object would generate not only one |
| -- Initialize call as it is required but one for each ancestor of |
| -- its type. This processing is suppressed if No_Initialization set. |
| |
| if not Controlled_Type (Typ) |
| or else No_Initialization (N) |
| then |
| null; |
| |
| elsif not Abort_Allowed |
| or else not Comes_From_Source (N) |
| then |
| Insert_Actions_After (N, |
| Make_Init_Call ( |
| Ref => New_Occurrence_Of (Def_Id, Loc), |
| Typ => Base_Type (Typ), |
| Flist_Ref => Find_Final_List (Def_Id), |
| With_Attach => Make_Integer_Literal (Loc, 1))); |
| |
| -- Abort allowed |
| |
| else |
| -- We need to protect the initialize call |
| |
| -- begin |
| -- Defer_Abort.all; |
| -- Initialize (...); |
| -- at end |
| -- Undefer_Abort.all; |
| -- end; |
| |
| -- ??? this won't protect the initialize call for controlled |
| -- components which are part of the init proc, so this block |
| -- should probably also contain the call to _init_proc but this |
| -- requires some code reorganization... |
| |
| declare |
| L : constant List_Id := |
| Make_Init_Call ( |
| Ref => New_Occurrence_Of (Def_Id, Loc), |
| Typ => Base_Type (Typ), |
| Flist_Ref => Find_Final_List (Def_Id), |
| With_Attach => Make_Integer_Literal (Loc, 1)); |
| |
| Blk : constant Node_Id := |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, L)); |
| |
| begin |
| Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer)); |
| Set_At_End_Proc (Handled_Statement_Sequence (Blk), |
| New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); |
| Insert_Actions_After (N, New_List (Blk)); |
| Expand_At_End_Handler |
| (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); |
| end; |
| end if; |
| |
| -- Call type initialization procedure if there is one. We build the |
| -- call and put it immediately after the object declaration, so that |
| -- it will be expanded in the usual manner. Note that this will |
| -- result in proper handling of defaulted discriminants. The call |
| -- to the Init_Proc is suppressed if No_Initialization is set. |
| |
| if Has_Non_Null_Base_Init_Proc (Typ) |
| and then not No_Initialization (N) |
| then |
| -- The call to the initialization procedure does NOT freeze |
| -- the object being initialized. This is because the call is |
| -- not a source level call. This works fine, because the only |
| -- possible statements depending on freeze status that can |
| -- appear after the _Init call are rep clauses which can |
| -- safely appear after actual references to the object. |
| |
| Id_Ref := New_Reference_To (Def_Id, Loc); |
| Set_Must_Not_Freeze (Id_Ref); |
| Set_Assignment_OK (Id_Ref); |
| |
| Insert_Actions_After (N, |
| Build_Initialization_Call (Loc, Id_Ref, Typ)); |
| |
| -- If simple initialization is required, then set an appropriate |
| -- simple initialization expression in place. This special |
| -- initialization is required even though No_Init_Flag is present. |
| |
| -- An internally generated temporary needs no initialization because |
| -- it will be assigned subsequently. In particular, there is no |
| -- point in applying Initialize_Scalars to such a temporary. |
| |
| elsif Needs_Simple_Initialization (Typ) |
| and then not Is_Internal (Def_Id) |
| then |
| Set_No_Initialization (N, False); |
| Set_Expression (N, Get_Simple_Init_Val (Typ, Loc, Esize (Def_Id))); |
| Analyze_And_Resolve (Expression (N), Typ); |
| end if; |
| |
| -- Generate attribute for Persistent_BSS if needed |
| |
| if Persistent_BSS_Mode |
| and then Comes_From_Source (N) |
| and then Is_Potentially_Persistent_Type (Typ) |
| and then Is_Library_Level_Entity (Def_Id) |
| then |
| declare |
| Prag : Node_Id; |
| begin |
| Prag := |
| Make_Linker_Section_Pragma |
| (Def_Id, Sloc (N), ".persistent.bss"); |
| Insert_After (N, Prag); |
| Analyze (Prag); |
| end; |
| end if; |
| |
| -- If access type, then we know it is null if not initialized |
| |
| if Is_Access_Type (Typ) then |
| Set_Is_Known_Null (Def_Id); |
| end if; |
| |
| -- Explicit initialization present |
| |
| else |
| -- Obtain actual expression from qualified expression |
| |
| if Nkind (Expr) = N_Qualified_Expression then |
| Expr_Q := Expression (Expr); |
| else |
| Expr_Q := Expr; |
| end if; |
| |
| -- When we have the appropriate type of aggregate in the expression |
| -- (it has been determined during analysis of the aggregate by |
| -- setting the delay flag), let's perform in place assignment and |
| -- thus avoid creating a temporary. |
| |
| if Is_Delayed_Aggregate (Expr_Q) then |
| Convert_Aggr_In_Object_Decl (N); |
| |
| else |
| -- In most cases, we must check that the initial value meets any |
| -- constraint imposed by the declared type. However, there is one |
| -- very important exception to this rule. If the entity has an |
| -- unconstrained nominal subtype, then it acquired its constraints |
| -- from the expression in the first place, and not only does this |
| -- mean that the constraint check is not needed, but an attempt to |
| -- perform the constraint check can cause order order of |
| -- elaboration problems. |
| |
| if not Is_Constr_Subt_For_U_Nominal (Typ) then |
| |
| -- If this is an allocator for an aggregate that has been |
| -- allocated in place, delay checks until assignments are |
| -- made, because the discriminants are not initialized. |
| |
| if Nkind (Expr) = N_Allocator |
| and then No_Initialization (Expr) |
| then |
| null; |
| else |
| Apply_Constraint_Check (Expr, Typ); |
| end if; |
| end if; |
| |
| -- If the type is controlled we attach the object to the final |
| -- list and adjust the target after the copy. This |
| -- ??? incomplete sentence |
| |
| if Controlled_Type (Typ) then |
| declare |
| Flist : Node_Id; |
| F : Entity_Id; |
| |
| begin |
| -- Attach the result to a dummy final list which will never |
| -- be finalized if Delay_Finalize_Attachis set. It is |
| -- important to attach to a dummy final list rather than not |
| -- attaching at all in order to reset the pointers coming |
| -- from the initial value. Equivalent code exists in the |
| -- sec-stack case in Exp_Ch4.Expand_N_Allocator. |
| |
| if Delay_Finalize_Attach (N) then |
| F := |
| Make_Defining_Identifier (Loc, New_Internal_Name ('F')); |
| Insert_Action (N, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => F, |
| Object_Definition => |
| New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); |
| |
| Flist := New_Reference_To (F, Loc); |
| |
| else |
| Flist := Find_Final_List (Def_Id); |
| end if; |
| |
| Insert_Actions_After (N, |
| Make_Adjust_Call ( |
| Ref => New_Reference_To (Def_Id, Loc), |
| Typ => Base_Type (Typ), |
| Flist_Ref => Flist, |
| With_Attach => Make_Integer_Literal (Loc, 1))); |
| end; |
| end if; |
| |
| -- For tagged types, when an init value is given, the tag has to |
| -- be re-initialized separately in order to avoid the propagation |
| -- of a wrong tag coming from a view conversion unless the type |
| -- is class wide (in this case the tag comes from the init value). |
| -- Suppress the tag assignment when Java_VM because JVM tags are |
| -- represented implicitly in objects. Ditto for types that are |
| -- CPP_CLASS, and for initializations that are aggregates, because |
| -- they have to have the right tag. |
| |
| if Is_Tagged_Type (Typ) |
| and then not Is_Class_Wide_Type (Typ) |
| and then not Is_CPP_Class (Typ) |
| and then not Java_VM |
| and then Nkind (Expr) /= N_Aggregate |
| then |
| -- The re-assignment of the tag has to be done even if the |
| -- object is a constant. |
| |
| New_Ref := |
| Make_Selected_Component (Loc, |
| Prefix => New_Reference_To (Def_Id, Loc), |
| Selector_Name => |
| New_Reference_To (First_Tag_Component (Typ), Loc)); |
| |
| Set_Assignment_OK (New_Ref); |
| |
| Insert_After (N, |
| Make_Assignment_Statement (Loc, |
| Name => New_Ref, |
| Expression => |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To |
| (Node |
| (First_Elmt |
| (Access_Disp_Table (Base_Type (Typ)))), |
| Loc)))); |
| |
| -- For discrete types, set the Is_Known_Valid flag if the |
| -- initializing value is known to be valid. |
| |
| elsif Is_Discrete_Type (Typ) and then Expr_Known_Valid (Expr) then |
| Set_Is_Known_Valid (Def_Id); |
| |
| elsif Is_Access_Type (Typ) then |
| |
| -- For access types set the Is_Known_Non_Null flag if the |
| -- initializing value is known to be non-null. We can also set |
| -- Can_Never_Be_Null if this is a constant. |
| |
| if Known_Non_Null (Expr) then |
| Set_Is_Known_Non_Null (Def_Id, True); |
| |
| if Constant_Present (N) then |
| Set_Can_Never_Be_Null (Def_Id); |
| end if; |
| end if; |
| end if; |
| |
| -- If validity checking on copies, validate initial expression |
| |
| if Validity_Checks_On |
| and then Validity_Check_Copies |
| then |
| Ensure_Valid (Expr); |
| Set_Is_Known_Valid (Def_Id); |
| end if; |
| end if; |
| |
| -- Cases where the back end cannot handle the initialization directly |
| -- In such cases, we expand an assignment that will be appropriately |
| -- handled by Expand_N_Assignment_Statement. |
| |
| -- The exclusion of the unconstrained case is wrong, but for now it |
| -- is too much trouble ??? |
| |
| if (Is_Possibly_Unaligned_Slice (Expr) |
| or else (Is_Possibly_Unaligned_Object (Expr) |
| and then not Represented_As_Scalar (Etype (Expr)))) |
| |
| -- The exclusion of the unconstrained case is wrong, but for now |
| -- it is too much trouble ??? |
| |
| and then not (Is_Array_Type (Etype (Expr)) |
| and then not Is_Constrained (Etype (Expr))) |
| then |
| declare |
| Stat : constant Node_Id := |
| Make_Assignment_Statement (Loc, |
| Name => New_Reference_To (Def_Id, Loc), |
| Expression => Relocate_Node (Expr)); |
| begin |
| Set_Expression (N, Empty); |
| Set_No_Initialization (N); |
| Set_Assignment_OK (Name (Stat)); |
| Set_No_Ctrl_Actions (Stat); |
| Insert_After (N, Stat); |
| Analyze (Stat); |
| end; |
| end if; |
| end if; |
| |
| -- For array type, check for size too large |
| -- We really need this for record types too??? |
| |
| if Is_Array_Type (Typ) then |
| Apply_Array_Size_Check (N, Typ); |
| end if; |
| |
| exception |
| when RE_Not_Available => |
| return; |
| end Expand_N_Object_Declaration; |
| |
| --------------------------------- |
| -- Expand_N_Subtype_Indication -- |
| --------------------------------- |
| |
| -- Add a check on the range of the subtype. The static case is partially |
| -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need |
| -- to check here for the static case in order to avoid generating |
| -- extraneous expanded code. |
| |
| procedure Expand_N_Subtype_Indication (N : Node_Id) is |
| Ran : constant Node_Id := Range_Expression (Constraint (N)); |
| Typ : constant Entity_Id := Entity (Subtype_Mark (N)); |
| |
| begin |
| if Nkind (Parent (N)) = N_Constrained_Array_Definition or else |
| Nkind (Parent (N)) = N_Slice |
| then |
| Resolve (Ran, Typ); |
| Apply_Range_Check (Ran, Typ); |
| end if; |
| end Expand_N_Subtype_Indication; |
| |
| --------------------------- |
| -- Expand_N_Variant_Part -- |
| --------------------------- |
| |
| -- If the last variant does not contain the Others choice, replace it with |
| -- an N_Others_Choice node since Gigi always wants an Others. Note that we |
| -- do not bother to call Analyze on the modified variant part, since it's |
| -- only effect would be to compute the contents of the |
| -- Others_Discrete_Choices node laboriously, and of course we already know |
| -- the list of choices that corresponds to the others choice (it's the |
| -- list we are replacing!) |
| |
| procedure Expand_N_Variant_Part (N : Node_Id) is |
| Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N)); |
| Others_Node : Node_Id; |
| begin |
| if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then |
| Others_Node := Make_Others_Choice (Sloc (Last_Var)); |
| Set_Others_Discrete_Choices |
| (Others_Node, Discrete_Choices (Last_Var)); |
| Set_Discrete_Choices (Last_Var, New_List (Others_Node)); |
| end if; |
| end Expand_N_Variant_Part; |
| |
| --------------------------------- |
| -- Expand_Previous_Access_Type -- |
| --------------------------------- |
| |
| procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is |
| T : Entity_Id := First_Entity (Current_Scope); |
| |
| begin |
| -- Find all access types declared in the current scope, whose |
| -- designated type is Def_Id. |
| |
| while Present (T) loop |
| if Is_Access_Type (T) |
| and then Designated_Type (T) = Def_Id |
| then |
| Build_Master_Entity (Def_Id); |
| Build_Master_Renaming (Parent (Def_Id), T); |
| end if; |
| |
| Next_Entity (T); |
| end loop; |
| end Expand_Previous_Access_Type; |
| |
| ------------------------------ |
| -- Expand_Record_Controller -- |
| ------------------------------ |
| |
| procedure Expand_Record_Controller (T : Entity_Id) is |
| Def : Node_Id := Type_Definition (Parent (T)); |
| Comp_List : Node_Id; |
| Comp_Decl : Node_Id; |
| Loc : Source_Ptr; |
| First_Comp : Node_Id; |
| Controller_Type : Entity_Id; |
| Ent : Entity_Id; |
| |
| begin |
| if Nkind (Def) = N_Derived_Type_Definition then |
| Def := Record_Extension_Part (Def); |
| end if; |
| |
| if Null_Present (Def) then |
| Set_Component_List (Def, |
| Make_Component_List (Sloc (Def), |
| Component_Items => Empty_List, |
| Variant_Part => Empty, |
| Null_Present => True)); |
| end if; |
| |
| Comp_List := Component_List (Def); |
| |
| if Null_Present (Comp_List) |
| or else Is_Empty_List (Component_Items (Comp_List)) |
| then |
| Loc := Sloc (Comp_List); |
| else |
| Loc := Sloc (First (Component_Items (Comp_List))); |
| end if; |
| |
| if Is_Return_By_Reference_Type (T) then |
| Controller_Type := RTE (RE_Limited_Record_Controller); |
| else |
| Controller_Type := RTE (RE_Record_Controller); |
| end if; |
| |
| Ent := Make_Defining_Identifier (Loc, Name_uController); |
| |
| Comp_Decl := |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => Ent, |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => False, |
| Subtype_Indication => New_Reference_To (Controller_Type, Loc))); |
| |
| if Null_Present (Comp_List) |
| or else Is_Empty_List (Component_Items (Comp_List)) |
| then |
| Set_Component_Items (Comp_List, New_List (Comp_Decl)); |
| Set_Null_Present (Comp_List, False); |
| |
| else |
| -- The controller cannot be placed before the _Parent field since |
| -- gigi lays out field in order and _parent must be first to |
| -- preserve the polymorphism of tagged types. |
| |
| First_Comp := First (Component_Items (Comp_List)); |
| |
| if Chars (Defining_Identifier (First_Comp)) /= Name_uParent |
| and then Chars (Defining_Identifier (First_Comp)) /= Name_uTag |
| then |
| Insert_Before (First_Comp, Comp_Decl); |
| else |
| Insert_After (First_Comp, Comp_Decl); |
| end if; |
| end if; |
| |
| New_Scope (T); |
| Analyze (Comp_Decl); |
| Set_Ekind (Ent, E_Component); |
| Init_Component_Location (Ent); |
| |
| -- Move the _controller entity ahead in the list of internal entities |
| -- of the enclosing record so that it is selected instead of a |
| -- potentially inherited one. |
| |
| declare |
| E : constant Entity_Id := Last_Entity (T); |
| Comp : Entity_Id; |
| |
| begin |
| pragma Assert (Chars (E) = Name_uController); |
| |
| Set_Next_Entity (E, First_Entity (T)); |
| Set_First_Entity (T, E); |
| |
| Comp := Next_Entity (E); |
| while Next_Entity (Comp) /= E loop |
| Next_Entity (Comp); |
| end loop; |
| |
| Set_Next_Entity (Comp, Empty); |
| Set_Last_Entity (T, Comp); |
| end; |
| |
| End_Scope; |
| |
| exception |
| when RE_Not_Available => |
| return; |
| end Expand_Record_Controller; |
| |
| ------------------------ |
| -- Expand_Tagged_Root -- |
| ------------------------ |
| |
| procedure Expand_Tagged_Root (T : Entity_Id) is |
| Def : constant Node_Id := Type_Definition (Parent (T)); |
| Comp_List : Node_Id; |
| Comp_Decl : Node_Id; |
| Sloc_N : Source_Ptr; |
| |
| begin |
| if Null_Present (Def) then |
| Set_Component_List (Def, |
| Make_Component_List (Sloc (Def), |
| Component_Items => Empty_List, |
| Variant_Part => Empty, |
| Null_Present => True)); |
| end if; |
| |
| Comp_List := Component_List (Def); |
| |
| if Null_Present (Comp_List) |
| or else Is_Empty_List (Component_Items (Comp_List)) |
| then |
| Sloc_N := Sloc (Comp_List); |
| else |
| Sloc_N := Sloc (First (Component_Items (Comp_List))); |
| end if; |
| |
| Comp_Decl := |
| Make_Component_Declaration (Sloc_N, |
| Defining_Identifier => First_Tag_Component (T), |
| Component_Definition => |
| Make_Component_Definition (Sloc_N, |
| Aliased_Present => False, |
| Subtype_Indication => New_Reference_To (RTE (RE_Tag), Sloc_N))); |
| |
| if Null_Present (Comp_List) |
| or else Is_Empty_List (Component_Items (Comp_List)) |
| then |
| Set_Component_Items (Comp_List, New_List (Comp_Decl)); |
| Set_Null_Present (Comp_List, False); |
| |
| else |
| Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); |
| end if; |
| |
| -- We don't Analyze the whole expansion because the tag component has |
| -- already been analyzed previously. Here we just insure that the tree |
| -- is coherent with the semantic decoration |
| |
| Find_Type (Subtype_Indication (Component_Definition (Comp_Decl))); |
| |
| exception |
| when RE_Not_Available => |
| return; |
| end Expand_Tagged_Root; |
| |
| ----------------------- |
| -- Freeze_Array_Type -- |
| ----------------------- |
| |
| procedure Freeze_Array_Type (N : Node_Id) is |
| Typ : constant Entity_Id := Entity (N); |
| Base : constant Entity_Id := Base_Type (Typ); |
| |
| begin |
| if not Is_Bit_Packed_Array (Typ) then |
| |
| -- If the component contains tasks, so does the array type. This may |
| -- not be indicated in the array type because the component may have |
| -- been a private type at the point of definition. Same if component |
| -- type is controlled. |
| |
| Set_Has_Task (Base, Has_Task (Component_Type (Typ))); |
| Set_Has_Controlled_Component (Base, |
| Has_Controlled_Component (Component_Type (Typ)) |
| or else Is_Controlled (Component_Type (Typ))); |
| |
| if No (Init_Proc (Base)) then |
| |
| -- If this is an anonymous array created for a declaration with |
| -- an initial value, its init_proc will never be called. The |
| -- initial value itself may have been expanded into assign- |
| -- ments, in which case the object declaration is carries the |
| -- No_Initialization flag. |
| |
| if Is_Itype (Base) |
| and then Nkind (Associated_Node_For_Itype (Base)) = |
| N_Object_Declaration |
| and then (Present (Expression (Associated_Node_For_Itype (Base))) |
| or else |
| No_Initialization (Associated_Node_For_Itype (Base))) |
| then |
| null; |
| |
| -- We do not need an init proc for string or wide [wide] string, |
| -- since the only time these need initialization in normalize or |
| -- initialize scalars mode, and these types are treated specially |
| -- and do not need initialization procedures. |
| |
| elsif Root_Type (Base) = Standard_String |
| or else Root_Type (Base) = Standard_Wide_String |
| or else Root_Type (Base) = Standard_Wide_Wide_String |
| then |
| null; |
| |
| -- Otherwise we have to build an init proc for the subtype |
| |
| else |
| Build_Array_Init_Proc (Base, N); |
| end if; |
| end if; |
| |
| if Typ = Base and then Has_Controlled_Component (Base) then |
| Build_Controlling_Procs (Base); |
| |
| if not Is_Limited_Type (Component_Type (Typ)) |
| and then Number_Dimensions (Typ) = 1 |
| then |
| Build_Slice_Assignment (Typ); |
| end if; |
| end if; |
| |
| -- For packed case, there is a default initialization, except if the |
| -- component type is itself a packed structure with an initialization |
| -- procedure. |
| |
| elsif Present (Init_Proc (Component_Type (Base))) |
| and then No (Base_Init_Proc (Base)) |
| then |
| Build_Array_Init_Proc (Base, N); |
| end if; |
| end Freeze_Array_Type; |
| |
| ----------------------------- |
| -- Freeze_Enumeration_Type -- |
| ----------------------------- |
| |
| procedure Freeze_Enumeration_Type (N : Node_Id) is |
| Typ : constant Entity_Id := Entity (N); |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Ent : Entity_Id; |
| Lst : List_Id; |
| Num : Nat; |
| Arr : Entity_Id; |
| Fent : Entity_Id; |
| Ityp : Entity_Id; |
| Is_Contiguous : Boolean; |
| Pos_Expr : Node_Id; |
| Last_Repval : Uint; |
| |
| Func : Entity_Id; |
| pragma Warnings (Off, Func); |
| |
| begin |
| -- Various optimization are possible if the given representation is |
| -- contiguous. |
| |
| Is_Contiguous := True; |
| Ent := First_Literal (Typ); |
| Last_Repval := Enumeration_Rep (Ent); |
| Next_Literal (Ent); |
| |
| while Present (Ent) loop |
| if Enumeration_Rep (Ent) - Last_Repval /= 1 then |
| Is_Contiguous := False; |
| exit; |
| else |
| Last_Repval := Enumeration_Rep (Ent); |
| end if; |
| |
| Next_Literal (Ent); |
| end loop; |
| |
| if Is_Contiguous then |
| Set_Has_Contiguous_Rep (Typ); |
| Ent := First_Literal (Typ); |
| Num := 1; |
| Lst := New_List (New_Reference_To (Ent, Sloc (Ent))); |
| |
| else |
| -- Build list of literal references |
| |
| Lst := New_List; |
| Num := 0; |
| |
| Ent := First_Literal (Typ); |
| while Present (Ent) loop |
| Append_To (Lst, New_Reference_To (Ent, Sloc (Ent))); |
| Num := Num + 1; |
| Next_Literal (Ent); |
| end loop; |
| end if; |
| |
| -- Now build an array declaration |
| |
| -- typA : array (Natural range 0 .. num - 1) of ctype := |
| -- (v, v, v, v, v, ....) |
| |
| -- where ctype is the corresponding integer type. If the representation |
| -- is contiguous, we only keep the first literal, which provides the |
| -- offset for Pos_To_Rep computations. |
| |
| Arr := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Chars (Typ), 'A')); |
| |
| Append_Freeze_Action (Typ, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Arr, |
| Constant_Present => True, |
| |
| Object_Definition => |
| Make_Constrained_Array_Definition (Loc, |
| Discrete_Subtype_Definitions => New_List ( |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => New_Reference_To (Standard_Natural, Loc), |
| Constraint => |
| Make_Range_Constraint (Loc, |
| Range_Expression => |
| Make_Range (Loc, |
| Low_Bound => |
| Make_Integer_Literal (Loc, 0), |
| High_Bound => |
| Make_Integer_Literal (Loc, Num - 1))))), |
| |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => False, |
| Subtype_Indication => New_Reference_To (Typ, Loc))), |
| |
| Expression => |
| Make_Aggregate (Loc, |
| Expressions => Lst))); |
| |
| Set_Enum_Pos_To_Rep (Typ, Arr); |
| |
| -- Now we build the function that converts representation values to |
| -- position values. This function has the form: |
| |
| -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is |
| -- begin |
| -- case ityp!(A) is |
| -- when enum-lit'Enum_Rep => return posval; |
| -- when enum-lit'Enum_Rep => return posval; |
| -- ... |
| -- when others => |
| -- [raise Constraint_Error when F "invalid data"] |
| -- return -1; |
| -- end case; |
| -- end; |
| |
| -- Note: the F parameter determines whether the others case (no valid |
| -- representation) raises Constraint_Error or returns a unique value |
| -- of minus one. The latter case is used, e.g. in 'Valid code. |
| |
| -- Note: the reason we use Enum_Rep values in the case here is to avoid |
| -- the code generator making inappropriate assumptions about the range |
| -- of the values in the case where the value is invalid. ityp is a |
| -- signed or unsigned integer type of appropriate width. |
| |
| -- Note: if exceptions are not supported, then we suppress the raise |
| -- and return -1 unconditionally (this is an erroneous program in any |
| -- case and there is no obligation to raise Constraint_Error here!) We |
| -- also do this if pragma Restrictions (No_Exceptions) is active. |
| |
| -- Representations are signed |
| |
| if Enumeration_Rep (First_Literal (Typ)) < 0 then |
| |
| -- The underlying type is signed. Reset the Is_Unsigned_Type |
| -- explicitly, because it might have been inherited from |
| -- parent type. |
| |
| Set_Is_Unsigned_Type (Typ, False); |
| |
| if Esize (Typ) <= Standard_Integer_Size then |
| Ityp := Standard_Integer; |
| else |
| Ityp := Universal_Integer; |
| end if; |
| |
| -- Representations are unsigned |
| |
| else |
| if Esize (Typ) <= Standard_Integer_Size then |
| Ityp := RTE (RE_Unsigned); |
| else |
| Ityp := RTE (RE_Long_Long_Unsigned); |
| end if; |
| end if; |
| |
| -- The body of the function is a case statement. First collect case |
| -- alternatives, or optimize the contiguous case. |
| |
| Lst := New_List; |
| |
| -- If representation is contiguous, Pos is computed by subtracting |
| -- the representation of the first literal. |
| |
| if Is_Contiguous then |
| Ent := First_Literal (Typ); |
| |
| if Enumeration_Rep (Ent) = Last_Repval then |
| |
| -- Another special case: for a single literal, Pos is zero |
| |
| Pos_Expr := Make_Integer_Literal (Loc, Uint_0); |
| |
| else |
| Pos_Expr := |
| Convert_To (Standard_Integer, |
| Make_Op_Subtract (Loc, |
| Left_Opnd => |
| Unchecked_Convert_To (Ityp, |
| Make_Identifier (Loc, Name_uA)), |
| Right_Opnd => |
| Make_Integer_Literal (Loc, |
| Intval => |
| Enumeration_Rep (First_Literal (Typ))))); |
| end if; |
| |
| Append_To (Lst, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List ( |
| Make_Range (Sloc (Enumeration_Rep_Expr (Ent)), |
| Low_Bound => |
| Make_Integer_Literal (Loc, |
| Intval => Enumeration_Rep (Ent)), |
| High_Bound => |
| Make_Integer_Literal (Loc, Intval => Last_Repval))), |
| |
| Statements => New_List ( |
| Make_Return_Statement (Loc, |
| Expression => Pos_Expr)))); |
| |
| else |
| Ent := First_Literal (Typ); |
| |
| while Present (Ent) loop |
| Append_To (Lst, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List ( |
| Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)), |
| Intval => Enumeration_Rep (Ent))), |
| |
| Statements => New_List ( |
| Make_Return_Statement (Loc, |
| Expression => |
| Make_Integer_Literal (Loc, |
| Intval => Enumeration_Pos (Ent)))))); |
| |
| Next_Literal (Ent); |
| end loop; |
| end if; |
| |
| -- In normal mode, add the others clause with the test |
| |
| if not Restriction_Active (No_Exception_Handlers) then |
| Append_To (Lst, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List (Make_Others_Choice (Loc)), |
| Statements => New_List ( |
| Make_Raise_Constraint_Error (Loc, |
| Condition => Make_Identifier (Loc, Name_uF), |
| Reason => CE_Invalid_Data), |
| Make_Return_Statement (Loc, |
| Expression => |
| Make_Integer_Literal (Loc, -1))))); |
| |
| -- If Restriction (No_Exceptions_Handlers) is active then we always |
| -- return -1 (since we cannot usefully raise Constraint_Error in |
| -- this case). See description above for further details. |
| |
| else |
| Append_To (Lst, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List (Make_Others_Choice (Loc)), |
| Statements => New_List ( |
| Make_Return_Statement (Loc, |
| Expression => |
| Make_Integer_Literal (Loc, -1))))); |
| end if; |
| |
| -- Now we can build the function body |
| |
| Fent := |
| Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos)); |
| |
| Func := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Fent, |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uA), |
| Parameter_Type => New_Reference_To (Typ, Loc)), |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uF), |
| Parameter_Type => New_Reference_To (Standard_Boolean, Loc))), |
| |
| Result_Definition => New_Reference_To (Standard_Integer, Loc)), |
| |
| Declarations => Empty_List, |
| |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_Case_Statement (Loc, |
| Expression => |
| Unchecked_Convert_To (Ityp, |
| Make_Identifier (Loc, Name_uA)), |
| Alternatives => Lst)))); |
| |
| Set_TSS (Typ, Fent); |
| Set_Is_Pure (Fent); |
| |
| if not Debug_Generated_Code then |
| Set_Debug_Info_Off (Fent); |
| end if; |
| |
| exception |
| when RE_Not_Available => |
| return; |
| end Freeze_Enumeration_Type; |
| |
| ------------------------ |
| -- Freeze_Record_Type -- |
| ------------------------ |
| |
| procedure Freeze_Record_Type (N : Node_Id) is |
| Comp : Entity_Id; |
| Def_Id : constant Node_Id := Entity (N); |
| Predef_List : List_Id; |
| Type_Decl : constant Node_Id := Parent (Def_Id); |
| |
| Renamed_Eq : Node_Id := Empty; |
| -- Could use some comments ??? |
| |
| Wrapper_Decl_List : List_Id := No_List; |
| Wrapper_Body_List : List_Id := No_List; |
| |
| begin |
| -- Build discriminant checking functions if not a derived type (for |
| -- derived types that are not tagged types, we always use the |
| -- discriminant checking functions of the parent type). However, for |
| -- untagged types the derivation may have taken place before the |
| -- parent was frozen, so we copy explicitly the discriminant checking |
| -- functions from the parent into the components of the derived type. |
| |
| if not Is_Derived_Type (Def_Id) |
| or else Has_New_Non_Standard_Rep (Def_Id) |
| or else Is_Tagged_Type (Def_Id) |
| then |
| Build_Discr_Checking_Funcs (Type_Decl); |
| |
| elsif Is_Derived_Type (Def_Id) |
| and then not Is_Tagged_Type (Def_Id) |
| |
| -- If we have a derived Unchecked_Union, we do not inherit the |
| -- discriminant checking functions from the parent type since the |
| -- discriminants are non existent. |
| |
| and then not Is_Unchecked_Union (Def_Id) |
| and then Has_Discriminants (Def_Id) |
| then |
| declare |
| Old_Comp : Entity_Id; |
| |
| begin |
| Old_Comp := |
| First_Component (Base_Type (Underlying_Type (Etype (Def_Id)))); |
| Comp := First_Component (Def_Id); |
| while Present (Comp) loop |
| if Ekind (Comp) = E_Component |
| and then Chars (Comp) = Chars (Old_Comp) |
| then |
| Set_Discriminant_Checking_Func (Comp, |
| Discriminant_Checking_Func (Old_Comp)); |
| end if; |
| |
| Next_Component (Old_Comp); |
| Next_Component (Comp); |
| end loop; |
| end; |
| end if; |
| |
| if Is_Derived_Type (Def_Id) |
| and then Is_Limited_Type (Def_Id) |
| and then Is_Tagged_Type (Def_Id) |
| then |
| Check_Stream_Attributes (Def_Id); |
| end if; |
| |
| -- Update task and controlled component flags, because some of the |
| -- component types may have been private at the point of the record |
| -- declaration. |
| |
| Comp := First_Component (Def_Id); |
| |
| while Present (Comp) loop |
| if Has_Task (Etype (Comp)) then |
| Set_Has_Task (Def_Id); |
| |
| elsif Has_Controlled_Component (Etype (Comp)) |
| or else (Chars (Comp) /= Name_uParent |
| and then Is_Controlled (Etype (Comp))) |
| then |
| Set_Has_Controlled_Component (Def_Id); |
| end if; |
| |
| Next_Component (Comp); |
| end loop; |
| |
| -- Creation of the Dispatch Table. Note that a Dispatch Table is |
| -- created for regular tagged types as well as for Ada types deriving |
| -- from a C++ Class, but not for tagged types directly corresponding to |
| -- the C++ classes. In the later case we assume that the Vtable is |
| -- created in the C++ side and we just use it. |
| |
| if Is_Tagged_Type (Def_Id) then |
| |
| if Is_CPP_Class (Def_Id) then |
| |
| -- Because of the new C++ ABI compatibility we now allow the |
| -- programer to use the Ada tag (and in this case we must do |
| -- the normal expansion of the tag) |
| |
| if Etype (First_Component (Def_Id)) = RTE (RE_Tag) |
| and then Underlying_Type (Etype (Def_Id)) = Def_Id |
| then |
| Expand_Tagged_Root (Def_Id); |
| end if; |
| |
| Set_All_DT_Position (Def_Id); |
| Set_Default_Constructor (Def_Id); |
| |
| else |
| -- Usually inherited primitives are not delayed but the first Ada |
| -- extension of a CPP_Class is an exception since the address of |
| -- the inherited subprogram has to be inserted in the new Ada |
| -- Dispatch Table and this is a freezing action (usually the |
| -- inherited primitive address is inserted in the DT by |
| -- Inherit_DT) |
| |
| -- Similarly, if this is an inherited operation whose parent is |
| -- not frozen yet, it is not in the DT of the parent, and we |
| -- generate an explicit freeze node for the inherited operation, |
| -- so that it is properly inserted in the DT of the current type. |
| |
| declare |
| Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id)); |
| Subp : Entity_Id; |
| |
| begin |
| while Present (Elmt) loop |
| Subp := Node (Elmt); |
| |
| if Present (Alias (Subp)) then |
| if Is_CPP_Class (Etype (Def_Id)) then |
| Set_Has_Delayed_Freeze (Subp); |
| |
| elsif Has_Delayed_Freeze (Alias (Subp)) |
| and then not Is_Frozen (Alias (Subp)) |
| then |
| Set_Is_Frozen (Subp, False); |
| Set_Has_Delayed_Freeze (Subp); |
| end if; |
| end if; |
| |
| Next_Elmt (Elmt); |
| end loop; |
| end; |
| |
| if Underlying_Type (Etype (Def_Id)) = Def_Id then |
| Expand_Tagged_Root (Def_Id); |
| end if; |
| |
| -- Unfreeze momentarily the type to add the predefined primitives |
| -- operations. The reason we unfreeze is so that these predefined |
| -- operations will indeed end up as primitive operations (which |
| -- must be before the freeze point). |
| |
| Set_Is_Frozen (Def_Id, False); |
| Make_Predefined_Primitive_Specs |
| (Def_Id, Predef_List, Renamed_Eq); |
| Insert_List_Before_And_Analyze (N, Predef_List); |
| |
| -- Ada 2005 (AI-391): For a nonabstract null extension, create |
| -- wrapper functions for each nonoverridden inherited function |
| -- with a controlling result of the type. The wrapper for such |
| -- a function returns an extension aggregate that invokes the |
| -- the parent function. |
| |
| if Ada_Version >= Ada_05 |
| and then not Is_Abstract (Def_Id) |
| and then Is_Null_Extension (Def_Id) |
| then |
| Make_Controlling_Function_Wrappers |
| (Def_Id, Wrapper_Decl_List, Wrapper_Body_List); |
| Insert_List_Before_And_Analyze (N, Wrapper_Decl_List); |
| end if; |
| |
| Set_Is_Frozen (Def_Id, True); |
| Set_All_DT_Position (Def_Id); |
| |
| -- Add the controlled component before the freezing actions |
| -- referenced in those actions. |
| |
| if Has_New_Controlled_Component (Def_Id) then |
| Expand_Record_Controller (Def_Id); |
| end if; |
| |
| -- Suppress creation of a dispatch table when Java_VM because the |
| -- dispatching mechanism is handled internally by the JVM. |
| |
| if not Java_VM then |
| |
| -- Ada 2005 (AI-251): Build the secondary dispatch tables |
| |
| declare |
| ADT : Elist_Id := Access_Disp_Table (Def_Id); |
| |
| procedure Add_Secondary_Tables (Typ : Entity_Id); |
| -- Internal subprogram, recursively climb to the ancestors |
| |
| -------------------------- |
| -- Add_Secondary_Tables -- |
| -------------------------- |
| |
| procedure Add_Secondary_Tables (Typ : Entity_Id) is |
| E : Entity_Id; |
| Iface : Elmt_Id; |
| Result : List_Id; |
| Suffix_Index : Int; |
| |
| begin |
| -- Climb to the ancestor (if any) handling private types |
| |
| if Present (Full_View (Etype (Typ))) then |
| if Full_View (Etype (Typ)) /= Typ then |
| Add_Secondary_Tables (Full_View (Etype (Typ))); |
| end if; |
| |
| elsif Etype (Typ) /= Typ then |
| Add_Secondary_Tables (Etype (Typ)); |
| end if; |
| |
| if Present (Abstract_Interfaces (Typ)) |
| and then |
| not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) |
| then |
| Iface := First_Elmt (Abstract_Interfaces (Typ)); |
| Suffix_Index := 0; |
| |
| E := First_Entity (Typ); |
| while Present (E) loop |
| if Is_Tag (E) and then Chars (E) /= Name_uTag then |
| Make_Secondary_DT |
| (Typ => Def_Id, |
| Ancestor_Typ => Typ, |
| Suffix_Index => Suffix_Index, |
| Iface => Node (Iface), |
| AI_Tag => E, |
| Acc_Disp_Tables => ADT, |
| Result => Result); |
| |
| Append_Freeze_Actions (Def_Id, Result); |
| Suffix_Index := Suffix_Index + 1; |
| Next_Elmt (Iface); |
| end if; |
| |
| Next_Entity (E); |
| end loop; |
| end if; |
| end Add_Secondary_Tables; |
| |
| -- Start of processing to build secondary dispatch tables |
| |
| begin |
| -- Handle private types |
| |
| if Present (Full_View (Def_Id)) then |
| Add_Secondary_Tables (Full_View (Def_Id)); |
| else |
| Add_Secondary_Tables (Def_Id); |
| end if; |
| |
| Set_Access_Disp_Table (Def_Id, ADT); |
| Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); |
| end; |
| end if; |
| |
| -- Make sure that the primitives Initialize, Adjust and Finalize |
| -- are Frozen before other TSS subprograms. We don't want them |
| -- Frozen inside. |
| |
| if Is_Controlled (Def_Id) then |
| if not Is_Limited_Type (Def_Id) then |
| Append_Freeze_Actions (Def_Id, |
| Freeze_Entity |
| (Find_Prim_Op (Def_Id, Name_Adjust), Sloc (Def_Id))); |
| end if; |
| |
| Append_Freeze_Actions (Def_Id, |
| Freeze_Entity |
| (Find_Prim_Op (Def_Id, Name_Initialize), Sloc (Def_Id))); |
| |
| Append_Freeze_Actions (Def_Id, |
| Freeze_Entity |
| (Find_Prim_Op (Def_Id, Name_Finalize), Sloc (Def_Id))); |
| end if; |
| |
| -- Freeze rest of primitive operations |
| |
| Append_Freeze_Actions |
| (Def_Id, Predefined_Primitive_Freeze (Def_Id)); |
| Append_Freeze_Actions |
| (Def_Id, Init_Predefined_Interface_Primitives (Def_Id)); |
| end if; |
| |
| -- In the non-tagged case, an equality function is provided only for |
| -- variant records (that are not unchecked unions). |
| |
| elsif Has_Discriminants (Def_Id) |
| and then not Is_Limited_Type (Def_Id) |
| then |
| declare |
| Comps : constant Node_Id := |
| Component_List (Type_Definition (Type_Decl)); |
| |
| begin |
| if Present (Comps) |
| and then Present (Variant_Part (Comps)) |
| then |
| Build_Variant_Record_Equality (Def_Id); |
| end if; |
| end; |
| end if; |
| |
| -- Before building the record initialization procedure, if we are |
| -- dealing with a concurrent record value type, then we must go through |
| -- the discriminants, exchanging discriminals between the concurrent |
| -- type and the concurrent record value type. See the section "Handling |
| -- of Discriminants" in the Einfo spec for details. |
| |
| if Is_Concurrent_Record_Type (Def_Id) |
| and then Has_Discriminants (Def_Id) |
| then |
| declare |
| Ctyp : constant Entity_Id := |
| Corresponding_Concurrent_Type (Def_Id); |
| Conc_Discr : Entity_Id; |
| Rec_Discr : Entity_Id; |
| Temp : Entity_Id; |
| |
| begin |
| Conc_Discr := First_Discriminant (Ctyp); |
| Rec_Discr := First_Discriminant (Def_Id); |
| |
| while Present (Conc_Discr) loop |
| Temp := Discriminal (Conc_Discr); |
| Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); |
| Set_Discriminal (Rec_Discr, Temp); |
| |
| Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); |
| Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); |
| |
| Next_Discriminant (Conc_Discr); |
| Next_Discriminant (Rec_Discr); |
| end loop; |
| end; |
| end if; |
| |
| if Has_Controlled_Component (Def_Id) then |
| if No (Controller_Component (Def_Id)) then |
| Expand_Record_Controller (Def_Id); |
| end if; |
| |
| Build_Controlling_Procs (Def_Id); |
| end if; |
| |
| Adjust_Discriminants (Def_Id); |
| Build_Record_Init_Proc (Type_Decl, Def_Id); |
| |
| -- For tagged type, build bodies of primitive operations. Note that we |
| -- do this after building the record initialization experiment, since |
| -- the primitive operations may need the initialization routine |
| |
| if Is_Tagged_Type (Def_Id) then |
| Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); |
| Append_Freeze_Actions (Def_Id, Predef_List); |
| |
| -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden |
| -- inherited functions, then add their bodies to the freeze actions. |
| |
| if Present (Wrapper_Body_List) then |
| Append_Freeze_Actions (Def_Id, Wrapper_Body_List); |
| end if; |
| |
| -- Populate the two auxiliary tables used for dispatching |
| -- asynchronous, conditional and timed selects for synchronized |
| -- types that implement a limited interface. |
| |
| if Ada_Version >= Ada_05 |
| and then not Restriction_Active (No_Dispatching_Calls) |
| and then Is_Concurrent_Record_Type (Def_Id) |
| and then Implements_Interface ( |
| Typ => Def_Id, |
| Kind => Any_Limited_Interface, |
| Check_Parent => True) |
| then |
| Append_Freeze_Actions (Def_Id, |
| Make_Select_Specific_Data_Table (Def_Id)); |
| end if; |
| end if; |
| end Freeze_Record_Type; |
| |
| ------------------------------ |
| -- Freeze_Stream_Operations -- |
| ------------------------------ |
| |
| procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is |
| Names : constant array (1 .. 4) of TSS_Name_Type := |
| (TSS_Stream_Input, |
| TSS_Stream_Output, |
| TSS_Stream_Read, |
| TSS_Stream_Write); |
| Stream_Op : Entity_Id; |
| |
| begin |
| -- Primitive operations of tagged types are frozen when the dispatch |
| -- table is constructed. |
| |
| if not Comes_From_Source (Typ) |
| or else Is_Tagged_Type (Typ) |
| then |
| return; |
| end if; |
| |
| for J in Names'Range loop |
| Stream_Op := TSS (Typ, Names (J)); |
| |
| if Present (Stream_Op) |
| and then Is_Subprogram (Stream_Op) |
| and then Nkind (Unit_Declaration_Node (Stream_Op)) = |
| N_Subprogram_Declaration |
| and then not Is_Frozen (Stream_Op) |
| then |
| Append_Freeze_Actions |
| (Typ, Freeze_Entity (Stream_Op, Sloc (N))); |
| end if; |
| end loop; |
| end Freeze_Stream_Operations; |
| |
| ----------------- |
| -- Freeze_Type -- |
| ----------------- |
| |
| -- Full type declarations are expanded at the point at which the type is |
| -- frozen. The formal N is the Freeze_Node for the type. Any statements or |
| -- declarations generated by the freezing (e.g. the procedure generated |
| -- for initialization) are chained in the Actions field list of the freeze |
| -- node using Append_Freeze_Actions. |
| |
| function Freeze_Type (N : Node_Id) return Boolean is |
| Def_Id : constant Entity_Id := Entity (N); |
| RACW_Seen : Boolean := False; |
| Result : Boolean := False; |
| |
| begin |
| -- Process associated access types needing special processing |
| |
| if Present (Access_Types_To_Process (N)) then |
| declare |
| E : Elmt_Id := First_Elmt (Access_Types_To_Process (N)); |
| begin |
| while Present (E) loop |
| |
| if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then |
| RACW_Seen := True; |
| end if; |
| |
| E := Next_Elmt (E); |
| end loop; |
| end; |
| |
| if RACW_Seen then |
| |
| -- If there are RACWs designating this type, make stubs now |
| |
| Remote_Types_Tagged_Full_View_Encountered (Def_Id); |
| end if; |
| end if; |
| |
| -- Freeze processing for record types |
| |
| if Is_Record_Type (Def_Id) then |
| if Ekind (Def_Id) = E_Record_Type then |
| Freeze_Record_Type (N); |
| |
| -- The subtype may have been declared before the type was frozen. If |
| -- the type has controlled components it is necessary to create the |
| -- entity for the controller explicitly because it did not exist at |
| -- the point of the subtype declaration. Only the entity is needed, |
| -- the back-end will obtain the layout from the type. This is only |
| -- necessary if this is constrained subtype whose component list is |
| -- not shared with the base type. |
| |
| elsif Ekind (Def_Id) = E_Record_Subtype |
| and then Has_Discriminants (Def_Id) |
| and then Last_Entity (Def_Id) /= Last_Entity (Base_Type (Def_Id)) |
| and then Present (Controller_Component (Def_Id)) |
| then |
| declare |
| Old_C : constant Entity_Id := Controller_Component (Def_Id); |
| New_C : Entity_Id; |
| |
| begin |
| if Scope (Old_C) = Base_Type (Def_Id) then |
| |
| -- The entity is the one in the parent. Create new one |
| |
| New_C := New_Copy (Old_C); |
| Set_Parent (New_C, Parent (Old_C)); |
| New_Scope (Def_Id); |
| Enter_Name (New_C); |
| End_Scope; |
| end if; |
| end; |
| |
| if Is_Itype (Def_Id) |
| and then Is_Record_Type (Underlying_Type (Scope (Def_Id))) |
| then |
| -- The freeze node is only used to introduce the controller, |
| -- the back-end has no use for it for a discriminated |
| -- component. |
| |
| Set_Freeze_Node (Def_Id, Empty); |
| Set_Has_Delayed_Freeze (Def_Id, False); |
| Result := True; |
| end if; |
| |
| -- Similar process if the controller of the subtype is not present |
| -- but the parent has it. This can happen with constrained |
| -- record components where the subtype is an itype. |
| |
| elsif Ekind (Def_Id) = E_Record_Subtype |
| and then Is_Itype (Def_Id) |
| and then No (Controller_Component (Def_Id)) |
| and then Present (Controller_Component (Etype (Def_Id))) |
| then |
| declare |
| Old_C : constant Entity_Id := |
| Controller_Component (Etype (Def_Id)); |
| New_C : constant Entity_Id := New_Copy (Old_C); |
| |
| begin |
| Set_Next_Entity (New_C, First_Entity (Def_Id)); |
| Set_First_Entity (Def_Id, New_C); |
| |
| -- The freeze node is only used to introduce the controller, |
| -- the back-end has no use for it for a discriminated |
| -- component. |
| |
| Set_Freeze_Node (Def_Id, Empty); |
| Set_Has_Delayed_Freeze (Def_Id, False); |
| Result := True; |
| end; |
| end if; |
| |
| -- Freeze processing for array types |
| |
| elsif Is_Array_Type (Def_Id) then |
| Freeze_Array_Type (N); |
| |
| -- Freeze processing for access types |
| |
| -- For pool-specific access types, find out the pool object used for |
| -- this type, needs actual expansion of it in some cases. Here are the |
| -- different cases : |
| |
| -- 1. Rep Clause "for Def_Id'Storage_Size use 0;" |
| -- ---> don't use any storage pool |
| |
| -- 2. Rep Clause : for Def_Id'Storage_Size use Expr. |
| -- Expand: |
| -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment); |
| |
| -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" |
| -- ---> Storage Pool is the specified one |
| |
| -- See GNAT Pool packages in the Run-Time for more details |
| |
| elsif Ekind (Def_Id) = E_Access_Type |
| or else Ekind (Def_Id) = E_General_Access_Type |
| then |
| declare |
| Loc : constant Source_Ptr := Sloc (N); |
| Desig_Type : constant Entity_Id := Designated_Type (Def_Id); |
| Pool_Object : Entity_Id; |
| Siz_Exp : Node_Id; |
| |
| Freeze_Action_Typ : Entity_Id; |
| |
| begin |
| if Has_Storage_Size_Clause (Def_Id) then |
| Siz_Exp := Expression (Parent (Storage_Size_Variable (Def_Id))); |
| else |
| Siz_Exp := Empty; |
| end if; |
| |
| -- Case 1 |
| |
| -- Rep Clause "for Def_Id'Storage_Size use 0;" |
| -- ---> don't use any storage pool |
| |
| if Has_Storage_Size_Clause (Def_Id) |
| and then Compile_Time_Known_Value (Siz_Exp) |
| and then Expr_Value (Siz_Exp) = 0 |
| then |
| null; |
| |
| -- Case 2 |
| |
| -- Rep Clause : for Def_Id'Storage_Size use Expr. |
| -- ---> Expand: |
| -- Def_Id__Pool : Stack_Bounded_Pool |
| -- (Expr, DT'Size, DT'Alignment); |
| |
| elsif Has_Storage_Size_Clause (Def_Id) then |
| declare |
| DT_Size : Node_Id; |
| DT_Align : Node_Id; |
| |
| begin |
| -- For unconstrained composite types we give a size of zero |
| -- so that the pool knows that it needs a special algorithm |
| -- for variable size object allocation. |
| |
| if Is_Composite_Type (Desig_Type) |
| and then not Is_Constrained (Desig_Type) |
| then |
| DT_Size := |
| Make_Integer_Literal (Loc, 0); |
| |
| DT_Align := |
| Make_Integer_Literal (Loc, Maximum_Alignment); |
| |
| else |
| DT_Size := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Desig_Type, Loc), |
| Attribute_Name => Name_Max_Size_In_Storage_Elements); |
| |
| DT_Align := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Desig_Type, Loc), |
| Attribute_Name => Name_Alignment); |
| end if; |
| |
| Pool_Object := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Chars (Def_Id), 'P')); |
| |
| -- We put the code associated with the pools in the entity |
| -- that has the later freeze node, usually the acces type |
| -- but it can also be the designated_type; because the pool |
| -- code requires both those types to be frozen |
| |
| if Is_Frozen (Desig_Type) |
| and then (No (Freeze_Node (Desig_Type)) |
| or else Analyzed (Freeze_Node (Desig_Type))) |
| then |
| Freeze_Action_Typ := Def_Id; |
| |
| -- A Taft amendment type cannot get the freeze actions |
| -- since the full view is not there. |
| |
| elsif Is_Incomplete_Or_Private_Type (Desig_Type) |
| and then No (Full_View (Desig_Type)) |
| then |
| Freeze_Action_Typ := Def_Id; |
| |
| else |
| Freeze_Action_Typ := Desig_Type; |
| end if; |
| |
| Append_Freeze_Action (Freeze_Action_Typ, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Pool_Object, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Reference_To |
| (RTE (RE_Stack_Bounded_Pool), Loc), |
| |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List ( |
| |
| -- First discriminant is the Pool Size |
| |
| New_Reference_To ( |
| Storage_Size_Variable (Def_Id), Loc), |
| |
| -- Second discriminant is the element size |
| |
| DT_Size, |
| |
| -- Third discriminant is the alignment |
| |
| DT_Align))))); |
| end; |
| |
| Set_Associated_Storage_Pool (Def_Id, Pool_Object); |
| |
| -- Case 3 |
| |
| -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" |
| -- ---> Storage Pool is the specified one |
| |
| elsif Present (Associated_Storage_Pool (Def_Id)) then |
| |
| -- Nothing to do the associated storage pool has been attached |
| -- when analyzing the rep. clause |
| |
| null; |
| end if; |
| |
| -- For access-to-controlled types (including class-wide types and |
| -- Taft-amendment types which potentially have controlled |
| -- components), expand the list controller object that will store |
| -- the dynamically allocated objects. Do not do this |
| -- transformation for expander-generated access types, but do it |
| -- for types that are the full view of types derived from other |
| -- private types. Also suppress the list controller in the case |
| -- of a designated type with convention Java, since this is used |
| -- when binding to Java API specs, where there's no equivalent of |
| -- a finalization list and we don't want to pull in the |
| -- finalization support if not needed. |
| |
| if not Comes_From_Source (Def_Id) |
| and then not Has_Private_Declaration (Def_Id) |
| then |
| null; |
| |
| elsif (Controlled_Type (Desig_Type) |
| and then Convention (Desig_Type) /= Convention_Java) |
| or else |
| (Is_Incomplete_Or_Private_Type (Desig_Type) |
| and then No (Full_View (Desig_Type)) |
| |
| -- An exception is made for types defined in the run-time |
| -- because Ada.Tags.Tag itself is such a type and cannot |
| -- afford this unnecessary overhead that would generates a |
| -- loop in the expansion scheme... |
| |
| and then not In_Runtime (Def_Id) |
| |
| -- Another exception is if Restrictions (No_Finalization) |
| -- is active, since then we know nothing is controlled. |
| |
| and then not Restriction_Active (No_Finalization)) |
| |
| -- If the designated type is not frozen yet, its controlled |
| -- status must be retrieved explicitly. |
| |
| or else (Is_Array_Type (Desig_Type) |
| and then not Is_Frozen (Desig_Type) |
| and then Controlled_Type (Component_Type (Desig_Type))) |
| then |
| Set_Associated_Final_Chain (Def_Id, |
| Make_Defining_Identifier (Loc, |
| New_External_Name (Chars (Def_Id), 'L'))); |
| |
| Append_Freeze_Action (Def_Id, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Associated_Final_Chain (Def_Id), |
| Object_Definition => |
| New_Reference_To (RTE (RE_List_Controller), Loc))); |
| end if; |
| end; |
| |
| -- Freeze processing for enumeration types |
| |
| elsif Ekind (Def_Id) = E_Enumeration_Type then |
| |
| -- We only have something to do if we have a non-standard |
| -- representation (i.e. at least one literal whose pos value |
| -- is not the same as its representation) |
| |
| if Has_Non_Standard_Rep (Def_Id) then |
| Freeze_Enumeration_Type (N); |
| end if; |
| |
| -- Private types that are completed by a derivation from a private |
| -- type have an internally generated full view, that needs to be |
| -- frozen. This must be done explicitly because the two views share |
| -- the freeze node, and the underlying full view is not visible when |
| -- the freeze node is analyzed. |
| |
| elsif Is_Private_Type (Def_Id) |
| and then Is_Derived_Type (Def_Id) |
| and then Present (Full_View (Def_Id)) |
| and then Is_Itype (Full_View (Def_Id)) |
| and then Has_Private_Declaration (Full_View (Def_Id)) |
| and then Freeze_Node (Full_View (Def_Id)) = N |
| then |
| Set_Entity (N, Full_View (Def_Id)); |
| Result := Freeze_Type (N); |
| Set_Entity (N, Def_Id); |
| |
| -- All other types require no expander action. There are such cases |
| -- (e.g. task types and protected types). In such cases, the freeze |
| -- nodes are there for use by Gigi. |
| |
| end if; |
| |
| Freeze_Stream_Operations (N, Def_Id); |
| return Result; |
| |
| exception |
| when RE_Not_Available => |
| return False; |
| end Freeze_Type; |
| |
| ------------------------- |
| -- Get_Simple_Init_Val -- |
| ------------------------- |
| |
| function Get_Simple_Init_Val |
| (T : Entity_Id; |
| Loc : Source_Ptr; |
| Size : Uint := No_Uint) return Node_Id |
| is |
| Val : Node_Id; |
| Result : Node_Id; |
| Val_RE : RE_Id; |
| |
| Size_To_Use : Uint; |
| -- This is the size to be used for computation of the appropriate |
| -- initial value for the Normalize_Scalars and Initialize_Scalars case. |
| |
| Lo_Bound : Uint; |
| Hi_Bound : Uint; |
| -- These are the values computed by the procedure Check_Subtype_Bounds |
| |
| procedure Check_Subtype_Bounds; |
| -- This procedure examines the subtype T, and its ancestor subtypes and |
| -- derived types to determine the best known information about the |
| -- bounds of the subtype. After the call Lo_Bound is set either to |
| -- No_Uint if no information can be determined, or to a value which |
| -- represents a known low bound, i.e. a valid value of the subtype can |
| -- not be less than this value. Hi_Bound is similarly set to a known |
| -- high bound (valid value cannot be greater than this). |
| |
| -------------------------- |
| -- Check_Subtype_Bounds -- |
| -------------------------- |
| |
| procedure Check_Subtype_Bounds is |
| ST1 : Entity_Id; |
| ST2 : Entity_Id; |
| Lo : Node_Id; |
| Hi : Node_Id; |
| Loval : Uint; |
| Hival : Uint; |
| |
| begin |
| Lo_Bound := No_Uint; |
| Hi_Bound := No_Uint; |
| |
| -- Loop to climb ancestor subtypes and derived types |
| |
| ST1 := T; |
| loop |
| if not Is_Discrete_Type (ST1) then |
| return; |
| end if; |
| |
| Lo := Type_Low_Bound (ST1); |
| Hi := Type_High_Bound (ST1); |
| |
| if Compile_Time_Known_Value (Lo) then |
| Loval := Expr_Value (Lo); |
| |
| if Lo_Bound = No_Uint or else Lo_Bound < Loval then |
| Lo_Bound := Loval; |
| end if; |
| end if; |
| |
| if Compile_Time_Known_Value (Hi) then |
| Hival := Expr_Value (Hi); |
| |
| if Hi_Bound = No_Uint or else Hi_Bound > Hival then |
| Hi_Bound := Hival; |
| end if; |
| end if; |
| |
| ST2 := Ancestor_Subtype (ST1); |
| |
| if No (ST2) then |
| ST2 := Etype (ST1); |
| end if; |
| |
| exit when ST1 = ST2; |
| ST1 := ST2; |
| end loop; |
| end Check_Subtype_Bounds; |
| |
| -- Start of processing for Get_Simple_Init_Val |
| |
| begin |
| -- For a private type, we should always have an underlying type |
| -- (because this was already checked in Needs_Simple_Initialization). |
| -- What we do is to get the value for the underlying type and then do |
| -- an Unchecked_Convert to the private type. |
| |
| if Is_Private_Type (T) then |
| Val := Get_Simple_Init_Val (Underlying_Type (T), Loc, Size); |
| |
| -- A special case, if the underlying value is null, then qualify it |
| -- with the underlying type, so that the null is properly typed |
| -- Similarly, if it is an aggregate it must be qualified, because an |
| -- unchecked conversion does not provide a context for it. |
| |
| if Nkind (Val) = N_Null |
| or else Nkind (Val) = N_Aggregate |
| then |
| Val := |
| Make_Qualified_Expression (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (Underlying_Type (T), Loc), |
| Expression => Val); |
| end if; |
| |
| Result := Unchecked_Convert_To (T, Val); |
| |
| -- Don't truncate result (important for Initialize/Normalize_Scalars) |
| |
| if Nkind (Result) = N_Unchecked_Type_Conversion |
| and then Is_Scalar_Type (Underlying_Type (T)) |
| then |
| Set_No_Truncation (Result); |
| end if; |
| |
| return Result; |
| |
| -- For scalars, we must have normalize/initialize scalars case |
| |
| elsif Is_Scalar_Type (T) then |
| pragma Assert (Init_Or_Norm_Scalars); |
| |
| -- Compute size of object. If it is given by the caller, we can use |
| -- it directly, otherwise we use Esize (T) as an estimate. As far as |
| -- we know this covers all cases correctly. |
| |
| if Size = No_Uint or else Size <= Uint_0 then |
| Size_To_Use := UI_Max (Uint_1, Esize (T)); |
| else |
| Size_To_Use := Size; |
| end if; |
| |
| -- Maximum size to use is 64 bits, since we will create values |
| -- of type Unsigned_64 and the range must fit this type. |
| |
| if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then |
| Size_To_Use := Uint_64; |
| end if; |
| |
| -- Check known bounds of subtype |
| |
| Check_Subtype_Bounds; |
| |
| -- Processing for Normalize_Scalars case |
| |
| if Normalize_Scalars then |
| |
| -- If zero is invalid, it is a convenient value to use that is |
| -- for sure an appropriate invalid value in all situations. |
| |
| if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then |
| Val := Make_Integer_Literal (Loc, 0); |
| |
| -- Cases where all one bits is the appropriate invalid value |
| |
| -- For modular types, all 1 bits is either invalid or valid. If |
| -- it is valid, then there is nothing that can be done since there |
| -- are no invalid values (we ruled out zero already). |
| |
| -- For signed integer types that have no negative values, either |
| -- there is room for negative values, or there is not. If there |
| -- is, then all 1 bits may be interpretecd as minus one, which is |
| -- certainly invalid. Alternatively it is treated as the largest |
| -- positive value, in which case the observation for modular types |
| -- still applies. |
| |
| -- For float types, all 1-bits is a NaN (not a number), which is |
| -- certainly an appropriately invalid value. |
| |
| elsif Is_Unsigned_Type (T) |
| or else Is_Floating_Point_Type (T) |
| or else Is_Enumeration_Type (T) |
| then |
| Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1); |
| |
| -- Resolve as Unsigned_64, because the largest number we |
| -- can generate is out of range of universal integer. |
| |
| Analyze_And_Resolve (Val, RTE (RE_Unsigned_64)); |
| |
| -- Case of signed types |
| |
| else |
| declare |
| Signed_Size : constant Uint := |
| UI_Min (Uint_63, Size_To_Use - 1); |
| |
| begin |
| -- Normally we like to use the most negative number. The |
| -- one exception is when this number is in the known |
| -- subtype range and the largest positive number is not in |
| -- the known subtype range. |
| |
| -- For this exceptional case, use largest positive value |
| |
| if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint |
| and then Lo_Bound <= (-(2 ** Signed_Size)) |
| and then Hi_Bound < 2 ** Signed_Size |
| then |
| Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1); |
| |
| -- Normal case of largest negative value |
| |
| else |
| Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size)); |
| end if; |
| end; |
| end if; |
| |
| -- Here for Initialize_Scalars case |
| |
| else |
| -- For float types, use float values from System.Scalar_Values |
| |
| if Is_Floating_Point_Type (T) then |
| if Root_Type (T) = Standard_Short_Float then |
| Val_RE := RE_IS_Isf; |
| elsif Root_Type (T) = Standard_Float then |
| Val_RE := RE_IS_Ifl; |
| elsif Root_Type (T) = Standard_Long_Float then |
| Val_RE := RE_IS_Ilf; |
| else pragma Assert (Root_Type (T) = Standard_Long_Long_Float); |
| Val_RE := RE_IS_Ill; |
| end if; |
| |
| -- If zero is invalid, use zero values from System.Scalar_Values |
| |
| elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then |
| if Size_To_Use <= 8 then |
| Val_RE := RE_IS_Iz1; |
| elsif Size_To_Use <= 16 then |
| Val_RE := RE_IS_Iz2; |
| elsif Size_To_Use <= 32 then |
| Val_RE := RE_IS_Iz4; |
| else |
| Val_RE := RE_IS_Iz8; |
| end if; |
| |
| -- For unsigned, use unsigned values from System.Scalar_Values |
| |
| elsif Is_Unsigned_Type (T) then |
| if Size_To_Use <= 8 then |
| Val_RE := RE_IS_Iu1; |
| elsif Size_To_Use <= 16 then |
| Val_RE := RE_IS_Iu2; |
| elsif Size_To_Use <= 32 then |
| Val_RE := RE_IS_Iu4; |
| else |
| Val_RE := RE_IS_Iu8; |
| end if; |
| |
| -- For signed, use signed values from System.Scalar_Values |
| |
| else |
| if Size_To_Use <= 8 then |
| Val_RE := RE_IS_Is1; |
| elsif Size_To_Use <= 16 then |
| Val_RE := RE_IS_Is2; |
| elsif Size_To_Use <= 32 then |
| Val_RE := RE_IS_Is4; |
| else |
| Val_RE := RE_IS_Is8; |
| end if; |
| end if; |
| |
| Val := New_Occurrence_Of (RTE (Val_RE), Loc); |
| end if; |
| |
| -- The final expression is obtained by doing an unchecked conversion |
| -- of this result to the base type of the required subtype. We use |
| -- the base type to avoid the unchecked conversion from chopping |
| -- bits, and then we set Kill_Range_Check to preserve the "bad" |
| -- value. |
| |
| Result := Unchecked_Convert_To (Base_Type (T), Val); |
| |
| -- Ensure result is not truncated, since we want the "bad" bits |
| -- and also kill range check on result. |
| |
| if Nkind (Result) = N_Unchecked_Type_Conversion then |
| Set_No_Truncation (Result); |
| Set_Kill_Range_Check (Result, True); |
| end if; |
| |
| return Result; |
| |
| -- String or Wide_[Wide]_String (must have Initialize_Scalars set) |
| |
| elsif Root_Type (T) = Standard_String |
| or else |
| Root_Type (T) = Standard_Wide_String |
| or else |
| Root_Type (T) = Standard_Wide_Wide_String |
| then |
| pragma Assert (Init_Or_Norm_Scalars); |
| |
| return |
| Make_Aggregate (Loc, |
| Component_Associations => New_List ( |
| Make_Component_Association (Loc, |
| Choices => New_List ( |
| Make_Others_Choice (Loc)), |
| Expression => |
| Get_Simple_Init_Val |
| (Component_Type (T), Loc, Esize (Root_Type (T)))))); |
| |
| -- Access type is initialized to null |
| |
| elsif Is_Access_Type (T) then |
| return |
| Make_Null (Loc); |
| |
| -- No other possibilities should arise, since we should only be |
| -- calling Get_Simple_Init_Val if Needs_Simple_Initialization |
| -- returned True, indicating one of the above cases held. |
| |
| else |
| raise Program_Error; |
| end if; |
| |
| exception |
| when RE_Not_Available => |
| return Empty; |
| end Get_Simple_Init_Val; |
| |
| ------------------------------ |
| -- Has_New_Non_Standard_Rep -- |
| ------------------------------ |
| |
| function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is |
| begin |
| if not Is_Derived_Type (T) then |
| return Has_Non_Standard_Rep (T) |
| or else Has_Non_Standard_Rep (Root_Type (T)); |
| |
| -- If Has_Non_Standard_Rep is not set on the derived type, the |
| -- representation is fully inherited. |
| |
| elsif not Has_Non_Standard_Rep (T) then |
| return False; |
| |
| else |
| return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T)); |
| |
| -- May need a more precise check here: the First_Rep_Item may |
| -- be a stream attribute, which does not affect the representation |
| -- of the type ??? |
| end if; |
| end Has_New_Non_Standard_Rep; |
| |
| ---------------- |
| -- In_Runtime -- |
| ---------------- |
| |
| function In_Runtime (E : Entity_Id) return Boolean is |
| S1 : Entity_Id := Scope (E); |
| |
| begin |
| while Scope (S1) /= Standard_Standard loop |
| S1 := Scope (S1); |
| end loop; |
| |
| return Chars (S1) = Name_System or else Chars (S1) = Name_Ada; |
| end In_Runtime; |
| |
| ------------------ |
| -- Init_Formals -- |
| ------------------ |
| |
| function Init_Formals (Typ : Entity_Id) return List_Id is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Formals : List_Id; |
| |
| begin |
| -- First parameter is always _Init : in out typ. Note that we need |
| -- this to be in/out because in the case of the task record value, |
| -- there are default record fields (_Priority, _Size, -Task_Info) |
| -- that may be referenced in the generated initialization routine. |
| |
| Formals := New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uInit), |
| In_Present => True, |
| Out_Present => True, |
| Parameter_Type => New_Reference_To (Typ, Loc))); |
| |
| -- For task record value, or type that contains tasks, add two more |
| -- formals, _Master : Master_Id and _Chain : in out Activation_Chain |
| -- We also add these parameters for the task record type case. |
| |
| if Has_Task (Typ) |
| or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ)) |
| then |
| Append_To (Formals, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uMaster), |
| Parameter_Type => New_Reference_To (RTE (RE_Master_Id), Loc))); |
| |
| Append_To (Formals, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uChain), |
| In_Present => True, |
| Out_Present => True, |
| Parameter_Type => |
| New_Reference_To (RTE (RE_Activation_Chain), Loc))); |
| |
| Append_To (Formals, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uTask_Name), |
| In_Present => True, |
| Parameter_Type => |
| New_Reference_To (Standard_String, Loc))); |
| end if; |
| |
| return Formals; |
| |
| exception |
| when RE_Not_Available => |
| return Empty_List; |
| end Init_Formals; |
| |
| ------------------------------------- |
| -- Make_Predefined_Primitive_Specs -- |
| ------------------------------------- |
| |
| procedure Make_Controlling_Function_Wrappers |
| (Tag_Typ : Entity_Id; |
| Decl_List : out List_Id; |
| Body_List : out List_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Tag_Typ); |
| Prim_Elmt : Elmt_Id; |
| Subp : Entity_Id; |
| Actual_List : List_Id; |
| Formal_List : List_Id; |
| Formal : Entity_Id; |
| Par_Formal : Entity_Id; |
| Formal_Node : Node_Id; |
| Func_Spec : Node_Id; |
| Func_Decl : Node_Id; |
| Func_Body : Node_Id; |
| Return_Stmt : Node_Id; |
| |
| begin |
| Decl_List := New_List; |
| Body_List := New_List; |
| |
| Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); |
| |
| while Present (Prim_Elmt) loop |
| Subp := Node (Prim_Elmt); |
| |
| -- If a primitive function with a controlling result of the type has |
| -- not been overridden by the user, then we must create a wrapper |
| -- function here that effectively overrides it and invokes the |
| -- abstract inherited function's nonabstract parent. This can only |
| -- occur for a null extension. Note that functions with anonymous |
| -- controlling access results don't qualify and must be overridden. |
| -- We also exclude Input attributes, since each type will have its |
| -- own version of Input constructed by the expander. The test for |
| -- Comes_From_Source is needed to distinguish inherited operations |
| -- from renamings (which also have Alias set). |
| |
| if Is_Abstract (Subp) |
| and then Present (Alias (Subp)) |
| and then not Comes_From_Source (Subp) |
| and then Ekind (Subp) = E_Function |
| and then Has_Controlling_Result (Subp) |
| and then not Is_Access_Type (Etype (Subp)) |
| and then not Is_TSS (Subp, TSS_Stream_Input) |
| then |
| Formal_List := No_List; |
| Formal := First_Formal (Subp); |
| |
| if Present (Formal) then |
| Formal_List := New_List; |
| |
| while Present (Formal) loop |
| Append |
| (Make_Parameter_Specification |
| (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Sloc (Formal), |
| Chars => Chars (Formal)), |
| In_Present => In_Present (Parent (Formal)), |
| Out_Present => Out_Present (Parent (Formal)), |
| Parameter_Type => |
| New_Reference_To (Etype (Formal), Loc), |
| Expression => |
| New_Copy_Tree (Expression (Parent (Formal)))), |
| Formal_List); |
| |
| Next_Formal (Formal); |
| end loop; |
| end if; |
| |
| Func_Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => |
| Make_Defining_Identifier (Loc, Chars (Subp)), |
| Parameter_Specifications => |
| Formal_List, |
| Result_Definition => |
| New_Reference_To (Etype (Subp), Loc)); |
| |
| Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); |
| Append_To (Decl_List, Func_Decl); |
| |
| -- Build a wrapper body that calls the parent function. The body |
| -- contains a single return statement that returns an extension |
| -- aggregate whose ancestor part is a call to the parent function, |
| -- passing the formals as actuals (with any controlling arguments |
| -- converted to the types of the corresponding formals of the |
| -- parent function, which might be anonymous access types), and |
| -- having a null extension. |
| |
| Formal := First_Formal (Subp); |
| Par_Formal := First_Formal (Alias (Subp)); |
| Formal_Node := First (Formal_List); |
| |
| if Present (Formal) then |
| Actual_List := New_List; |
| else |
| Actual_List := No_List; |
| end if; |
| |
| while Present (Formal) loop |
| if Is_Controlling_Formal (Formal) then |
| Append_To (Actual_List, |
| Make_Type_Conversion (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (Etype (Par_Formal), Loc), |
| Expression => |
| New_Reference_To |
| (Defining_Identifier (Formal_Node), Loc))); |
| else |
| Append_To |
| (Actual_List, |
| New_Reference_To |
| (Defining_Identifier (Formal_Node), Loc)); |
| end if; |
| |
| Next_Formal (Formal); |
| Next_Formal (Par_Formal); |
| Next (Formal_Node); |
| end loop; |
| |
| Return_Stmt := |
| Make_Return_Statement (Loc, |
| Expression => |
| Make_Extension_Aggregate (Loc, |
| Ancestor_Part => |
| Make_Function_Call (Loc, |
| Name => New_Reference_To (Alias (Subp), Loc), |
| Parameter_Associations => Actual_List), |
| Null_Record_Present => True)); |
| |
| Func_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => New_Copy_Tree (Func_Spec), |
| Declarations => Empty_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Return_Stmt))); |
| |
| Set_Defining_Unit_Name |
| (Specification (Func_Body), |
| Make_Defining_Identifier (Loc, Chars (Subp))); |
| |
| Append_To (Body_List, Func_Body); |
| |
| -- Replace the inherited function with the wrapper function |
| -- in the primitive operations list. |
| |
| Override_Dispatching_Operation |
| (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec)); |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| end Make_Controlling_Function_Wrappers; |
| |
| ------------------ |
| -- Make_Eq_Case -- |
| ------------------ |
| |
| -- <Make_Eq_if shared components> |
| -- case X.D1 is |
| -- when V1 => <Make_Eq_Case> on subcomponents |
| -- ... |
| -- when Vn => <Make_Eq_Case> on subcomponents |
| -- end case; |
| |
| function Make_Eq_Case |
| (E : Entity_Id; |
| CL : Node_Id; |
| Discr : Entity_Id := Empty) return List_Id |
| is |
| Loc : constant Source_Ptr := Sloc (E); |
| Result : constant List_Id := New_List; |
| Variant : Node_Id; |
| Alt_List : List_Id; |
| |
| begin |
| Append_To (Result, Make_Eq_If (E, Component_Items (CL))); |
| |
| if No (Variant_Part (CL)) then |
| return Result; |
| end if; |
| |
| Variant := First_Non_Pragma (Variants (Variant_Part (CL))); |
| |
| if No (Variant) then |
| return Result; |
| end if; |
| |
| Alt_List := New_List; |
| |
| while Present (Variant) loop |
| Append_To (Alt_List, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)), |
| Statements => Make_Eq_Case (E, Component_List (Variant)))); |
| |
| Next_Non_Pragma (Variant); |
| end loop; |
| |
| -- If we have an Unchecked_Union, use one of the parameters that |
| -- captures the discriminants. |
| |
| if Is_Unchecked_Union (E) then |
| Append_To (Result, |
| Make_Case_Statement (Loc, |
| Expression => New_Reference_To (Discr, Loc), |
| Alternatives => Alt_List)); |
| |
| else |
| Append_To (Result, |
| Make_Case_Statement (Loc, |
| Expression => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_X), |
| Selector_Name => New_Copy (Name (Variant_Part (CL)))), |
| Alternatives => Alt_List)); |
| end if; |
| |
| return Result; |
| end Make_Eq_Case; |
| |
| ---------------- |
| -- Make_Eq_If -- |
| ---------------- |
| |
| -- Generates: |
| |
| -- if |
| -- X.C1 /= Y.C1 |
| -- or else |
| -- X.C2 /= Y.C2 |
| -- ... |
| -- then |
| -- return False; |
| -- end if; |
| |
| -- or a null statement if the list L is empty |
| |
| function Make_Eq_If |
| (E : Entity_Id; |
| L : List_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (E); |
| C : Node_Id; |
| Field_Name : Name_Id; |
| Cond : Node_Id; |
| |
| begin |
| if No (L) then |
| return Make_Null_Statement (Loc); |
| |
| else |
| Cond := Empty; |
| |
| C := First_Non_Pragma (L); |
| while Present (C) loop |
| Field_Name := Chars (Defining_Identifier (C)); |
| |
| -- The tags must not be compared they are not part of the value. |
| -- Note also that in the following, we use Make_Identifier for |
| -- the component names. Use of New_Reference_To to identify the |
| -- components would be incorrect because the wrong entities for |
| -- discriminants could be picked up in the private type case. |
| |
| if Field_Name /= Name_uTag then |
| Evolve_Or_Else (Cond, |
| Make_Op_Ne (Loc, |
| Left_Opnd => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_X), |
| Selector_Name => |
| Make_Identifier (Loc, Field_Name)), |
| |
| Right_Opnd => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_Y), |
| Selector_Name => |
| Make_Identifier (Loc, Field_Name)))); |
| end if; |
| |
| Next_Non_Pragma (C); |
| end loop; |
| |
| if No (Cond) then |
| return Make_Null_Statement (Loc); |
| |
| else |
| return |
| Make_Implicit_If_Statement (E, |
| Condition => Cond, |
| Then_Statements => New_List ( |
| Make_Return_Statement (Loc, |
| Expression => New_Occurrence_Of (Standard_False, Loc)))); |
| end if; |
| end if; |
| end Make_Eq_If; |
| |
| ------------------------------------- |
| -- Make_Predefined_Primitive_Specs -- |
| ------------------------------------- |
| |
| procedure Make_Predefined_Primitive_Specs |
| (Tag_Typ : Entity_Id; |
| Predef_List : out List_Id; |
| Renamed_Eq : out Node_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Tag_Typ); |
| Res : constant List_Id := New_List; |
| Prim : Elmt_Id; |
| Eq_Needed : Boolean; |
| Eq_Spec : Node_Id; |
| Eq_Name : Name_Id := Name_Op_Eq; |
| |
| function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean; |
| -- Returns true if Prim is a renaming of an unresolved predefined |
| -- equality operation. |
| |
| ------------------------------- |
| -- Is_Predefined_Eq_Renaming -- |
| ------------------------------- |
| |
| function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is |
| begin |
| return Chars (Prim) /= Name_Op_Eq |
| and then Present (Alias (Prim)) |
| and then Comes_From_Source (Prim) |
| and then Is_Intrinsic_Subprogram (Alias (Prim)) |
| and then Chars (Alias (Prim)) = Name_Op_Eq; |
| end Is_Predefined_Eq_Renaming; |
| |
| -- Start of processing for Make_Predefined_Primitive_Specs |
| |
| begin |
| Renamed_Eq := Empty; |
| |
| -- Spec of _Size |
| |
| Append_To (Res, Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Tag_Typ, |
| Name => Name_uSize, |
| Profile => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), |
| Parameter_Type => New_Reference_To (Tag_Typ, Loc))), |
| |
| Ret_Type => Standard_Long_Long_Integer)); |
| |
| -- Spec of _Alignment |
| |
| Append_To (Res, Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Tag_Typ, |
| Name => Name_uAlignment, |
| Profile => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), |
| Parameter_Type => New_Reference_To (Tag_Typ, Loc))), |
| |
| Ret_Type => Standard_Integer)); |
| |
| -- Specs for dispatching stream attributes |
| |
| declare |
| Stream_Op_TSS_Names : |
| constant array (Integer range <>) of TSS_Name_Type := |
| (TSS_Stream_Read, |
| TSS_Stream_Write, |
| TSS_Stream_Input, |
| TSS_Stream_Output); |
| begin |
| for Op in Stream_Op_TSS_Names'Range loop |
| if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then |
| Append_To (Res, |
| Predef_Stream_Attr_Spec (Loc, Tag_Typ, |
| Stream_Op_TSS_Names (Op))); |
| end if; |
| end loop; |
| end; |
| |
| -- Spec of "=" if expanded if the type is not limited and if a |
| -- user defined "=" was not already declared for the non-full |
| -- view of a private extension |
| |
| if not Is_Limited_Type (Tag_Typ) then |
| Eq_Needed := True; |
| |
| Prim := First_Elmt (Primitive_Operations (Tag_Typ)); |
| while Present (Prim) loop |
| |
| -- If a primitive is encountered that renames the predefined |
| -- equality operator before reaching any explicit equality |
| -- primitive, then we still need to create a predefined |
| -- equality function, because calls to it can occur via |
| -- the renaming. A new name is created for the equality |
| -- to avoid conflicting with any user-defined equality. |
| -- (Note that this doesn't account for renamings of |
| -- equality nested within subpackages???) |
| |
| if Is_Predefined_Eq_Renaming (Node (Prim)) then |
| Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); |
| |
| elsif Chars (Node (Prim)) = Name_Op_Eq |
| and then (No (Alias (Node (Prim))) |
| or else Nkind (Unit_Declaration_Node (Node (Prim))) = |
| N_Subprogram_Renaming_Declaration) |
| and then Etype (First_Formal (Node (Prim))) = |
| Etype (Next_Formal (First_Formal (Node (Prim)))) |
| and then Base_Type (Etype (Node (Prim))) = Standard_Boolean |
| |
| then |
| Eq_Needed := False; |
| exit; |
| |
| -- If the parent equality is abstract, the inherited equality is |
| -- abstract as well, and no body can be created for for it. |
| |
| elsif Chars (Node (Prim)) = Name_Op_Eq |
| and then Present (Alias (Node (Prim))) |
| and then Is_Abstract (Alias (Node (Prim))) |
| then |
| Eq_Needed := False; |
| exit; |
| end if; |
| |
| Next_Elmt (Prim); |
| end loop; |
| |
| -- If a renaming of predefined equality was found |
| -- but there was no user-defined equality (so Eq_Needed |
| -- is still true), then set the name back to Name_Op_Eq. |
| -- But in the case where a user-defined equality was |
| -- located after such a renaming, then the predefined |
| -- equality function is still needed, so Eq_Needed must |
| -- be set back to True. |
| |
| if Eq_Name /= Name_Op_Eq then |
| if Eq_Needed then |
| Eq_Name := Name_Op_Eq; |
| else |
| Eq_Needed := True; |
| end if; |
| end if; |
| |
| if Eq_Needed then |
| Eq_Spec := Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Tag_Typ, |
| Name => Eq_Name, |
| Profile => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_X), |
| Parameter_Type => New_Reference_To (Tag_Typ, Loc)), |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_Y), |
| Parameter_Type => New_Reference_To (Tag_Typ, Loc))), |
| Ret_Type => Standard_Boolean); |
| Append_To (Res, Eq_Spec); |
| |
| if Eq_Name /= Name_Op_Eq then |
| Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec)); |
| |
| Prim := First_Elmt (Primitive_Operations (Tag_Typ)); |
| while Present (Prim) loop |
| |
| -- Any renamings of equality that appeared before an |
| -- overriding equality must be updated to refer to |
| -- the entity for the predefined equality, otherwise |
| -- calls via the renaming would get incorrectly |
| -- resolved to call the user-defined equality function. |
| |
| if Is_Predefined_Eq_Renaming (Node (Prim)) then |
| Set_Alias (Node (Prim), Renamed_Eq); |
| |
| -- Exit upon encountering a user-defined equality |
| |
| elsif Chars (Node (Prim)) = Name_Op_Eq |
| and then No (Alias (Node (Prim))) |
| then |
| exit; |
| end if; |
| |
| Next_Elmt (Prim); |
| end loop; |
| end if; |
| end if; |
| |
| -- Spec for dispatching assignment |
| |
| Append_To (Res, Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Tag_Typ, |
| Name => Name_uAssign, |
| Profile => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), |
| Out_Present => True, |
| Parameter_Type => New_Reference_To (Tag_Typ, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), |
| Parameter_Type => New_Reference_To (Tag_Typ, Loc))))); |
| end if; |
| |
| -- Generate the declarations for the following primitive operations: |
| |
| -- disp_asynchronous_select |
| -- disp_conditional_select |
| -- disp_get_prim_op_kind |
| -- disp_get_task_id |
| -- disp_timed_select |
| |
| -- for limited interfaces and synchronized types that implement a |
| -- limited interface. |
| |
| if Ada_Version >= Ada_05 |
| and then |
| ((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ)) |
| or else |
| (Is_Concurrent_Record_Type (Tag_Typ) |
| and then Implements_Interface ( |
| Typ => Tag_Typ, |
| Kind => Any_Limited_Interface, |
| Check_Parent => True))) |
| then |
| Append_To (Res, |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); |
| |
| Append_To (Res, |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Conditional_Select_Spec (Tag_Typ))); |
| |
| Append_To (Res, |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); |
| |
| Append_To (Res, |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Get_Task_Id_Spec (Tag_Typ))); |
| |
| Append_To (Res, |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Timed_Select_Spec (Tag_Typ))); |
| end if; |
| |
| -- Specs for finalization actions that may be required in case a |
| -- future extension contain a controlled element. We generate those |
| -- only for root tagged types where they will get dummy bodies or |
| -- when the type has controlled components and their body must be |
| -- generated. It is also impossible to provide those for tagged |
| -- types defined within s-finimp since it would involve circularity |
| -- problems |
| |
| if In_Finalization_Root (Tag_Typ) then |
| null; |
| |
| -- We also skip these if finalization is not available |
| |
| elsif Restriction_Active (No_Finalization) then |
| null; |
| |
| elsif Etype (Tag_Typ) = Tag_Typ or else Controlled_Type (Tag_Typ) then |
| if not Is_Limited_Type (Tag_Typ) then |
| Append_To (Res, |
| Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust)); |
| end if; |
| |
| Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize)); |
| end if; |
| |
| Predef_List := Res; |
| end Make_Predefined_Primitive_Specs; |
| |
| --------------------------------- |
| -- Needs_Simple_Initialization -- |
| --------------------------------- |
| |
| function Needs_Simple_Initialization (T : Entity_Id) return Boolean is |
| begin |
| -- Check for private type, in which case test applies to the |
| -- underlying type of the private type. |
| |
| if Is_Private_Type (T) then |
| declare |
| RT : constant Entity_Id := Underlying_Type (T); |
| |
| begin |
| if Present (RT) then |
| return Needs_Simple_Initialization (RT); |
| else |
| return False; |
| end if; |
| end; |
| |
| -- Cases needing simple initialization are access types, and, if pragma |
| -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar |
| -- types. |
| |
| elsif Is_Access_Type (T) |
| or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T))) |
| then |
| return True; |
| |
| -- If Initialize/Normalize_Scalars is in effect, string objects also |
| -- need initialization, unless they are created in the course of |
| -- expanding an aggregate (since in the latter case they will be |
| -- filled with appropriate initializing values before they are used). |
| |
| elsif Init_Or_Norm_Scalars |
| and then |
| (Root_Type (T) = Standard_String |
| or else Root_Type (T) = Standard_Wide_String |
| or else Root_Type (T) = Standard_Wide_Wide_String) |
| and then |
| (not Is_Itype (T) |
| or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate) |
| then |
| return True; |
| |
| else |
| return False; |
| end if; |
| end Needs_Simple_Initialization; |
| |
| ---------------------- |
| -- Predef_Deep_Spec -- |
| ---------------------- |
| |
| function Predef_Deep_Spec |
| (Loc : Source_Ptr; |
| Tag_Typ : Entity_Id; |
| Name : TSS_Name_Type; |
| For_Body : Boolean := False) return Node_Id |
| is |
| Prof : List_Id; |
| Type_B : Entity_Id; |
| |
| begin |
| if Name = TSS_Deep_Finalize then |
| Prof := New_List; |
| Type_B := Standard_Boolean; |
| |
| else |
| Prof := New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_L), |
| In_Present => True, |
| Out_Present => True, |
| Parameter_Type => |
| New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); |
| Type_B := Standard_Short_Short_Integer; |
| end if; |
| |
| Append_To (Prof, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), |
| In_Present => True, |
| Out_Present => True, |
| Parameter_Type => New_Reference_To (Tag_Typ, Loc))); |
| |
| Append_To (Prof, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_B), |
| Parameter_Type => New_Reference_To (Type_B, Loc))); |
| |
| return Predef_Spec_Or_Body (Loc, |
| Name => Make_TSS_Name (Tag_Typ, Name), |
| Tag_Typ => Tag_Typ, |
| Profile => Prof, |
| For_Body => For_Body); |
| |
| exception |
| when RE_Not_Available => |
| return Empty; |
| end Predef_Deep_Spec; |
| |
| ------------------------- |
| -- Predef_Spec_Or_Body -- |
| ------------------------- |
| |
| function Predef_Spec_Or_Body |
| (Loc : Source_Ptr; |
| Tag_Typ : Entity_Id; |
| Name : Name_Id; |
| Profile : List_Id; |
| Ret_Type : Entity_Id := Empty; |
| For_Body : Boolean := False) return Node_Id |
| is |
| Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name); |
| Spec : Node_Id; |
| |
| begin |
| Set_Is_Public (Id, Is_Public (Tag_Typ)); |
| |
| -- The internal flag is set to mark these declarations because |
| -- they have specific properties. First they are primitives even |
| -- if they are not defined in the type scope (the freezing point |
| -- is not necessarily in the same scope), furthermore the |
| -- predefined equality can be overridden by a user-defined |
| -- equality, no body will be generated in this case. |
| |
| Set_Is_Internal (Id); |
| |
| if not Debug_Generated_Code then |
| Set_Debug_Info_Off (Id); |
| end if; |
| |
| if No (Ret_Type) then |
| Spec := |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Id, |
| Parameter_Specifications => Profile); |
| else |
| Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Id, |
| Parameter_Specifications => Profile, |
| Result_Definition => |
| New_Reference_To (Ret_Type, Loc)); |
| end if; |
| |
| -- If body case, return empty subprogram body. Note that this is |
| -- ill-formed, because there is not even a null statement, and |
| -- certainly not a return in the function case. The caller is |
| -- expected to do surgery on the body to add the appropriate stuff. |
| |
| if For_Body then |
| return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty); |
| |
| -- For the case of Input/Output attributes applied to an abstract type, |
| -- generate abstract specifications. These will never be called, |
| -- but we need the slots allocated in the dispatching table so |
| -- that typ'Class'Input and typ'Class'Output will work properly. |
| |
| elsif (Is_TSS (Name, TSS_Stream_Input) |
| or else |
| Is_TSS (Name, TSS_Stream_Output)) |
| and then Is_Abstract (Tag_Typ) |
| then |
| return Make_Abstract_Subprogram_Declaration (Loc, Spec); |
| |
| -- Normal spec case, where we return a subprogram declaration |
| |
| else |
| return Make_Subprogram_Declaration (Loc, Spec); |
| end if; |
| end Predef_Spec_Or_Body; |
| |
| ----------------------------- |
| -- Predef_Stream_Attr_Spec -- |
| ----------------------------- |
| |
| function Predef_Stream_Attr_Spec |
| (Loc : Source_Ptr; |
| Tag_Typ : Entity_Id; |
| Name : TSS_Name_Type; |
| For_Body : Boolean := False) return Node_Id |
| is |
| Ret_Type : Entity_Id; |
| |
| begin |
| if Name = TSS_Stream_Input then |
| Ret_Type := Tag_Typ; |
| else |
| Ret_Type := Empty; |
| end if; |
| |
| return Predef_Spec_Or_Body (Loc, |
| Name => Make_TSS_Name (Tag_Typ, Name), |
| Tag_Typ => Tag_Typ, |
| Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name), |
| Ret_Type => Ret_Type, |
| For_Body => For_Body); |
| end Predef_Stream_Attr_Spec; |
| |
| --------------------------------- |
| -- Predefined_Primitive_Bodies -- |
| --------------------------------- |
| |
| function Predefined_Primitive_Bodies |
| (Tag_Typ : Entity_Id; |
| Renamed_Eq : Node_Id) return List_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Tag_Typ); |
| Res : constant List_Id := New_List; |
| Decl : Node_Id; |
| Prim : Elmt_Id; |
| Eq_Needed : Boolean; |
| Eq_Name : Name_Id; |
| Ent : Entity_Id; |
| |
| begin |
| -- See if we have a predefined "=" operator |
| |
| if Present (Renamed_Eq) then |
| Eq_Needed := True; |
| Eq_Name := Chars (Renamed_Eq); |
| |
| else |
| Eq_Needed := False; |
| Eq_Name := No_Name; |
| |
| Prim := First_Elmt (Primitive_Operations (Tag_Typ)); |
| while Present (Prim) loop |
| if Chars (Node (Prim)) = Name_Op_Eq |
| and then Is_Internal (Node (Prim)) |
| then |
| Eq_Needed := True; |
| Eq_Name := Name_Op_Eq; |
| end if; |
| |
| Next_Elmt (Prim); |
| end loop; |
| end if; |
| |
| -- Body of _Alignment |
| |
| Decl := Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Tag_Typ, |
| Name => Name_uAlignment, |
| Profile => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), |
| Parameter_Type => New_Reference_To (Tag_Typ, Loc))), |
| |
| Ret_Type => Standard_Integer, |
| For_Body => True); |
| |
| Set_Handled_Statement_Sequence (Decl, |
| Make_Handled_Sequence_Of_Statements (Loc, New_List ( |
| Make_Return_Statement (Loc, |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_X), |
| Attribute_Name => Name_Alignment))))); |
| |
| Append_To (Res, Decl); |
| |
| -- Body of _Size |
| |
| Decl := Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Tag_Typ, |
| Name => Name_uSize, |
| Profile => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), |
| Parameter_Type => New_Reference_To (Tag_Typ, Loc))), |
| |
| Ret_Type => Standard_Long_Long_Integer, |
| For_Body => True); |
| |
| Set_Handled_Statement_Sequence (Decl, |
| Make_Handled_Sequence_Of_Statements (Loc, New_List ( |
| Make_Return_Statement (Loc, |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_X), |
| Attribute_Name => Name_Size))))); |
| |
| Append_To (Res, Decl); |
| |
| -- Bodies for Dispatching stream IO routines. We need these only for |
| -- non-limited types (in the limited case there is no dispatching). |
| -- We also skip them if dispatching or finalization are not available. |
| |
| if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read) |
| and then No (TSS (Tag_Typ, TSS_Stream_Read)) |
| then |
| Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent); |
| Append_To (Res, Decl); |
| end if; |
| |
| if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write) |
| and then No (TSS (Tag_Typ, TSS_Stream_Write)) |
| then |
| Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent); |
| Append_To (Res, Decl); |
| end if; |
| |
| -- Skip bodies of _Input and _Output for the abstract case, since |
| -- the corresponding specs are abstract (see Predef_Spec_Or_Body) |
| |
| if not Is_Abstract (Tag_Typ) then |
| if Stream_Operation_OK (Tag_Typ, TSS_Stream_Input) |
| and then No (TSS (Tag_Typ, TSS_Stream_Input)) |
| then |
| Build_Record_Or_Elementary_Input_Function |
| (Loc, Tag_Typ, Decl, Ent); |
| Append_To (Res, Decl); |
| end if; |
| |
| if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output) |
| and then No (TSS (Tag_Typ, TSS_Stream_Output)) |
| then |
| Build_Record_Or_Elementary_Output_Procedure |
| (Loc, Tag_Typ, Decl, Ent); |
| Append_To (Res, Decl); |
| end if; |
| end if; |
| |
| -- Generate the bodies for the following primitive operations: |
| |
| -- disp_asynchronous_select |
| -- disp_conditional_select |
| -- disp_get_prim_op_kind |
| -- disp_get_task_id |
| -- disp_timed_select |
| |
| -- for limited interfaces and synchronized types that implement a |
| -- limited interface. The interface versions will have null bodies. |
| |
| if Ada_Version >= Ada_05 |
| and then |
| not Restriction_Active (No_Dispatching_Calls) |
| and then |
| ((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ)) |
| or else |
| (Is_Concurrent_Record_Type (Tag_Typ) |
| and then Implements_Interface ( |
| Typ => Tag_Typ, |
| Kind => Any_Limited_Interface, |
| Check_Parent => True))) |
| then |
| Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); |
| Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); |
| Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ)); |
| Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ)); |
| Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ)); |
| end if; |
| |
| if not Is_Limited_Type (Tag_Typ) then |
| |
| -- Body for equality |
| |
| if Eq_Needed then |
| Decl := |
| Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Tag_Typ, |
| Name => Eq_Name, |
| Profile => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_X), |
| Parameter_Type => New_Reference_To (Tag_Typ, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_Y), |
| Parameter_Type => New_Reference_To (Tag_Typ, Loc))), |
| |
| Ret_Type => Standard_Boolean, |
| For_Body => True); |
| |
| declare |
| Def : constant Node_Id := Parent (Tag_Typ); |
| Stmts : constant List_Id := New_List; |
| Variant_Case : Boolean := Has_Discriminants (Tag_Typ); |
| Comps : Node_Id := Empty; |
| Typ_Def : Node_Id := Type_Definition (Def); |
| |
| begin |
| if Variant_Case then |
| if Nkind (Typ_Def) = N_Derived_Type_Definition then |
| Typ_Def := Record_Extension_Part (Typ_Def); |
| end if; |
| |
| if Present (Typ_Def) then |
| Comps := Component_List (Typ_Def); |
| end if; |
| |
| Variant_Case := Present (Comps) |
| and then Present (Variant_Part (Comps)); |
| end if; |
| |
| if Variant_Case then |
| Append_To (Stmts, |
| Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def))); |
| Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps)); |
| Append_To (Stmts, |
| Make_Return_Statement (Loc, |
| Expression => New_Reference_To (Standard_True, Loc))); |
| |
| else |
| Append_To (Stmts, |
| Make_Return_Statement (Loc, |
| Expression => |
| Expand_Record_Equality (Tag_Typ, |
| Typ => Tag_Typ, |
| Lhs => Make_Identifier (Loc, Name_X), |
| Rhs => Make_Identifier (Loc, Name_Y), |
| Bodies => Declarations (Decl)))); |
| end if; |
| |
| Set_Handled_Statement_Sequence (Decl, |
| Make_Handled_Sequence_Of_Statements (Loc, Stmts)); |
| end; |
| Append_To (Res, Decl); |
| end if; |
| |
| -- Body for dispatching assignment |
| |
| Decl := |
| Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Tag_Typ, |
| Name => Name_uAssign, |
| Profile => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), |
| Out_Present => True, |
| Parameter_Type => New_Reference_To (Tag_Typ, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), |
| Parameter_Type => New_Reference_To (Tag_Typ, Loc))), |
| For_Body => True); |
| |
| Set_Handled_Statement_Sequence (Decl, |
| Make_Handled_Sequence_Of_Statements (Loc, New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => Make_Identifier (Loc, Name_X), |
| Expression => Make_Identifier (Loc, Name_Y))))); |
| |
| Append_To (Res, Decl); |
| end if; |
| |
| -- Generate dummy bodies for finalization actions of types that have |
| -- no controlled components. |
| |
| -- Skip this processing if we are in the finalization routine in the |
| -- runtime itself, otherwise we get hopelessly circularly confused! |
| |
| if In_Finalization_Root (Tag_Typ) then |
| null; |
| |
| -- Skip this if finalization is not available |
| |
| elsif Restriction_Active (No_Finalization) then |
| null; |
| |
| elsif (Etype (Tag_Typ) = Tag_Typ or else Is_Controlled (Tag_Typ)) |
| and then not Has_Controlled_Component (Tag_Typ) |
| then |
| if not Is_Limited_Type (Tag_Typ) then |
| Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True); |
| |
| if Is_Controlled (Tag_Typ) then |
| Set_Handled_Statement_Sequence (Decl, |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Make_Adjust_Call ( |
| Ref => Make_Identifier (Loc, Name_V), |
| Typ => Tag_Typ, |
| Flist_Ref => Make_Identifier (Loc, Name_L), |
| With_Attach => Make_Identifier (Loc, Name_B)))); |
| |
| else |
| Set_Handled_Statement_Sequence (Decl, |
| Make_Handled_Sequence_Of_Statements (Loc, New_List ( |
| Make_Null_Statement (Loc)))); |
| end if; |
| |
| Append_To (Res, Decl); |
| end if; |
| |
| Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True); |
| |
| if Is_Controlled (Tag_Typ) then |
| Set_Handled_Statement_Sequence (Decl, |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Make_Final_Call ( |
| Ref => Make_Identifier (Loc, Name_V), |
| Typ => Tag_Typ, |
| With_Detach => Make_Identifier (Loc, Name_B)))); |
| |
| else |
| Set_Handled_Statement_Sequence (Decl, |
| Make_Handled_Sequence_Of_Statements (Loc, New_List ( |
| Make_Null_Statement (Loc)))); |
| end if; |
| |
| Append_To (Res, Decl); |
| end if; |
| |
| return Res; |
| end Predefined_Primitive_Bodies; |
| |
| --------------------------------- |
| -- Predefined_Primitive_Freeze -- |
| --------------------------------- |
| |
| function Predefined_Primitive_Freeze |
| (Tag_Typ : Entity_Id) return List_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Tag_Typ); |
| Res : constant List_Id := New_List; |
| Prim : Elmt_Id; |
| Frnodes : List_Id; |
| |
| begin |
| Prim := First_Elmt (Primitive_Operations (Tag_Typ)); |
| while Present (Prim) loop |
| if Is_Internal (Node (Prim)) then |
| Frnodes := Freeze_Entity (Node (Prim), Loc); |
| |
| if Present (Frnodes) then |
| Append_List_To (Res, Frnodes); |
| end if; |
| end if; |
| |
| Next_Elmt (Prim); |
| end loop; |
| |
| return Res; |
| end Predefined_Primitive_Freeze; |
| |
| ------------------------- |
| -- Stream_Operation_OK -- |
| ------------------------- |
| |
| function Stream_Operation_OK |
| (Typ : Entity_Id; |
| Operation : TSS_Name_Type) return Boolean |
| is |
| Has_Inheritable_Stream_Attribute : Boolean := False; |
| |
| begin |
| if Is_Limited_Type (Typ) |
| and then Is_Tagged_Type (Typ) |
| and then Is_Derived_Type (Typ) |
| then |
| -- Special case of a limited type extension: a default implementation |
| -- of the stream attributes Read and Write exists if the attribute |
| -- has been specified for an ancestor type. |
| |
| Has_Inheritable_Stream_Attribute := |
| Present (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation)); |
| end if; |
| |
| return |
| not (Is_Limited_Type (Typ) |
| and then not Has_Inheritable_Stream_Attribute) |
| and then not Has_Unknown_Discriminants (Typ) |
| and then RTE_Available (RE_Tag) |
| and then RTE_Available (RE_Root_Stream_Type) |
| and then not Restriction_Active (No_Dispatch) |
| and then not Restriction_Active (No_Streams); |
| end Stream_Operation_OK; |
| end Exp_Ch3; |