| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ C H 3 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Aspects; use Aspects; |
| with Atree; use Atree; |
| with Checks; use Checks; |
| with Contracts; use Contracts; |
| with Einfo; use Einfo; |
| with Einfo.Entities; use Einfo.Entities; |
| with Einfo.Utils; use Einfo.Utils; |
| with Errout; use Errout; |
| with Expander; use Expander; |
| with Exp_Aggr; use Exp_Aggr; |
| with Exp_Atag; use Exp_Atag; |
| with Exp_Ch4; use Exp_Ch4; |
| with Exp_Ch6; use Exp_Ch6; |
| with Exp_Ch7; use Exp_Ch7; |
| with Exp_Ch9; use Exp_Ch9; |
| with Exp_Dbug; use Exp_Dbug; |
| with Exp_Disp; use Exp_Disp; |
| with Exp_Dist; use Exp_Dist; |
| with Exp_Put_Image; |
| with Exp_Smem; use Exp_Smem; |
| with Exp_Strm; use Exp_Strm; |
| with Exp_Util; use Exp_Util; |
| with Freeze; use Freeze; |
| with Ghost; use Ghost; |
| with Lib; use Lib; |
| with Namet; use Namet; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Opt; use Opt; |
| with Restrict; use Restrict; |
| with Rident; use Rident; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_Aux; use Sem_Aux; |
| with Sem_Attr; use Sem_Attr; |
| with Sem_Cat; use Sem_Cat; |
| with Sem_Ch3; use Sem_Ch3; |
| with Sem_Ch6; use Sem_Ch6; |
| with Sem_Ch8; use Sem_Ch8; |
| with Sem_Disp; use Sem_Disp; |
| with Sem_Eval; use Sem_Eval; |
| with Sem_Mech; use Sem_Mech; |
| with Sem_Res; use Sem_Res; |
| with Sem_SCIL; use Sem_SCIL; |
| with Sem_Type; use Sem_Type; |
| with Sem_Util; use Sem_Util; |
| with Sinfo; use Sinfo; |
| with Sinfo.Nodes; use Sinfo.Nodes; |
| with Sinfo.Utils; use Sinfo.Utils; |
| with Stand; use Stand; |
| with Snames; use Snames; |
| with Tbuild; use Tbuild; |
| with Ttypes; use Ttypes; |
| with Validsw; use Validsw; |
| |
| package body Exp_Ch3 is |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Adjust_Discriminants (Rtype : Entity_Id); |
| -- This is used when freezing a record type. It attempts to construct |
| -- more restrictive subtypes for discriminants so that the max size of |
| -- the record can be calculated more accurately. See the body of this |
| -- procedure for details. |
| |
| procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id); |
| -- Build initialization procedure for given array type. Nod is a node |
| -- used for attachment of any actions required in its construction. |
| -- It also supplies the source location used for the procedure. |
| |
| function Build_Discriminant_Formals |
| (Rec_Id : Entity_Id; |
| Use_Dl : Boolean) return List_Id; |
| -- This function uses the discriminants of a type to build a list of |
| -- formal parameters, used in Build_Init_Procedure among other places. |
| -- If the flag Use_Dl is set, the list is built using the already |
| -- defined discriminals of the type, as is the case for concurrent |
| -- types with discriminants. Otherwise new identifiers are created, |
| -- with the source names of the discriminants. |
| |
| procedure Build_Discr_Checking_Funcs (N : Node_Id); |
| -- For each variant component, builds a function which checks whether |
| -- the component name is consistent with the current discriminants |
| -- and sets the component's Dcheck_Function attribute to refer to it. |
| -- N is the full type declaration node; the discriminant checking |
| -- functions are inserted after this node. |
| |
| function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id; |
| -- This function builds a static aggregate that can serve as the initial |
| -- value for an array type whose bounds are static, and whose component |
| -- type is a composite type that has a static equivalent aggregate. |
| -- The equivalent array aggregate is used both for object initialization |
| -- and for component initialization, when used in the following function. |
| |
| function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id; |
| -- This function builds a static aggregate that can serve as the initial |
| -- value for a record type whose components are scalar and initialized |
| -- with compile-time values, or arrays with similar initialization or |
| -- defaults. When possible, initialization of an object of the type can |
| -- be achieved by using a copy of the aggregate as an initial value, thus |
| -- removing the implicit call that would otherwise constitute elaboration |
| -- code. |
| |
| procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id); |
| -- Build record initialization procedure. N is the type declaration |
| -- node, and Rec_Ent is the corresponding entity for the record type. |
| |
| procedure Build_Slice_Assignment (Typ : Entity_Id); |
| -- Build assignment procedure for one-dimensional arrays of controlled |
| -- types. Other array and slice assignments are expanded in-line, but |
| -- the code expansion for controlled components (when control actions |
| -- are active) can lead to very large blocks that GCC handles poorly. |
| |
| procedure Build_Untagged_Equality (Typ : Entity_Id); |
| -- AI05-0123: Equality on untagged records composes. This procedure |
| -- builds the equality routine for an untagged record that has components |
| -- of a record type that has user-defined primitive equality operations. |
| -- The resulting operation is a TSS subprogram. |
| |
| procedure Check_Stream_Attributes (Typ : Entity_Id); |
| -- Check that if a limited extension has a parent with user-defined stream |
| -- attributes, and does not itself have user-defined stream-attributes, |
| -- then any limited component of the extension also has the corresponding |
| -- user-defined stream attributes. |
| |
| procedure Clean_Task_Names |
| (Typ : Entity_Id; |
| Proc_Id : Entity_Id); |
| -- If an initialization procedure includes calls to generate names |
| -- for task subcomponents, indicate that secondary stack cleanup is |
| -- needed after an initialization. Typ is the component type, and Proc_Id |
| -- the initialization procedure for the enclosing composite type. |
| |
| procedure Copy_Discr_Checking_Funcs (N : Node_Id); |
| -- For a derived untagged type, copy the attributes that were set |
| -- for the components of the parent type onto the components of the |
| -- derived type. No new subprograms are constructed. |
| -- N is the full type declaration node, as for Build_Discr_Checking_Funcs. |
| |
| procedure Expand_Freeze_Array_Type (N : Node_Id); |
| -- Freeze an array type. Deals with building the initialization procedure, |
| -- creating the packed array type for a packed array and also with the |
| -- creation of the controlling procedures for the controlled case. The |
| -- argument N is the N_Freeze_Entity node for the type. |
| |
| procedure Expand_Freeze_Class_Wide_Type (N : Node_Id); |
| -- Freeze a class-wide type. Build routine Finalize_Address for the purpose |
| -- of finalizing controlled derivations from the class-wide's root type. |
| |
| procedure Expand_Freeze_Enumeration_Type (N : Node_Id); |
| -- Freeze enumeration type with non-standard representation. Builds the |
| -- array and function needed to convert between enumeration pos and |
| -- enumeration representation values. N is the N_Freeze_Entity node |
| -- for the type. |
| |
| procedure Expand_Freeze_Record_Type (N : Node_Id); |
| -- Freeze record type. Builds all necessary discriminant checking |
| -- and other ancillary functions, and builds dispatch tables where |
| -- needed. The argument N is the N_Freeze_Entity node. This processing |
| -- applies only to E_Record_Type entities, not to class wide types, |
| -- record subtypes, or private types. |
| |
| procedure Expand_Tagged_Root (T : Entity_Id); |
| -- Add a field _Tag at the beginning of the record. This field carries |
| -- the value of the access to the Dispatch table. This procedure is only |
| -- called on root type, the _Tag field being inherited by the descendants. |
| |
| procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id); |
| -- Treat user-defined stream operations as renaming_as_body if the |
| -- subprogram they rename is not frozen when the type is frozen. |
| |
| package Initialization_Control is |
| |
| function Requires_Late_Init |
| (Decl : Node_Id; Rec_Type : Entity_Id) return Boolean; |
| -- Return True iff the given component declaration requires late |
| -- initialization, as defined by 3.3.1 (8.1/5). |
| |
| function Has_Late_Init_Component |
| (Tagged_Rec_Type : Entity_Id) return Boolean; |
| -- Return True iff the given tagged record type has at least one |
| -- component that requires late initialization; this includes |
| -- components of ancestor types. |
| |
| type Initialization_Mode is |
| (Full_Init, Full_Init_Except_Tag, Early_Init_Only, Late_Init_Only); |
| -- The initialization routine for a tagged type is passed in a |
| -- formal parameter of this type, indicating what initialization |
| -- is to be performed. This parameter defaults to Full_Init in all |
| -- cases except when the init proc of a type extension (let's call |
| -- that type T2) calls the init proc of its parent (let's call that |
| -- type T1). In that case, one of the other 3 values will |
| -- be passed in. In all three of those cases, the Tag component has |
| -- already been initialized before the call and is therefore not to be |
| -- modified. T2's init proc will either call T1's init proc |
| -- once (with Full_Init_Except_Tag as the parameter value) or twice |
| -- (first with Early_Init_Only, then later with Late_Init_Only), |
| -- depending on the result returned by Has_Late_Init_Component (T1). |
| -- In the latter case, the first call does not initialize any |
| -- components that require late initialization and the second call |
| -- then performs that deferred initialization. |
| -- Strictly speaking, the formal parameter subtype is actually Natural |
| -- but calls will only pass in values corresponding to literals |
| -- of this enumeration type. |
| |
| function Make_Mode_Literal |
| (Loc : Source_Ptr; Mode : Initialization_Mode) return Node_Id |
| is (Make_Integer_Literal (Loc, Initialization_Mode'Pos (Mode))); |
| -- Generate an integer literal for a given mode value. |
| |
| function Tag_Init_Condition |
| (Loc : Source_Ptr; |
| Init_Control_Formal : Entity_Id) return Node_Id; |
| function Early_Init_Condition |
| (Loc : Source_Ptr; |
| Init_Control_Formal : Entity_Id) return Node_Id; |
| function Late_Init_Condition |
| (Loc : Source_Ptr; |
| Init_Control_Formal : Entity_Id) return Node_Id; |
| -- These three functions each return a Boolean expression that |
| -- can be used to determine whether a given call to the initialization |
| -- expression for a tagged type should initialize (respectively) |
| -- the Tag component, the non-Tag components that do not require late |
| -- initialization, and the components that do require late |
| -- initialization. |
| |
| end Initialization_Control; |
| |
| procedure Initialization_Warning (E : Entity_Id); |
| -- If static elaboration of the package is requested, indicate |
| -- when a type does meet the conditions for static initialization. If |
| -- E is a type, it has components that have no static initialization. |
| -- if E is an entity, its initial expression is not compile-time known. |
| |
| function Init_Formals (Typ : Entity_Id; Proc_Id : 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 and Proc_Id is decorated with attribute Has_Master_Entity: |
| -- |
| -- _Master : Master_Id |
| -- _Chain : in out Activation_Chain |
| -- _Task_Name : String |
| -- |
| -- The caller must append additional entries for discriminants if required. |
| |
| function Inline_Init_Proc (Typ : Entity_Id) return Boolean; |
| -- Returns true if the initialization procedure of Typ should be inlined |
| |
| function In_Runtime (E : Entity_Id) return Boolean; |
| -- Check if E is defined in the RTL (in a child of Ada or System). Used |
| -- to avoid to bring in the overhead of _Input, _Output for tagged types. |
| |
| function Is_Null_Statement_List (Stmts : List_Id) return Boolean; |
| -- Returns true if Stmts is made of null statements only, possibly wrapped |
| -- in a case statement, recursively. This latter pattern may occur for the |
| -- initialization procedure of an unchecked union. |
| |
| function Make_Eq_Body |
| (Typ : Entity_Id; |
| Eq_Name : Name_Id) return Node_Id; |
| -- Build the body of a primitive equality operation for a tagged record |
| -- type, or in Ada 2012 for any record type that has components with a |
| -- user-defined equality. Factored out of Predefined_Primitive_Bodies. |
| |
| function Make_Eq_Case |
| (E : Entity_Id; |
| CL : Node_Id; |
| Discrs : Elist_Id := New_Elmt_List) return List_Id; |
| -- Building block for variant record equality. Defined to share the code |
| -- between the tagged and untagged case. Given a Component_List node CL, |
| -- it generates an 'if' followed by a 'case' statement that compares all |
| -- components of local temporaries named X and Y (that are declared as |
| -- formals at some upper level). E provides the Sloc to be used for the |
| -- generated code. |
| -- |
| -- IF E is an unchecked_union, Discrs is the list of formals created for |
| -- the inferred discriminants of one operand. These formals are used in |
| -- the generated case statements for each variant of the unchecked union. |
| |
| function Make_Eq_If |
| (E : Entity_Id; |
| L : List_Id) return Node_Id; |
| -- Building block for variant record equality. Defined to share the code |
| -- between the tagged and untagged case. Given the list of components |
| -- (or discriminants) L, it generates a return statement that compares all |
| -- components of local temporaries named X and Y (that are declared as |
| -- formals at some upper level). E provides the Sloc to be used for the |
| -- generated code. |
| |
| function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id; |
| -- Search for a renaming of the inequality dispatching primitive of |
| -- this tagged type. If found then build and return the corresponding |
| -- rename-as-body inequality subprogram; otherwise return Empty. |
| |
| procedure Make_Predefined_Primitive_Specs |
| (Tag_Typ : Entity_Id; |
| Predef_List : out List_Id; |
| Renamed_Eq : out Entity_Id); |
| -- Create a list with the specs of the predefined primitive operations. |
| -- For tagged types that are interfaces all these primitives are defined |
| -- abstract. |
| -- |
| -- The following entries are present for all tagged types, and provide |
| -- the results of the corresponding attribute applied to the object. |
| -- Dispatching is required in general, since the result of the attribute |
| -- will vary with the actual object subtype. |
| -- |
| -- _size provides result of 'Size attribute |
| -- typSR provides result of 'Read attribute |
| -- typSW provides result of 'Write attribute |
| -- typSI provides result of 'Input attribute |
| -- typSO provides result of 'Output attribute |
| -- typPI provides result of 'Put_Image attribute |
| -- |
| -- The following entries are additionally present for non-limited tagged |
| -- types, and implement additional dispatching operations for predefined |
| -- operations: |
| -- |
| -- _equality implements "=" operator |
| -- _assign implements assignment operation |
| -- typDF implements deep finalization |
| -- typDA implements deep adjust |
| -- |
| -- The latter two are empty procedures unless the type contains some |
| -- controlled components that require finalization actions (the deep |
| -- in the name refers to the fact that the action applies to components). |
| -- |
| -- The list of specs is returned in Predef_List |
| |
| function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean; |
| -- Returns True if there are representation clauses for type T that are not |
| -- inherited. If the result is false, the init_proc and the discriminant |
| -- checking functions of the parent can be reused by a derived type. |
| |
| function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id; |
| -- Ada 2005 (AI-251): Makes specs for null procedures associated with any |
| -- null procedures inherited from an interface type that have not been |
| -- overridden. Only one null procedure will be created for a given set of |
| -- inherited null procedures with homographic profiles. |
| |
| function Predef_Spec_Or_Body |
| (Loc : Source_Ptr; |
| Tag_Typ : Entity_Id; |
| Name : Name_Id; |
| Profile : List_Id; |
| Ret_Type : Entity_Id := Empty; |
| For_Body : Boolean := False) return Node_Id; |
| -- This function generates the appropriate expansion for a predefined |
| -- primitive operation specified by its name, parameter profile and |
| -- return type (Empty means this is a procedure). If For_Body is false, |
| -- then the returned node is a subprogram declaration. If For_Body is |
| -- true, then the returned node is a empty subprogram body containing |
| -- no declarations and no statements. |
| |
| function Predef_Stream_Attr_Spec |
| (Loc : Source_Ptr; |
| Tag_Typ : Entity_Id; |
| Name : TSS_Name_Type) return Node_Id; |
| -- Specialized version of Predef_Spec_Or_Body that apply to read, write, |
| -- input and output attribute whose specs are constructed in Exp_Strm. |
| |
| function Predef_Deep_Spec |
| (Loc : Source_Ptr; |
| Tag_Typ : Entity_Id; |
| Name : TSS_Name_Type; |
| For_Body : Boolean := False) return Node_Id; |
| -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust |
| -- and _deep_finalize |
| |
| function Predefined_Primitive_Bodies |
| (Tag_Typ : Entity_Id; |
| Renamed_Eq : Entity_Id) return List_Id; |
| -- Create the bodies of the predefined primitives that are described in |
| -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote |
| -- the defining unit name of the type's predefined equality as returned |
| -- by Make_Predefined_Primitive_Specs. |
| |
| function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id; |
| -- Freeze entities of all predefined primitive operations. This is needed |
| -- because the bodies of these operations do not normally do any freezing. |
| |
| -------------------------- |
| -- Adjust_Discriminants -- |
| -------------------------- |
| |
| -- This procedure attempts to define subtypes for discriminants that are |
| -- more restrictive than those declared. Such a replacement is possible if |
| -- we can demonstrate that values outside the restricted range would cause |
| -- constraint errors in any case. The advantage of restricting the |
| -- discriminant types in this way is that the maximum size of the variant |
| -- record can be calculated more conservatively. |
| |
| -- An example of a situation in which we can perform this type of |
| -- restriction is the following: |
| |
| -- subtype B is range 1 .. 10; |
| -- type Q is array (B range <>) of Integer; |
| |
| -- type V (N : Natural) is record |
| -- C : Q (1 .. N); |
| -- end record; |
| |
| -- In this situation, we can restrict the upper bound of N to 10, since |
| -- any larger value would cause a constraint error in any case. |
| |
| -- There are many situations in which such restriction is possible, but |
| -- for now, we just look for cases like the above, where the component |
| -- in question is a one dimensional array whose upper bound is one of |
| -- the record discriminants. Also the component must not be part of |
| -- any variant part, since then the component does not always exist. |
| |
| procedure Adjust_Discriminants (Rtype : Entity_Id) is |
| Loc : constant Source_Ptr := Sloc (Rtype); |
| Comp : Entity_Id; |
| Ctyp : Entity_Id; |
| Ityp : Entity_Id; |
| Lo : Node_Id; |
| Hi : Node_Id; |
| P : Node_Id; |
| Loval : Uint; |
| Discr : Entity_Id; |
| Dtyp : Entity_Id; |
| Dhi : Node_Id; |
| Dhiv : Uint; |
| Ahi : Node_Id; |
| Ahiv : Uint; |
| Tnn : Entity_Id; |
| |
| begin |
| Comp := First_Component (Rtype); |
| while Present (Comp) loop |
| |
| -- If our parent is a variant, quit, we do not look at components |
| -- that are in variant parts, because they may not always exist. |
| |
| P := Parent (Comp); -- component declaration |
| P := Parent (P); -- component list |
| |
| exit when Nkind (Parent (P)) = N_Variant; |
| |
| -- We are looking for a one dimensional array type |
| |
| Ctyp := Etype (Comp); |
| |
| if not Is_Array_Type (Ctyp) or else Number_Dimensions (Ctyp) > 1 then |
| goto Continue; |
| end if; |
| |
| -- The lower bound must be constant, and the upper bound is a |
| -- discriminant (which is a discriminant of the current record). |
| |
| Ityp := Etype (First_Index (Ctyp)); |
| Lo := Type_Low_Bound (Ityp); |
| Hi := Type_High_Bound (Ityp); |
| |
| if not Compile_Time_Known_Value (Lo) |
| or else Nkind (Hi) /= N_Identifier |
| or else No (Entity (Hi)) |
| or else Ekind (Entity (Hi)) /= E_Discriminant |
| then |
| goto Continue; |
| end if; |
| |
| -- We have an array with appropriate bounds |
| |
| Loval := Expr_Value (Lo); |
| Discr := Entity (Hi); |
| Dtyp := Etype (Discr); |
| |
| -- See if the discriminant has a known upper bound |
| |
| Dhi := Type_High_Bound (Dtyp); |
| |
| if not Compile_Time_Known_Value (Dhi) then |
| goto Continue; |
| end if; |
| |
| Dhiv := Expr_Value (Dhi); |
| |
| -- See if base type of component array has known upper bound |
| |
| Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp)))); |
| |
| if not Compile_Time_Known_Value (Ahi) then |
| goto Continue; |
| end if; |
| |
| Ahiv := Expr_Value (Ahi); |
| |
| -- The condition for doing the restriction is that the high bound |
| -- of the discriminant is greater than the low bound of the array, |
| -- and is also greater than the high bound of the base type index. |
| |
| if Dhiv > Loval and then Dhiv > Ahiv then |
| |
| -- We can reset the upper bound of the discriminant type to |
| -- whichever is larger, the low bound of the component, or |
| -- the high bound of the base type array index. |
| |
| -- We build a subtype that is declared as |
| |
| -- subtype Tnn is discr_type range discr_type'First .. max; |
| |
| -- And insert this declaration into the tree. The type of the |
| -- discriminant is then reset to this more restricted subtype. |
| |
| Tnn := Make_Temporary (Loc, 'T'); |
| |
| Insert_Action (Declaration_Node (Rtype), |
| Make_Subtype_Declaration (Loc, |
| Defining_Identifier => Tnn, |
| Subtype_Indication => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => New_Occurrence_Of (Dtyp, Loc), |
| Constraint => |
| Make_Range_Constraint (Loc, |
| Range_Expression => |
| Make_Range (Loc, |
| Low_Bound => |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Name_First, |
| Prefix => New_Occurrence_Of (Dtyp, Loc)), |
| High_Bound => |
| Make_Integer_Literal (Loc, |
| Intval => UI_Max (Loval, Ahiv))))))); |
| |
| Set_Etype (Discr, Tnn); |
| end if; |
| |
| <<Continue>> |
| Next_Component (Comp); |
| end loop; |
| end Adjust_Discriminants; |
| |
| ------------------------------------------ |
| -- Build_Access_Subprogram_Wrapper_Body -- |
| ------------------------------------------ |
| |
| procedure Build_Access_Subprogram_Wrapper_Body |
| (Decl : Node_Id; |
| New_Decl : Node_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Decl); |
| Actuals : constant List_Id := New_List; |
| Type_Def : constant Node_Id := Type_Definition (Decl); |
| Type_Id : constant Entity_Id := Defining_Identifier (Decl); |
| Spec_Node : constant Node_Id := |
| Copy_Subprogram_Spec (Specification (New_Decl)); |
| -- This copy creates new identifiers for formals and subprogram. |
| |
| Act : Node_Id; |
| Body_Node : Node_Id; |
| Call_Stmt : Node_Id; |
| Ptr : Entity_Id; |
| |
| begin |
| if not Expander_Active then |
| return; |
| end if; |
| |
| -- Create List of actuals for indirect call. The last parameter of the |
| -- subprogram declaration is the access value for the indirect call. |
| |
| Act := First (Parameter_Specifications (Spec_Node)); |
| |
| while Present (Act) loop |
| exit when Act = Last (Parameter_Specifications (Spec_Node)); |
| Append_To (Actuals, |
| Make_Identifier (Loc, Chars (Defining_Identifier (Act)))); |
| Next (Act); |
| end loop; |
| |
| Ptr := |
| Defining_Identifier |
| (Last (Parameter_Specifications (Specification (New_Decl)))); |
| |
| if Nkind (Type_Def) = N_Access_Procedure_Definition then |
| Call_Stmt := Make_Procedure_Call_Statement (Loc, |
| Name => |
| Make_Explicit_Dereference |
| (Loc, New_Occurrence_Of (Ptr, Loc)), |
| Parameter_Associations => Actuals); |
| else |
| Call_Stmt := Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Function_Call (Loc, |
| Name => Make_Explicit_Dereference |
| (Loc, New_Occurrence_Of (Ptr, Loc)), |
| Parameter_Associations => Actuals)); |
| end if; |
| |
| Body_Node := Make_Subprogram_Body (Loc, |
| Specification => Spec_Node, |
| Declarations => New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Call_Stmt))); |
| |
| -- Place body in list of freeze actions for the type. |
| |
| Append_Freeze_Action (Type_Id, Body_Node); |
| end Build_Access_Subprogram_Wrapper_Body; |
| |
| --------------------------- |
| -- Build_Array_Init_Proc -- |
| --------------------------- |
| |
| procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is |
| Comp_Type : constant Entity_Id := Component_Type (A_Type); |
| Comp_Simple_Init : constant Boolean := |
| Needs_Simple_Initialization |
| (Typ => Comp_Type, |
| Consider_IS => |
| not (Validity_Check_Copies and Is_Bit_Packed_Array (A_Type))); |
| -- True if the component needs simple initialization, based on its type, |
| -- plus the fact that we do not do simple initialization for components |
| -- of bit-packed arrays when validity checks are enabled, because the |
| -- initialization with deliberately out-of-range values would raise |
| -- Constraint_Error. |
| |
| Body_Stmts : List_Id; |
| Has_Default_Init : Boolean; |
| Index_List : List_Id; |
| Loc : Source_Ptr; |
| Parameters : List_Id; |
| Proc_Id : Entity_Id; |
| |
| function Init_Component return List_Id; |
| -- Create one statement to initialize one array component, designated |
| -- by a full set of indexes. |
| |
| function Init_One_Dimension (N : Int) return List_Id; |
| -- Create loop to initialize one dimension of the array. The single |
| -- statement in the loop body initializes the inner dimensions if any, |
| -- or else the single component. Note that this procedure is called |
| -- recursively, with N being the dimension to be initialized. A call |
| -- with N greater than the number of dimensions simply generates the |
| -- component initialization, terminating the recursion. |
| |
| -------------------- |
| -- Init_Component -- |
| -------------------- |
| |
| function Init_Component return List_Id is |
| Comp : Node_Id; |
| |
| begin |
| Comp := |
| Make_Indexed_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Expressions => Index_List); |
| |
| if Has_Default_Aspect (A_Type) then |
| Set_Assignment_OK (Comp); |
| return New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => Comp, |
| Expression => |
| Convert_To (Comp_Type, |
| Default_Aspect_Component_Value (First_Subtype (A_Type))))); |
| |
| elsif Comp_Simple_Init then |
| Set_Assignment_OK (Comp); |
| return New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => Comp, |
| Expression => |
| Get_Simple_Init_Val |
| (Typ => Comp_Type, |
| N => Nod, |
| Size => Component_Size (A_Type)))); |
| |
| else |
| Clean_Task_Names (Comp_Type, Proc_Id); |
| return |
| Build_Initialization_Call |
| (Loc => Loc, |
| Id_Ref => Comp, |
| Typ => Comp_Type, |
| In_Init_Proc => True, |
| Enclos_Type => A_Type); |
| end if; |
| end Init_Component; |
| |
| ------------------------ |
| -- Init_One_Dimension -- |
| ------------------------ |
| |
| function Init_One_Dimension (N : Int) return List_Id is |
| Index : Entity_Id; |
| DIC_Call : Node_Id; |
| Result_List : List_Id; |
| |
| function Possible_DIC_Call return Node_Id; |
| -- If the component type has Default_Initial_Conditions and a DIC |
| -- procedure that is not an empty body, then builds a call to the |
| -- DIC procedure and returns it. |
| |
| ----------------------- |
| -- Possible_DIC_Call -- |
| ----------------------- |
| |
| function Possible_DIC_Call return Node_Id is |
| begin |
| -- When the component's type has a Default_Initial_Condition, then |
| -- create a call for the DIC check. |
| |
| if Has_DIC (Comp_Type) |
| -- In GNATprove mode, the component DICs are checked by other |
| -- means. They should not be added to the record type DIC |
| -- procedure, so that the procedure can be used to check the |
| -- record type invariants or DICs if any. |
| |
| and then not GNATprove_Mode |
| |
| -- DIC checks for components of controlled types are done later |
| -- (see Exp_Ch7.Make_Deep_Array_Body). |
| |
| and then not Is_Controlled (Comp_Type) |
| |
| and then Present (DIC_Procedure (Comp_Type)) |
| |
| and then not Has_Null_Body (DIC_Procedure (Comp_Type)) |
| then |
| return |
| Build_DIC_Call (Loc, |
| Make_Indexed_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Expressions => Index_List), |
| Comp_Type); |
| else |
| return Empty; |
| end if; |
| end Possible_DIC_Call; |
| |
| -- Start of processing for Init_One_Dimension |
| |
| 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. |
| -- An exception is if component type has a Default_Initial_Condition, |
| -- in which case we generate a call to the type's DIC procedure. |
| |
| if not Has_Non_Null_Base_Init_Proc (Comp_Type) |
| and then not Comp_Simple_Init |
| and then not Has_Task (Comp_Type) |
| and then not Has_Default_Aspect (A_Type) |
| and then (not Has_DIC (Comp_Type) |
| or else N > Number_Dimensions (A_Type)) |
| then |
| DIC_Call := Possible_DIC_Call; |
| |
| if Present (DIC_Call) then |
| return New_List (DIC_Call); |
| else |
| return New_List (Make_Null_Statement (Loc)); |
| end if; |
| |
| -- If all dimensions dealt with, we simply initialize the component |
| -- and append a call to component type's DIC procedure when needed. |
| |
| elsif N > Number_Dimensions (A_Type) then |
| DIC_Call := Possible_DIC_Call; |
| |
| if Present (DIC_Call) then |
| Result_List := Init_Component; |
| Append (DIC_Call, Result_List); |
| return Result_List; |
| |
| else |
| return Init_Component; |
| end if; |
| |
| -- Here we generate the required loop |
| |
| else |
| Index := |
| Make_Defining_Identifier (Loc, New_External_Name ('J', N)); |
| |
| Append (New_Occurrence_Of (Index, Loc), Index_List); |
| |
| return New_List ( |
| Make_Implicit_Loop_Statement (Nod, |
| Identifier => Empty, |
| Iteration_Scheme => |
| Make_Iteration_Scheme (Loc, |
| Loop_Parameter_Specification => |
| Make_Loop_Parameter_Specification (Loc, |
| Defining_Identifier => Index, |
| Discrete_Subtype_Definition => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Identifier (Loc, Name_uInit), |
| Attribute_Name => Name_Range, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, N))))), |
| Statements => Init_One_Dimension (N + 1))); |
| end if; |
| end Init_One_Dimension; |
| |
| -- Start of processing for Build_Array_Init_Proc |
| |
| begin |
| -- The init proc is created when analyzing the freeze node for the type, |
| -- but it properly belongs with the array type declaration. However, if |
| -- the freeze node is for a subtype of a type declared in another unit |
| -- it seems preferable to use the freeze node as the source location of |
| -- the init proc. In any case this is preferable for gcov usage, and |
| -- the Sloc is not otherwise used by the compiler. |
| |
| if In_Open_Scopes (Scope (A_Type)) then |
| Loc := Sloc (A_Type); |
| else |
| Loc := Sloc (Nod); |
| end if; |
| |
| -- Nothing to generate in the following cases: |
| |
| -- 1. Initialization is suppressed for the type |
| -- 2. An initialization already exists for the base type |
| |
| if Initialization_Suppressed (A_Type) |
| or else Present (Base_Init_Proc (A_Type)) |
| then |
| return; |
| end if; |
| |
| Index_List := New_List; |
| |
| -- We need an initialization procedure if any of the following is true: |
| |
| -- 1. The component type has an initialization procedure |
| -- 2. The component type needs simple initialization |
| -- 3. Tasks are present |
| -- 4. The type is marked as a public entity |
| -- 5. The array type has a Default_Component_Value aspect |
| -- 6. The array component type has a Default_Initialization_Condition |
| |
| -- The reason for the public entity test is to deal properly with the |
| -- Initialize_Scalars pragma. This pragma can be set in the client and |
| -- not in the declaring package, this means the client will make a call |
| -- to the initialization procedure (because one of conditions 1-3 must |
| -- apply in this case), and we must generate a procedure (even if it is |
| -- null) to satisfy the call in this case. |
| |
| -- Exception: do not build an array init_proc for a type whose root |
| -- type is Standard.String or Standard.Wide_[Wide_]String, since there |
| -- is no place to put the code, and in any case we handle initialization |
| -- of such types (in the Initialize_Scalars case, that's the only time |
| -- the issue arises) in a special manner anyway which does not need an |
| -- init_proc. |
| |
| Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type) |
| or else Comp_Simple_Init |
| or else Has_Task (Comp_Type) |
| or else Has_Default_Aspect (A_Type) |
| or else Has_DIC (Comp_Type); |
| |
| if Has_Default_Init |
| or else (not Restriction_Active (No_Initialize_Scalars) |
| and then Is_Public (A_Type) |
| and then not Is_Standard_String_Type (A_Type)) |
| then |
| Proc_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Make_Init_Proc_Name (A_Type)); |
| |
| -- If No_Default_Initialization restriction is active, then we don't |
| -- want to build an init_proc, but we need to mark that an init_proc |
| -- would be needed if this restriction was not active (so that we can |
| -- detect attempts to call it), so set a dummy init_proc in place. |
| -- This is only done though when actual default initialization is |
| -- needed (and not done when only Is_Public is True), since otherwise |
| -- objects such as arrays of scalars could be wrongly flagged as |
| -- violating the restriction. |
| |
| if Restriction_Active (No_Default_Initialization) then |
| if Has_Default_Init then |
| Set_Init_Proc (A_Type, Proc_Id); |
| end if; |
| |
| return; |
| end if; |
| |
| Body_Stmts := Init_One_Dimension (1); |
| Parameters := Init_Formals (A_Type, Proc_Id); |
| |
| Discard_Node ( |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Proc_Id, |
| Parameter_Specifications => Parameters), |
| Declarations => New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Body_Stmts))); |
| |
| Mutate_Ekind (Proc_Id, E_Procedure); |
| Set_Is_Public (Proc_Id, Is_Public (A_Type)); |
| Set_Is_Internal (Proc_Id); |
| Set_Has_Completion (Proc_Id); |
| |
| if not Debug_Generated_Code then |
| Set_Debug_Info_Off (Proc_Id); |
| end if; |
| |
| -- Set Inlined on Init_Proc if it is set on the Init_Proc of the |
| -- component type itself (see also Build_Record_Init_Proc). |
| |
| Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Comp_Type)); |
| |
| -- Associate Init_Proc with type, and determine if the procedure |
| -- is null (happens because of the Initialize_Scalars pragma case, |
| -- where we have to generate a null procedure in case it is called |
| -- by a client with Initialize_Scalars set). Such procedures have |
| -- to be generated, but do not have to be called, so we mark them |
| -- as null to suppress the call. Kill also warnings for the _Init |
| -- out parameter, which is left entirely uninitialized. |
| |
| Set_Init_Proc (A_Type, Proc_Id); |
| |
| if Is_Null_Statement_List (Body_Stmts) then |
| Set_Is_Null_Init_Proc (Proc_Id); |
| Set_Warnings_Off (Defining_Identifier (First (Parameters))); |
| |
| else |
| -- Try to build a static aggregate to statically initialize |
| -- objects of the type. This can only be done for constrained |
| -- one-dimensional arrays with static bounds. |
| |
| Set_Static_Initialization |
| (Proc_Id, |
| Build_Equivalent_Array_Aggregate (First_Subtype (A_Type))); |
| end if; |
| end if; |
| end Build_Array_Init_Proc; |
| |
| -------------------------------- |
| -- Build_Discr_Checking_Funcs -- |
| -------------------------------- |
| |
| procedure Build_Discr_Checking_Funcs (N : Node_Id) is |
| Rec_Id : Entity_Id; |
| Loc : Source_Ptr; |
| Enclosing_Func_Id : Entity_Id; |
| Sequence : Nat := 1; |
| Type_Def : Node_Id; |
| V : Node_Id; |
| |
| function Build_Case_Statement |
| (Case_Id : Entity_Id; |
| Variant : Node_Id) return Node_Id; |
| -- Build a case statement containing only two alternatives. The first |
| -- alternative corresponds to the discrete choices given on the variant |
| -- that 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 returns 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); |
| Set_End_Span (Case_Node, Uint_0); |
| |
| -- Replace the discriminant which controls the variant with the name |
| -- of the formal of the checking function. |
| |
| Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id))); |
| |
| Choice := First (Discrete_Choices (Variant)); |
| |
| if Nkind (Choice) = N_Others_Choice then |
| Choice_List := New_Copy_List (Others_Discrete_Choices (Choice)); |
| else |
| Choice_List := New_Copy_List (Discrete_Choices (Variant)); |
| end if; |
| |
| if not Is_Empty_List (Choice_List) then |
| Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); |
| Set_Discrete_Choices (Case_Alt_Node, Choice_List); |
| |
| -- In case this is a nested variant, we need to return the result |
| -- of the discriminant checking function for the immediately |
| -- enclosing variant. |
| |
| if Present (Enclosing_Func_Id) then |
| Actuals_List := New_List; |
| |
| D := First_Discriminant (Rec_Id); |
| while Present (D) loop |
| Append (Make_Identifier (Loc, Chars (D)), Actuals_List); |
| Next_Discriminant (D); |
| end loop; |
| |
| Return_Node := |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (Enclosing_Func_Id, Loc), |
| Parameter_Associations => |
| Actuals_List)); |
| |
| else |
| Return_Node := |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| New_Occurrence_Of (Standard_False, Loc)); |
| end if; |
| |
| Set_Statements (Case_Alt_Node, New_List (Return_Node)); |
| Append (Case_Alt_Node, Alt_List); |
| end if; |
| |
| Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); |
| Choice_List := New_List (New_Node (N_Others_Choice, Loc)); |
| Set_Discrete_Choices (Case_Alt_Node, Choice_List); |
| |
| Return_Node := |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| New_Occurrence_Of (Standard_True, Loc)); |
| |
| Set_Statements (Case_Alt_Node, New_List (Return_Node)); |
| Append (Case_Alt_Node, Alt_List); |
| |
| Set_Alternatives (Case_Node, Alt_List); |
| return Case_Node; |
| end Build_Case_Statement; |
| |
| --------------------------- |
| -- Build_Dcheck_Function -- |
| --------------------------- |
| |
| function Build_Dcheck_Function |
| (Case_Id : Entity_Id; |
| Variant : Node_Id) return Entity_Id |
| is |
| Body_Node : Node_Id; |
| Func_Id : Entity_Id; |
| Parameter_List : List_Id; |
| Spec_Node : Node_Id; |
| |
| begin |
| Body_Node := New_Node (N_Subprogram_Body, Loc); |
| Sequence := Sequence + 1; |
| |
| Func_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence)); |
| Set_Is_Discriminant_Check_Function (Func_Id); |
| |
| Spec_Node := New_Node (N_Function_Specification, Loc); |
| Set_Defining_Unit_Name (Spec_Node, Func_Id); |
| |
| Parameter_List := Build_Discriminant_Formals (Rec_Id, False); |
| |
| Set_Parameter_Specifications (Spec_Node, Parameter_List); |
| Set_Result_Definition (Spec_Node, |
| New_Occurrence_Of (Standard_Boolean, Loc)); |
| Set_Specification (Body_Node, Spec_Node); |
| Set_Declarations (Body_Node, New_List); |
| |
| Set_Handled_Statement_Sequence (Body_Node, |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Build_Case_Statement (Case_Id, Variant)))); |
| |
| Mutate_Ekind (Func_Id, E_Function); |
| Set_Mechanism (Func_Id, Default_Mechanism); |
| Set_Is_Inlined (Func_Id, True); |
| Set_Is_Pure (Func_Id, True); |
| Set_Is_Public (Func_Id, Is_Public (Rec_Id)); |
| Set_Is_Internal (Func_Id, True); |
| |
| if not Debug_Generated_Code then |
| Set_Debug_Info_Off (Func_Id); |
| end if; |
| |
| Analyze (Body_Node); |
| |
| Append_Freeze_Action (Rec_Id, Body_Node); |
| Set_Dcheck_Function (Variant, Func_Id); |
| return Func_Id; |
| end Build_Dcheck_Function; |
| |
| ---------------------------- |
| -- Build_Dcheck_Functions -- |
| ---------------------------- |
| |
| procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is |
| Component_List_Node : Node_Id; |
| Decl : Entity_Id; |
| Discr_Name : Entity_Id; |
| Func_Id : Entity_Id; |
| Variant : Node_Id; |
| Saved_Enclosing_Func_Id : Entity_Id; |
| |
| begin |
| -- Build the discriminant-checking function for each variant, and |
| -- label all components of that variant with the function's name. |
| -- We only Generate a discriminant-checking function when the |
| -- variant is not empty, to prevent the creation of dead code. |
| |
| Discr_Name := Entity (Name (Variant_Part_Node)); |
| Variant := First_Non_Pragma (Variants (Variant_Part_Node)); |
| |
| while Present (Variant) loop |
| Component_List_Node := Component_List (Variant); |
| |
| if not Null_Present (Component_List_Node) then |
| Func_Id := Build_Dcheck_Function (Discr_Name, Variant); |
| |
| Decl := |
| First_Non_Pragma (Component_Items (Component_List_Node)); |
| while Present (Decl) loop |
| Set_Discriminant_Checking_Func |
| (Defining_Identifier (Decl), Func_Id); |
| Next_Non_Pragma (Decl); |
| end loop; |
| |
| if Present (Variant_Part (Component_List_Node)) then |
| Saved_Enclosing_Func_Id := Enclosing_Func_Id; |
| Enclosing_Func_Id := Func_Id; |
| Build_Dcheck_Functions (Variant_Part (Component_List_Node)); |
| Enclosing_Func_Id := Saved_Enclosing_Func_Id; |
| end if; |
| end if; |
| |
| Next_Non_Pragma (Variant); |
| end loop; |
| end Build_Dcheck_Functions; |
| |
| -- Start of processing for Build_Discr_Checking_Funcs |
| |
| begin |
| -- Only build if not done already |
| |
| if not Discr_Check_Funcs_Built (N) then |
| Type_Def := Type_Definition (N); |
| |
| if Nkind (Type_Def) = N_Record_Definition then |
| if No (Component_List (Type_Def)) then -- null record. |
| return; |
| else |
| V := Variant_Part (Component_List (Type_Def)); |
| end if; |
| |
| else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition); |
| if No (Component_List (Record_Extension_Part (Type_Def))) then |
| return; |
| else |
| V := Variant_Part |
| (Component_List (Record_Extension_Part (Type_Def))); |
| end if; |
| end if; |
| |
| Rec_Id := Defining_Identifier (N); |
| |
| if Present (V) and then not Is_Unchecked_Union (Rec_Id) then |
| Loc := Sloc (N); |
| Enclosing_Func_Id := Empty; |
| Build_Dcheck_Functions (V); |
| end if; |
| |
| Set_Discr_Check_Funcs_Built (N); |
| end if; |
| end Build_Discr_Checking_Funcs; |
| |
| ---------------------------------------- |
| -- Build_Or_Copy_Discr_Checking_Funcs -- |
| ---------------------------------------- |
| |
| procedure Build_Or_Copy_Discr_Checking_Funcs (N : Node_Id) is |
| Typ : constant Entity_Id := Defining_Identifier (N); |
| begin |
| if Is_Unchecked_Union (Typ) or else not Has_Discriminants (Typ) then |
| null; |
| elsif not Is_Derived_Type (Typ) |
| or else Has_New_Non_Standard_Rep (Typ) |
| or else Is_Tagged_Type (Typ) |
| then |
| Build_Discr_Checking_Funcs (N); |
| else |
| Copy_Discr_Checking_Funcs (N); |
| end if; |
| end Build_Or_Copy_Discr_Checking_Funcs; |
| |
| -------------------------------- |
| -- Build_Discriminant_Formals -- |
| -------------------------------- |
| |
| function Build_Discriminant_Formals |
| (Rec_Id : Entity_Id; |
| Use_Dl : Boolean) return List_Id |
| is |
| Loc : Source_Ptr := Sloc (Rec_Id); |
| Parameter_List : constant List_Id := New_List; |
| D : Entity_Id; |
| Formal : Entity_Id; |
| Formal_Type : Entity_Id; |
| Param_Spec_Node : Node_Id; |
| |
| begin |
| if Has_Discriminants (Rec_Id) then |
| D := First_Discriminant (Rec_Id); |
| while Present (D) loop |
| Loc := Sloc (D); |
| |
| if Use_Dl then |
| Formal := Discriminal (D); |
| Formal_Type := Etype (Formal); |
| else |
| Formal := Make_Defining_Identifier (Loc, Chars (D)); |
| Formal_Type := Etype (D); |
| end if; |
| |
| Param_Spec_Node := |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Formal, |
| Parameter_Type => |
| New_Occurrence_Of (Formal_Type, Loc)); |
| Append (Param_Spec_Node, Parameter_List); |
| Next_Discriminant (D); |
| end loop; |
| end if; |
| |
| return Parameter_List; |
| end Build_Discriminant_Formals; |
| |
| -------------------------------------- |
| -- Build_Equivalent_Array_Aggregate -- |
| -------------------------------------- |
| |
| function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is |
| Loc : constant Source_Ptr := Sloc (T); |
| Comp_Type : constant Entity_Id := Component_Type (T); |
| Index_Type : constant Entity_Id := Etype (First_Index (T)); |
| Proc : constant Entity_Id := Base_Init_Proc (T); |
| Lo, Hi : Node_Id; |
| Aggr : Node_Id; |
| Expr : Node_Id; |
| |
| begin |
| if not Is_Constrained (T) |
| or else Number_Dimensions (T) > 1 |
| or else No (Proc) |
| then |
| Initialization_Warning (T); |
| return Empty; |
| end if; |
| |
| Lo := Type_Low_Bound (Index_Type); |
| Hi := Type_High_Bound (Index_Type); |
| |
| if not Compile_Time_Known_Value (Lo) |
| or else not Compile_Time_Known_Value (Hi) |
| then |
| Initialization_Warning (T); |
| return Empty; |
| end if; |
| |
| if Is_Record_Type (Comp_Type) |
| and then Present (Base_Init_Proc (Comp_Type)) |
| then |
| Expr := Static_Initialization (Base_Init_Proc (Comp_Type)); |
| |
| if No (Expr) then |
| Initialization_Warning (T); |
| return Empty; |
| end if; |
| |
| else |
| Initialization_Warning (T); |
| return Empty; |
| end if; |
| |
| Aggr := Make_Aggregate (Loc, No_List, New_List); |
| Set_Etype (Aggr, T); |
| Set_Aggregate_Bounds (Aggr, |
| Make_Range (Loc, |
| Low_Bound => New_Copy (Lo), |
| High_Bound => New_Copy (Hi))); |
| Set_Parent (Aggr, Parent (Proc)); |
| |
| Append_To (Component_Associations (Aggr), |
| Make_Component_Association (Loc, |
| Choices => |
| New_List ( |
| Make_Range (Loc, |
| Low_Bound => New_Copy (Lo), |
| High_Bound => New_Copy (Hi))), |
| Expression => Expr)); |
| |
| if Static_Array_Aggregate (Aggr) then |
| return Aggr; |
| else |
| Initialization_Warning (T); |
| return Empty; |
| end if; |
| end Build_Equivalent_Array_Aggregate; |
| |
| --------------------------------------- |
| -- Build_Equivalent_Record_Aggregate -- |
| --------------------------------------- |
| |
| function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is |
| Agg : Node_Id; |
| Comp : Entity_Id; |
| Comp_Type : Entity_Id; |
| |
| begin |
| if not Is_Record_Type (T) |
| or else Has_Discriminants (T) |
| or else Is_Limited_Type (T) |
| or else Has_Non_Standard_Rep (T) |
| then |
| Initialization_Warning (T); |
| return Empty; |
| end if; |
| |
| Comp := First_Component (T); |
| |
| -- A null record needs no warning |
| |
| if No (Comp) then |
| return Empty; |
| end if; |
| |
| while Present (Comp) loop |
| |
| -- Array components are acceptable if initialized by a positional |
| -- aggregate with static components. |
| |
| if Is_Array_Type (Etype (Comp)) then |
| Comp_Type := Component_Type (Etype (Comp)); |
| |
| if Nkind (Parent (Comp)) /= N_Component_Declaration |
| or else No (Expression (Parent (Comp))) |
| or else Nkind (Expression (Parent (Comp))) /= N_Aggregate |
| then |
| Initialization_Warning (T); |
| return Empty; |
| |
| elsif Is_Scalar_Type (Component_Type (Etype (Comp))) |
| and then |
| (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type)) |
| or else |
| not Compile_Time_Known_Value (Type_High_Bound (Comp_Type))) |
| then |
| Initialization_Warning (T); |
| return Empty; |
| |
| elsif |
| not Static_Array_Aggregate (Expression (Parent (Comp))) |
| then |
| Initialization_Warning (T); |
| return Empty; |
| |
| -- We need to return empty if the type has predicates because |
| -- this would otherwise duplicate calls to the predicate |
| -- function. If the type hasn't been frozen before being |
| -- referenced in the current record, the extraneous call to |
| -- the predicate function would be inserted somewhere before |
| -- the predicate function is elaborated, which would result in |
| -- an invalid tree. |
| |
| elsif Has_Predicates (Etype (Comp)) then |
| return Empty; |
| end if; |
| |
| elsif Is_Scalar_Type (Etype (Comp)) then |
| Comp_Type := Etype (Comp); |
| |
| if Nkind (Parent (Comp)) /= N_Component_Declaration |
| or else No (Expression (Parent (Comp))) |
| or else not Compile_Time_Known_Value (Expression (Parent (Comp))) |
| or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type)) |
| or else not |
| Compile_Time_Known_Value (Type_High_Bound (Comp_Type)) |
| then |
| Initialization_Warning (T); |
| return Empty; |
| end if; |
| |
| -- For now, other types are excluded |
| |
| else |
| Initialization_Warning (T); |
| return Empty; |
| end if; |
| |
| Next_Component (Comp); |
| end loop; |
| |
| -- All components have static initialization. Build positional aggregate |
| -- from the given expressions or defaults. |
| |
| Agg := Make_Aggregate (Sloc (T), New_List, New_List); |
| Set_Parent (Agg, Parent (T)); |
| |
| Comp := First_Component (T); |
| while Present (Comp) loop |
| Append |
| (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg)); |
| Next_Component (Comp); |
| end loop; |
| |
| Analyze_And_Resolve (Agg, T); |
| return Agg; |
| end Build_Equivalent_Record_Aggregate; |
| |
| ---------------------------- |
| -- Init_Proc_Level_Formal -- |
| ---------------------------- |
| |
| function Init_Proc_Level_Formal (Proc : Entity_Id) return Entity_Id is |
| Form : Entity_Id; |
| begin |
| -- Move through the formals of the initialization procedure Proc to find |
| -- the extra accessibility level parameter associated with the object |
| -- being initialized. |
| |
| Form := First_Formal (Proc); |
| while Present (Form) loop |
| if Chars (Form) = Name_uInit_Level then |
| return Form; |
| end if; |
| |
| Next_Formal (Form); |
| end loop; |
| |
| -- No formal was found, return Empty |
| |
| return Empty; |
| end Init_Proc_Level_Formal; |
| |
| ------------------------------- |
| -- Build_Initialization_Call -- |
| ------------------------------- |
| |
| -- References to a discriminant inside the record type declaration can |
| -- appear either in the subtype_indication to constrain a record or an |
| -- array, or as part of a larger expression given for the initial value |
| -- of a component. In both of these cases N appears in the record |
| -- initialization procedure and needs to be replaced by the formal |
| -- parameter of the initialization procedure which corresponds to that |
| -- discriminant. |
| |
| -- In the example below, references to discriminants D1 and D2 in proc_1 |
| -- are replaced by references to formals with the same name |
| -- (discriminals) |
| |
| -- A similar replacement is done for calls to any record initialization |
| -- procedure for any components that are themselves of a record type. |
| |
| -- type R (D1, D2 : Integer) is record |
| -- X : Integer := F * D1; |
| -- Y : Integer := F * D2; |
| -- end record; |
| |
| -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is |
| -- begin |
| -- Out_2.D1 := D1; |
| -- Out_2.D2 := D2; |
| -- Out_2.X := F * D1; |
| -- Out_2.Y := F * D2; |
| -- end; |
| |
| function Build_Initialization_Call |
| (Loc : Source_Ptr; |
| Id_Ref : Node_Id; |
| Typ : Entity_Id; |
| In_Init_Proc : Boolean := False; |
| Enclos_Type : Entity_Id := Empty; |
| Discr_Map : Elist_Id := New_Elmt_List; |
| With_Default_Init : Boolean := False; |
| Constructor_Ref : Node_Id := Empty; |
| Init_Control_Actual : Entity_Id := Empty) return List_Id |
| is |
| Res : constant List_Id := New_List; |
| |
| Full_Type : Entity_Id; |
| |
| procedure Check_Predicated_Discriminant |
| (Val : Node_Id; |
| Discr : Entity_Id); |
| -- Discriminants whose subtypes have predicates are checked in two |
| -- cases: |
| -- a) When an object is default-initialized and assertions are enabled |
| -- we check that the value of the discriminant obeys the predicate. |
| |
| -- b) In all cases, if the discriminant controls a variant and the |
| -- variant has no others_choice, Constraint_Error must be raised if |
| -- the predicate is violated, because there is no variant covered |
| -- by the illegal discriminant value. |
| |
| ----------------------------------- |
| -- Check_Predicated_Discriminant -- |
| ----------------------------------- |
| |
| procedure Check_Predicated_Discriminant |
| (Val : Node_Id; |
| Discr : Entity_Id) |
| is |
| Typ : constant Entity_Id := Etype (Discr); |
| |
| procedure Check_Missing_Others (V : Node_Id); |
| -- Check that a given variant and its nested variants have an others |
| -- choice, and generate a constraint error raise when it does not. |
| |
| -------------------------- |
| -- Check_Missing_Others -- |
| -------------------------- |
| |
| procedure Check_Missing_Others (V : Node_Id) is |
| Alt : Node_Id; |
| Choice : Node_Id; |
| Last_Var : Node_Id; |
| |
| begin |
| Last_Var := Last_Non_Pragma (Variants (V)); |
| Choice := First (Discrete_Choices (Last_Var)); |
| |
| -- An others_choice is added during expansion for gcc use, but |
| -- does not cover the illegality. |
| |
| if Entity (Name (V)) = Discr then |
| if Present (Choice) |
| and then (Nkind (Choice) /= N_Others_Choice |
| or else not Comes_From_Source (Choice)) |
| then |
| Check_Expression_Against_Static_Predicate (Val, Typ); |
| |
| if not Is_Static_Expression (Val) then |
| Prepend_To (Res, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_Op_Not (Loc, |
| Right_Opnd => Make_Predicate_Call (Typ, Val)), |
| Reason => CE_Invalid_Data)); |
| end if; |
| end if; |
| end if; |
| |
| -- Check whether some nested variant is ruled by the predicated |
| -- discriminant. |
| |
| Alt := First (Variants (V)); |
| while Present (Alt) loop |
| if Nkind (Alt) = N_Variant |
| and then Present (Variant_Part (Component_List (Alt))) |
| then |
| Check_Missing_Others |
| (Variant_Part (Component_List (Alt))); |
| end if; |
| |
| Next (Alt); |
| end loop; |
| end Check_Missing_Others; |
| |
| -- Local variables |
| |
| Def : Node_Id; |
| |
| -- Start of processing for Check_Predicated_Discriminant |
| |
| begin |
| if Ekind (Base_Type (Full_Type)) = E_Record_Type then |
| Def := Type_Definition (Parent (Base_Type (Full_Type))); |
| else |
| return; |
| end if; |
| |
| if Policy_In_Effect (Name_Assert) = Name_Check |
| and then not Predicates_Ignored (Etype (Discr)) |
| then |
| Prepend_To (Res, Make_Predicate_Check (Typ, Val)); |
| end if; |
| |
| -- If discriminant controls a variant, verify that predicate is |
| -- obeyed or else an Others_Choice is present. |
| |
| if Nkind (Def) = N_Record_Definition |
| and then Present (Variant_Part (Component_List (Def))) |
| and then Policy_In_Effect (Name_Assert) = Name_Ignore |
| then |
| Check_Missing_Others (Variant_Part (Component_List (Def))); |
| end if; |
| end Check_Predicated_Discriminant; |
| |
| -- Local variables |
| |
| Arg : Node_Id; |
| Args : List_Id; |
| Decls : List_Id; |
| Decl : Node_Id; |
| Discr : Entity_Id; |
| First_Arg : Node_Id; |
| Full_Init_Type : Entity_Id; |
| Init_Call : Node_Id; |
| Init_Type : Entity_Id; |
| Proc : Entity_Id; |
| |
| -- Start of processing for Build_Initialization_Call |
| |
| begin |
| pragma Assert (Constructor_Ref = Empty |
| or else Is_CPP_Constructor_Call (Constructor_Ref)); |
| |
| if No (Constructor_Ref) then |
| Proc := Base_Init_Proc (Typ); |
| else |
| Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref))); |
| end if; |
| |
| pragma Assert (Present (Proc)); |
| Init_Type := Etype (First_Formal (Proc)); |
| Full_Init_Type := Underlying_Type (Init_Type); |
| |
| -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars |
| -- is active (in which case we make the call anyway, since in the |
| -- actual compiled client it may be non null). |
| |
| if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then |
| return Empty_List; |
| |
| -- Nothing to do for an array of controlled components that have only |
| -- the inherited Initialize primitive. This is a useful optimization |
| -- for CodePeer. |
| |
| elsif Is_Trivial_Subprogram (Proc) |
| and then Is_Array_Type (Full_Init_Type) |
| then |
| return New_List (Make_Null_Statement (Loc)); |
| end if; |
| |
| -- Use the [underlying] full view when dealing with a private type. This |
| -- may require several steps depending on derivations. |
| |
| Full_Type := Typ; |
| loop |
| if Is_Private_Type (Full_Type) then |
| if Present (Full_View (Full_Type)) then |
| Full_Type := Full_View (Full_Type); |
| |
| elsif Present (Underlying_Full_View (Full_Type)) then |
| Full_Type := Underlying_Full_View (Full_Type); |
| |
| -- When a private type acts as a generic actual and lacks a full |
| -- view, use the base type. |
| |
| elsif Is_Generic_Actual_Type (Full_Type) then |
| Full_Type := Base_Type (Full_Type); |
| |
| elsif Ekind (Full_Type) = E_Private_Subtype |
| and then (not Has_Discriminants (Full_Type) |
| or else No (Discriminant_Constraint (Full_Type))) |
| then |
| Full_Type := Etype (Full_Type); |
| |
| -- The loop has recovered the [underlying] full view, stop the |
| -- traversal. |
| |
| else |
| exit; |
| end if; |
| |
| -- The type is not private, nothing to do |
| |
| else |
| exit; |
| end if; |
| end loop; |
| |
| -- If Typ is derived, the procedure is the initialization procedure for |
| -- the root type. Wrap the argument in an conversion to make it type |
| -- honest. Actually it isn't quite type honest, because there can be |
| -- conflicts of views in the private type case. That is why we set |
| -- Conversion_OK in the conversion node. |
| |
| if (Is_Record_Type (Typ) |
| or else Is_Array_Type (Typ) |
| or else Is_Private_Type (Typ)) |
| and then Init_Type /= Base_Type (Typ) |
| then |
| First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref); |
| Set_Etype (First_Arg, Init_Type); |
| |
| else |
| First_Arg := Id_Ref; |
| end if; |
| |
| Args := New_List (Convert_Concurrent (First_Arg, Typ)); |
| |
| -- In the tasks case, add _Master as the value of the _Master parameter |
| -- and _Chain as the value of the _Chain parameter. At the outer level, |
| -- these will be variables holding the corresponding values obtained |
| -- from GNARL. At inner levels, they will be the parameters passed down |
| -- through the outer routines. |
| |
| if Has_Task (Full_Type) then |
| if Restriction_Active (No_Task_Hierarchy) then |
| Append_To (Args, Make_Integer_Literal (Loc, Library_Task_Level)); |
| else |
| Append_To (Args, Make_Identifier (Loc, Name_uMaster)); |
| end if; |
| |
| -- Add _Chain (not done for sequential elaboration policy, see |
| -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). |
| |
| if Partition_Elaboration_Policy /= 'S' then |
| Append_To (Args, Make_Identifier (Loc, Name_uChain)); |
| end if; |
| |
| -- Ada 2005 (AI-287): In case of default initialized components |
| -- with tasks, we generate a null string actual parameter. |
| -- This is just a workaround that must be improved later??? |
| |
| if With_Default_Init then |
| Append_To (Args, |
| Make_String_Literal (Loc, |
| Strval => "")); |
| |
| else |
| Decls := |
| Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc); |
| Decl := Last (Decls); |
| |
| Append_To (Args, |
| New_Occurrence_Of (Defining_Identifier (Decl), Loc)); |
| Append_List (Decls, Res); |
| end if; |
| |
| else |
| Decls := No_List; |
| Decl := Empty; |
| end if; |
| |
| -- Handle the optionally generated formal *_skip_null_excluding_checks |
| |
| -- Look at the associated node for the object we are referencing and |
| -- verify that we are expanding a call to an Init_Proc for an internally |
| -- generated object declaration before passing True and skipping the |
| -- relevant checks. |
| |
| if Needs_Conditional_Null_Excluding_Check (Full_Init_Type) |
| and then Nkind (Id_Ref) in N_Has_Entity |
| and then (Comes_From_Source (Id_Ref) |
| or else (Present (Associated_Node (Id_Ref)) |
| and then Comes_From_Source |
| (Associated_Node (Id_Ref)))) |
| then |
| Append_To (Args, New_Occurrence_Of (Standard_True, Loc)); |
| end if; |
| |
| -- Add discriminant values if discriminants are present |
| |
| if Has_Discriminants (Full_Init_Type) then |
| Discr := First_Discriminant (Full_Init_Type); |
| while Present (Discr) loop |
| |
| -- If this is a discriminated concurrent type, the init_proc |
| -- for the corresponding record is being called. Use that type |
| -- directly to find the discriminant value, to handle properly |
| -- intervening renamed discriminants. |
| |
| declare |
| T : Entity_Id := Full_Type; |
| |
| begin |
| if Is_Protected_Type (T) then |
| T := Corresponding_Record_Type (T); |
| end if; |
| |
| Arg := |
| Get_Discriminant_Value ( |
| Discr, |
| T, |
| Discriminant_Constraint (Full_Type)); |
| end; |
| |
| -- If the target has access discriminants, and is constrained by |
| -- an access to the enclosing construct, i.e. a current instance, |
| -- replace the reference to the type by a reference to the object. |
| |
| if Nkind (Arg) = N_Attribute_Reference |
| and then Is_Access_Type (Etype (Arg)) |
| and then Is_Entity_Name (Prefix (Arg)) |
| and then Is_Type (Entity (Prefix (Arg))) |
| then |
| Arg := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Copy (Prefix (Id_Ref)), |
| Attribute_Name => Name_Unrestricted_Access); |
| |
| elsif In_Init_Proc then |
| |
| -- Replace any possible references to the discriminant in the |
| -- call to the record initialization procedure with references |
| -- to the appropriate formal parameter. |
| |
| if Nkind (Arg) = N_Identifier |
| and then Ekind (Entity (Arg)) = E_Discriminant |
| then |
| Arg := New_Occurrence_Of (Discriminal (Entity (Arg)), Loc); |
| |
| -- Otherwise make a copy of the default expression. Note that |
| -- we use the current Sloc for this, because we do not want the |
| -- call to appear to be at the declaration point. Within the |
| -- expression, replace discriminants with their discriminals. |
| |
| else |
| Arg := |
| New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc); |
| end if; |
| |
| else |
| if Is_Constrained (Full_Type) then |
| Arg := Duplicate_Subexpr_No_Checks (Arg); |
| else |
| -- The constraints come from the discriminant default exps, |
| -- they must be reevaluated, so we use New_Copy_Tree but we |
| -- ensure the proper Sloc (for any embedded calls). |
| -- In addition, if a predicate check is needed on the value |
| -- of the discriminant, insert it ahead of the call. |
| |
| Arg := New_Copy_Tree (Arg, New_Sloc => Loc); |
| end if; |
| |
| if Has_Predicates (Etype (Discr)) then |
| Check_Predicated_Discriminant (Arg, Discr); |
| end if; |
| end if; |
| |
| -- Ada 2005 (AI-287): In case of default initialized components, |
| -- if the component is constrained with a discriminant of the |
| -- enclosing type, we need to generate the corresponding selected |
| -- component node to access the discriminant value. In other cases |
| -- this is not required, either because we are inside the init |
| -- proc and we use the corresponding formal, or else because the |
| -- component is constrained by an expression. |
| |
| if With_Default_Init |
| and then Nkind (Id_Ref) = N_Selected_Component |
| and then Nkind (Arg) = N_Identifier |
| and then Ekind (Entity (Arg)) = E_Discriminant |
| then |
| Append_To (Args, |
| Make_Selected_Component (Loc, |
| Prefix => New_Copy_Tree (Prefix (Id_Ref)), |
| Selector_Name => Arg)); |
| else |
| Append_To (Args, Arg); |
| end if; |
| |
| Next_Discriminant (Discr); |
| end loop; |
| end if; |
| |
| -- If this is a call to initialize the parent component of a derived |
| -- tagged type, indicate that the tag should not be set in the parent. |
| -- This is done via the actual parameter value for the Init_Control |
| -- formal parameter, which is also used to deal with late initialization |
| -- requirements. |
| -- |
| -- We pass in Full_Init_Except_Tag unless the caller tells us to do |
| -- otherwise (by passing in a nonempty Init_Control_Actual parameter). |
| |
| 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 |
| declare |
| use Initialization_Control; |
| begin |
| Append_To (Args, |
| (if Present (Init_Control_Actual) |
| then Init_Control_Actual |
| else Make_Mode_Literal (Loc, Full_Init_Except_Tag))); |
| end; |
| elsif Present (Constructor_Ref) then |
| Append_List_To (Args, |
| New_Copy_List (Parameter_Associations (Constructor_Ref))); |
| end if; |
| |
| -- Pass the extra accessibility level parameter associated with the |
| -- level of the object being initialized when required. |
| |
| if Is_Entity_Name (Id_Ref) |
| and then Present (Init_Proc_Level_Formal (Proc)) |
| then |
| Append_To (Args, |
| Make_Parameter_Association (Loc, |
| Selector_Name => |
| Make_Identifier (Loc, Name_uInit_Level), |
| Explicit_Actual_Parameter => |
| Accessibility_Level (Id_Ref, Dynamic_Level))); |
| end if; |
| |
| Append_To (Res, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Proc, Loc), |
| Parameter_Associations => Args)); |
| |
| if Needs_Finalization (Typ) |
| and then Nkind (Id_Ref) = N_Selected_Component |
| then |
| if Chars (Selector_Name (Id_Ref)) /= Name_uParent then |
| Init_Call := |
| Make_Init_Call |
| (Obj_Ref => New_Copy_Tree (First_Arg), |
| Typ => Typ); |
| |
| -- Guard against a missing [Deep_]Initialize when the type was not |
| -- properly frozen. |
| |
| if Present (Init_Call) then |
| Append_To (Res, Init_Call); |
| end if; |
| end if; |
| end if; |
| |
| return Res; |
| |
| exception |
| when RE_Not_Available => |
| return Empty_List; |
| end Build_Initialization_Call; |
| |
| ---------------------------- |
| -- Build_Record_Init_Proc -- |
| ---------------------------- |
| |
| procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id) is |
| Decls : constant List_Id := New_List; |
| Discr_Map : constant Elist_Id := New_Elmt_List; |
| Loc : constant Source_Ptr := Sloc (Rec_Ent); |
| Counter : Nat := 0; |
| Proc_Id : Entity_Id; |
| Rec_Type : Entity_Id; |
| |
| Init_Control_Formal : Entity_Id := Empty; -- set in Build_Init_Statements |
| Has_Late_Init_Comp : Boolean := False; -- set in Build_Init_Statements |
| |
| function Build_Assignment |
| (Id : Entity_Id; |
| Default : Node_Id) return List_Id; |
| -- Build an assignment statement that assigns the default expression to |
| -- its corresponding record component if defined. The left-hand side of |
| -- the assignment is marked Assignment_OK so that initialization of |
| -- limited private records works correctly. This routine may also build |
| -- an adjustment call if the component is controlled. |
| |
| procedure Build_Discriminant_Assignments (Statement_List : List_Id); |
| -- If the record has discriminants, add assignment statements to |
| -- Statement_List to initialize the discriminant values from the |
| -- arguments of the initialization procedure. |
| |
| function Build_Init_Statements (Comp_List : Node_Id) return List_Id; |
| -- Build a list representing a sequence of statements which initialize |
| -- components of the given component list. This may involve building |
| -- case statements for the variant parts. Append any locally declared |
| -- objects on list Decls. |
| |
| function Build_Init_Call_Thru (Parameters : List_Id) return List_Id; |
| -- Given an untagged type-derivation that declares discriminants, e.g. |
| -- |
| -- type R (R1, R2 : Integer) is record ... end record; |
| -- type D (D1 : Integer) is new R (1, D1); |
| -- |
| -- we make the _init_proc of D be |
| -- |
| -- procedure _init_proc (X : D; D1 : Integer) is |
| -- begin |
| -- _init_proc (R (X), 1, D1); |
| -- end _init_proc; |
| -- |
| -- This function builds the call statement in this _init_proc. |
| |
| procedure Build_CPP_Init_Procedure; |
| -- Build the tree corresponding to the procedure specification and body |
| -- of the IC procedure that initializes the C++ part of the dispatch |
| -- table of an Ada tagged type that is a derivation of a CPP type. |
| -- Install it as the CPP_Init TSS. |
| |
| procedure Build_Init_Procedure; |
| -- Build the tree corresponding to the procedure specification and body |
| -- of the initialization procedure and install it as the _init TSS. |
| |
| procedure Build_Offset_To_Top_Functions; |
| -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec |
| -- and body of Offset_To_Top, a function used in conjuction with types |
| -- having secondary dispatch tables. |
| |
| procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id); |
| -- Add range checks to components of discriminated records. S is a |
| -- subtype indication of a record component. Check_List is a list |
| -- to which the check actions are appended. |
| |
| function Component_Needs_Simple_Initialization |
| (T : Entity_Id) return Boolean; |
| -- Determine if a component needs simple initialization, given its type |
| -- T. This routine is the same as Needs_Simple_Initialization except for |
| -- components of type Tag and Interface_Tag. These two access types do |
| -- not require initialization since they are explicitly initialized by |
| -- other means. |
| |
| function Parent_Subtype_Renaming_Discrims return Boolean; |
| -- Returns True for base types N that rename discriminants, else False |
| |
| function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean; |
| -- Determine whether a record initialization procedure needs to be |
| -- generated for the given record type. |
| |
| ---------------------- |
| -- Build_Assignment -- |
| ---------------------- |
| |
| function Build_Assignment |
| (Id : Entity_Id; |
| Default : Node_Id) return List_Id |
| is |
| Default_Loc : constant Source_Ptr := Sloc (Default); |
| Typ : constant Entity_Id := Underlying_Type (Etype (Id)); |
| |
| Adj_Call : Node_Id; |
| Exp : Node_Id := Default; |
| Kind : Node_Kind := Nkind (Default); |
| Lhs : Node_Id; |
| Res : List_Id; |
| |
| begin |
| Lhs := |
| Make_Selected_Component (Default_Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => New_Occurrence_Of (Id, Default_Loc)); |
| Set_Assignment_OK (Lhs); |
| |
| -- Take a copy of Exp to ensure that later copies of this component |
| -- declaration in derived types see the original tree, not a node |
| -- rewritten during expansion of the init_proc. If the copy contains |
| -- itypes, the scope of the new itypes is the init_proc being built. |
| |
| declare |
| Map : Elist_Id := No_Elist; |
| begin |
| if Has_Late_Init_Comp then |
| -- Map the type to the _Init parameter in order to |
| -- handle "current instance" references. |
| |
| Map := New_Elmt_List |
| (Elmt1 => Rec_Type, |
| Elmt2 => Defining_Identifier (First |
| (Parameter_Specifications |
| (Parent (Proc_Id))))); |
| |
| -- If the type has an incomplete view, a current instance |
| -- may have an incomplete type. In that case, it must also be |
| -- replaced by the formal of the Init_Proc. |
| |
| if Nkind (Parent (Rec_Type)) = N_Full_Type_Declaration |
| and then Present (Incomplete_View (Parent (Rec_Type))) |
| then |
| Append_Elmt ( |
| N => Incomplete_View (Parent (Rec_Type)), |
| To => Map); |
| Append_Elmt ( |
| N => Defining_Identifier |
| (First |
| (Parameter_Specifications |
| (Parent (Proc_Id)))), |
| To => Map); |
| end if; |
| end if; |
| |
| Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id, Map => Map); |
| end; |
| |
| Res := New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => Lhs, |
| Expression => Exp)); |
| |
| Set_No_Ctrl_Actions (First (Res)); |
| |
| -- Adjust the tag if tagged (because of possible view conversions). |
| -- Suppress the tag adjustment when not Tagged_Type_Expansion because |
| -- tags are represented implicitly in objects, and when the record is |
| -- initialized with a raise expression. |
| |
| if Is_Tagged_Type (Typ) |
| and then Tagged_Type_Expansion |
| and then Nkind (Exp) /= N_Raise_Expression |
| and then (Nkind (Exp) /= N_Qualified_Expression |
| or else Nkind (Expression (Exp)) /= N_Raise_Expression) |
| then |
| Append_To (Res, |
| Make_Assignment_Statement (Default_Loc, |
| Name => |
| Make_Selected_Component (Default_Loc, |
| Prefix => |
| New_Copy_Tree (Lhs, New_Scope => Proc_Id), |
| Selector_Name => |
| New_Occurrence_Of |
| (First_Tag_Component (Typ), Default_Loc)), |
| |
| Expression => |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Occurrence_Of |
| (Node (First_Elmt (Access_Disp_Table (Underlying_Type |
| (Typ)))), |
| Default_Loc)))); |
| end if; |
| |
| -- Adjust the component if controlled except if it is an aggregate |
| -- that will be expanded inline. |
| |
| if Kind = N_Qualified_Expression then |
| Kind := Nkind (Expression (Default)); |
| end if; |
| |
| if Needs_Finalization (Typ) |
| and then Kind not in N_Aggregate | N_Extension_Aggregate |
| and then not Is_Build_In_Place_Function_Call (Exp) |
| then |
| Adj_Call := |
| Make_Adjust_Call |
| (Obj_Ref => New_Copy_Tree (Lhs), |
| Typ => Etype (Id)); |
| |
| -- Guard against a missing [Deep_]Adjust when the component type |
| -- was not properly frozen. |
| |
| if Present (Adj_Call) then |
| Append_To (Res, Adj_Call); |
| end if; |
| end if; |
| |
| -- If a component type has a predicate, add check to the component |
| -- assignment. Discriminants are handled at the point of the call, |
| -- which provides for a better error message. |
| |
| if Comes_From_Source (Exp) |
| and then Predicate_Enabled (Typ) |
| then |
| Append (Make_Predicate_Check (Typ, Exp), Res); |
| end if; |
| |
| return Res; |
| |
| exception |
| when RE_Not_Available => |
| return Empty_List; |
| end Build_Assignment; |
| |
| ------------------------------------ |
| -- Build_Discriminant_Assignments -- |
| ------------------------------------ |
| |
| procedure Build_Discriminant_Assignments (Statement_List : List_Id) is |
| Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type); |
| D : Entity_Id; |
| D_Loc : Source_Ptr; |
| |
| begin |
| if Has_Discriminants (Rec_Type) |
| and then not Is_Unchecked_Union (Rec_Type) |
| then |
| D := First_Discriminant (Rec_Type); |
| while Present (D) loop |
| |
| -- Don't generate the assignment for discriminants in derived |
| -- tagged types if the discriminant is a renaming of some |
| -- ancestor discriminant. This initialization will be done |
| -- when initializing the _parent field of the derived record. |
| |
| if Is_Tagged |
| and then Present (Corresponding_Discriminant (D)) |
| then |
| null; |
| |
| else |
| D_Loc := Sloc (D); |
| Append_List_To (Statement_List, |
| Build_Assignment (D, |
| New_Occurrence_Of (Discriminal (D), D_Loc))); |
| end if; |
| |
| Next_Discriminant (D); |
| end loop; |
| end if; |
| end Build_Discriminant_Assignments; |
| |
| -------------------------- |
| -- Build_Init_Call_Thru -- |
| -------------------------- |
| |
| function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is |
| Parent_Proc : constant Entity_Id := |
| Base_Init_Proc (Etype (Rec_Type)); |
| |
| Parent_Type : constant Entity_Id := |
| Etype (First_Formal (Parent_Proc)); |
| |
| Uparent_Type : constant Entity_Id := |
| Underlying_Type (Parent_Type); |
| |
| First_Discr_Param : Node_Id; |
| |
| Arg : Node_Id; |
| Args : List_Id; |
| First_Arg : Node_Id; |
| Parent_Discr : Entity_Id; |
| Res : List_Id; |
| |
| begin |
| -- First argument (_Init) is the object to be initialized. |
| -- ??? not sure where to get a reasonable Loc for First_Arg |
| |
| First_Arg := |
| OK_Convert_To (Parent_Type, |
| New_Occurrence_Of |
| (Defining_Identifier (First (Parameters)), Loc)); |
| |
| Set_Etype (First_Arg, Parent_Type); |
| |
| Args := New_List (Convert_Concurrent (First_Arg, Rec_Type)); |
| |
| -- In the tasks case, |
| -- add _Master as the value of the _Master parameter |
| -- add _Chain as the value of the _Chain parameter. |
| -- add _Task_Name as the value of the _Task_Name parameter. |
| -- At the outer level, these will be variables holding the |
| -- corresponding values obtained from GNARL or the expander. |
| -- |
| -- At inner levels, they will be the parameters passed down through |
| -- the outer routines. |
| |
| First_Discr_Param := Next (First (Parameters)); |
| |
| if Has_Task (Rec_Type) then |
| if Restriction_Active (No_Task_Hierarchy) then |
| Append_To |
| (Args, Make_Integer_Literal (Loc, Library_Task_Level)); |
| else |
| Append_To (Args, Make_Identifier (Loc, Name_uMaster)); |
| end if; |
| |
| -- Add _Chain (not done for sequential elaboration policy, see |
| -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). |
| |
| if Partition_Elaboration_Policy /= 'S' then |
| Append_To (Args, Make_Identifier (Loc, Name_uChain)); |
| end if; |
| |
| Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); |
| First_Discr_Param := Next (Next (Next (First_Discr_Param))); |
| end if; |
| |
| -- Append discriminant values |
| |
| if Has_Discriminants (Uparent_Type) then |
| pragma Assert (not Is_Tagged_Type (Uparent_Type)); |
| |
| Parent_Discr := First_Discriminant (Uparent_Type); |
| while Present (Parent_Discr) loop |
| |
| -- Get the initial value for this discriminant |
| -- ??? needs to be cleaned up to use parent_Discr_Constr |
| -- directly. |
| |
| declare |
| Discr : Entity_Id := |
| First_Stored_Discriminant (Uparent_Type); |
| |
| Discr_Value : Elmt_Id := |
| First_Elmt (Stored_Constraint (Rec_Type)); |
| |
| begin |
| while Original_Record_Component (Parent_Discr) /= Discr loop |
| Next_Stored_Discriminant (Discr); |
| Next_Elmt (Discr_Value); |
| end loop; |
| |
| Arg := Node (Discr_Value); |
| end; |
| |
| -- Append it to the list |
| |
| if Nkind (Arg) = N_Identifier |
| and then Ekind (Entity (Arg)) = E_Discriminant |
| then |
| Append_To (Args, |
| New_Occurrence_Of (Discriminal (Entity (Arg)), Loc)); |
| |
| -- Case of access discriminants. We replace the reference |
| -- to the type by a reference to the actual object. |
| |
| -- Is above comment right??? Use of New_Copy below seems mighty |
| -- suspicious ??? |
| |
| else |
| Append_To (Args, New_Copy (Arg)); |
| end if; |
| |
| Next_Discriminant (Parent_Discr); |
| end loop; |
| end if; |
| |
| Res := |
| New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (Parent_Proc, Loc), |
| Parameter_Associations => Args)); |
| |
| return Res; |
| end Build_Init_Call_Thru; |
| |
| ----------------------------------- |
| -- Build_Offset_To_Top_Functions -- |
| ----------------------------------- |
| |
| procedure Build_Offset_To_Top_Functions is |
| |
| procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id); |
| -- Generate: |
| -- function Fxx (O : Address) return Storage_Offset is |
| -- type Acc is access all <Typ>; |
| -- begin |
| -- return Acc!(O).Iface_Comp'Position; |
| -- end Fxx; |
| |
| ---------------------------------- |
| -- Build_Offset_To_Top_Function -- |
| ---------------------------------- |
| |
| procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is |
| Body_Node : Node_Id; |
| Func_Id : Entity_Id; |
| Spec_Node : Node_Id; |
| Acc_Type : Entity_Id; |
| |
| begin |
| Func_Id := Make_Temporary (Loc, 'F'); |
| Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id); |
| |
| -- Generate |
| -- function Fxx (O : in Rec_Typ) return Storage_Offset; |
| |
| Spec_Node := New_Node (N_Function_Specification, Loc); |
| Set_Defining_Unit_Name (Spec_Node, Func_Id); |
| Set_Parameter_Specifications (Spec_Node, New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uO), |
| In_Present => True, |
| Parameter_Type => |
| New_Occurrence_Of (RTE (RE_Address), Loc)))); |
| Set_Result_Definition (Spec_Node, |
| New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); |
| |
| -- Generate |
| -- function Fxx (O : in Rec_Typ) return Storage_Offset is |
| -- begin |
| -- return -O.Iface_Comp'Position; |
| -- end Fxx; |
| |
| Body_Node := New_Node (N_Subprogram_Body, Loc); |
| Set_Specification (Body_Node, Spec_Node); |
| |
| Acc_Type := Make_Temporary (Loc, 'T'); |
| Set_Declarations (Body_Node, New_List ( |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => Acc_Type, |
| Type_Definition => |
| Make_Access_To_Object_Definition (Loc, |
| All_Present => True, |
| Null_Exclusion_Present => False, |
| Constant_Present => False, |
| Subtype_Indication => |
| New_Occurrence_Of (Rec_Type, Loc))))); |
| |
| Set_Handled_Statement_Sequence (Body_Node, |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Op_Minus (Loc, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To (Acc_Type, |
| Make_Identifier (Loc, Name_uO))), |
| Selector_Name => |
| New_Occurrence_Of (Iface_Comp, Loc)), |
| Attribute_Name => Name_Position)))))); |
| |
| Mutate_Ekind (Func_Id, E_Function); |
| Set_Mechanism (Func_Id, Default_Mechanism); |
| Set_Is_Internal (Func_Id, True); |
| |
| if not Debug_Generated_Code then |
| Set_Debug_Info_Off (Func_Id); |
| end if; |
| |
| Analyze (Body_Node); |
| |
| Append_Freeze_Action (Rec_Type, Body_Node); |
| end Build_Offset_To_Top_Function; |
| |
| -- Local variables |
| |
| Iface_Comp : Node_Id; |
| Iface_Comp_Elmt : Elmt_Id; |
| Ifaces_Comp_List : Elist_Id; |
| |
| -- Start of processing for Build_Offset_To_Top_Functions |
| |
| begin |
| -- Offset_To_Top_Functions are built only for derivations of types |
| -- with discriminants that cover interface types. |
| -- Nothing is needed either in case of virtual targets, since |
| -- interfaces are handled directly by the target. |
| |
| if not Is_Tagged_Type (Rec_Type) |
| or else Etype (Rec_Type) = Rec_Type |
| or else not Has_Discriminants (Etype (Rec_Type)) |
| or else not Tagged_Type_Expansion |
| then |
| return; |
| end if; |
| |
| Collect_Interface_Components (Rec_Type, Ifaces_Comp_List); |
| |
| -- For each interface type with secondary dispatch table we generate |
| -- the Offset_To_Top_Functions (required to displace the pointer in |
| -- interface conversions) |
| |
| Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); |
| while Present (Iface_Comp_Elmt) loop |
| Iface_Comp := Node (Iface_Comp_Elmt); |
| pragma Assert (Is_Interface (Related_Type (Iface_Comp))); |
| |
| -- If the interface is a parent of Rec_Type it shares the primary |
| -- dispatch table and hence there is no need to build the function |
| |
| if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type, |
| Use_Full_View => True) |
| then |
| Build_Offset_To_Top_Function (Iface_Comp); |
| end if; |
| |
| Next_Elmt (Iface_Comp_Elmt); |
| end loop; |
| end Build_Offset_To_Top_Functions; |
| |
| ------------------------------ |
| -- Build_CPP_Init_Procedure -- |
| ------------------------------ |
| |
| procedure Build_CPP_Init_Procedure is |
| Body_Node : Node_Id; |
| Body_Stmts : List_Id; |
| Flag_Id : Entity_Id; |
| Handled_Stmt_Node : Node_Id; |
| Init_Tags_List : List_Id; |
| Proc_Id : Entity_Id; |
| Proc_Spec_Node : Node_Id; |
| |
| begin |
| -- Check cases requiring no IC routine |
| |
| if not Is_CPP_Class (Root_Type (Rec_Type)) |
| or else Is_CPP_Class (Rec_Type) |
| or else CPP_Num_Prims (Rec_Type) = 0 |
| or else not Tagged_Type_Expansion |
| or else No_Run_Time_Mode |
| then |
| return; |
| end if; |
| |
| -- Generate: |
| |
| -- Flag : Boolean := False; |
| -- |
| -- procedure Typ_IC is |
| -- begin |
| -- if not Flag then |
| -- Copy C++ dispatch table slots from parent |
| -- Update C++ slots of overridden primitives |
| -- end if; |
| -- end; |
| |
| Flag_Id := Make_Temporary (Loc, 'F'); |
| |
| Append_Freeze_Action (Rec_Type, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Flag_Id, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Boolean, Loc), |
| Expression => |
| New_Occurrence_Of (Standard_True, Loc))); |
| |
| Body_Stmts := New_List; |
| Body_Node := New_Node (N_Subprogram_Body, Loc); |
| |
| Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); |
| |
| Proc_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc)); |
| |
| Mutate_Ekind (Proc_Id, E_Procedure); |
| Set_Is_Internal (Proc_Id); |
| |
| Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); |
| |
| Set_Parameter_Specifications (Proc_Spec_Node, New_List); |
| Set_Specification (Body_Node, Proc_Spec_Node); |
| Set_Declarations (Body_Node, New_List); |
| |
| Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type); |
| |
| Append_To (Init_Tags_List, |
| Make_Assignment_Statement (Loc, |
| Name => |
| New_Occurrence_Of (Flag_Id, Loc), |
| Expression => |
| New_Occurrence_Of (Standard_False, Loc))); |
| |
| Append_To (Body_Stmts, |
| Make_If_Statement (Loc, |
| Condition => New_Occurrence_Of (Flag_Id, Loc), |
| Then_Statements => Init_Tags_List)); |
| |
| Handled_Stmt_Node := |
| New_Node (N_Handled_Sequence_Of_Statements, Loc); |
| Set_Statements (Handled_Stmt_Node, Body_Stmts); |
| Set_Exception_Handlers (Handled_Stmt_Node, No_List); |
| Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); |
| |
| if not Debug_Generated_Code then |
| Set_Debug_Info_Off (Proc_Id); |
| end if; |
| |
| -- Associate CPP_Init_Proc with type |
| |
| Set_Init_Proc (Rec_Type, Proc_Id); |
| end Build_CPP_Init_Procedure; |
| |
| -------------------------- |
| -- Build_Init_Procedure -- |
| -------------------------- |
| |
| procedure Build_Init_Procedure is |
| Body_Stmts : List_Id; |
| Body_Node : Node_Id; |
| Handled_Stmt_Node : Node_Id; |
| Init_Tags_List : List_Id; |
| Parameters : List_Id; |
| Proc_Spec_Node : Node_Id; |
| Record_Extension_Node : Node_Id; |
| |
| use Initialization_Control; |
| begin |
| Body_Stmts := New_List; |
| Body_Node := New_Node (N_Subprogram_Body, Loc); |
| Mutate_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, Proc_Id); |
| Append_List_To (Parameters, |
| Build_Discriminant_Formals (Rec_Type, True)); |
| |
| -- For tagged types, we add a parameter to indicate what |
| -- portion of the object's initialization is to be performed. |
| -- This is used for two purposes: |
| -- 1) When a type extension's initialization procedure calls |
| -- the initialization procedure of the parent type, we do |
| -- not want the parent to initialize the Tag component; |
| -- it has been set already. |
| -- 2) If an ancestor type has at least one component that requires |
| -- late initialization, then we need to be able to initialize |
| -- those components separately after initializing any other |
| -- components. |
| |
| if Is_Tagged_Type (Rec_Type) then |
| Init_Control_Formal := Make_Temporary (Loc, 'P'); |
| |
| Append_To (Parameters, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Init_Control_Formal, |
| Parameter_Type => |
| New_Occurrence_Of (Standard_Natural, Loc), |
| Expression => Make_Mode_Literal (Loc, Full_Init))); |
| end if; |
| |
| -- Create an extra accessibility parameter to capture the level of |
| -- the object being initialized when its type is a limited record. |
| |
| if Is_Limited_Record (Rec_Type) then |
| Append_To (Parameters, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier |
| (Loc, Name_uInit_Level), |
| Parameter_Type => |
| New_Occurrence_Of (Standard_Natural, Loc), |
| Expression => |
| Make_Integer_Literal |
| (Loc, Scope_Depth (Standard_Standard)))); |
| end if; |
| |
| Set_Parameter_Specifications (Proc_Spec_Node, Parameters); |
| Set_Specification (Body_Node, Proc_Spec_Node); |
| Set_Declarations (Body_Node, Decls); |
| |
| -- N is a Derived_Type_Definition that renames the parameters of the |
| -- ancestor type. We initialize it by expanding our discriminants and |
| -- call the ancestor _init_proc with a type-converted object. |
| |
| if Parent_Subtype_Renaming_Discrims then |
| Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters)); |
| |
| elsif Nkind (Type_Definition (N)) = N_Record_Definition then |
| Build_Discriminant_Assignments (Body_Stmts); |
| |
| if not Null_Present (Type_Definition (N)) then |
| Append_List_To (Body_Stmts, |
| Build_Init_Statements (Component_List (Type_Definition (N)))); |
| end if; |
| |
| -- N is a Derived_Type_Definition with a possible non-empty |
| -- extension. The initialization of a type extension consists in the |
| -- initialization of the components in the extension. |
| |
| else |
| Build_Discriminant_Assignments (Body_Stmts); |
| |
| Record_Extension_Node := |
| Record_Extension_Part (Type_Definition (N)); |
| |
| if not Null_Present (Record_Extension_Node) then |
| declare |
| Stmts : constant List_Id := |
| Build_Init_Statements ( |
| Component_List (Record_Extension_Node)); |
| |
| begin |
| -- The parent field must be initialized first because the |
| -- offset of the new discriminants may depend on it. This is |
| -- not needed if the parent is an interface type because in |
| -- such case the initialization of the _parent field was not |
| -- generated. |
| |
| if not Is_Interface (Etype (Rec_Ent)) then |
| declare |
| Parent_IP : constant Name_Id := |
| Make_Init_Proc_Name (Etype (Rec_Ent)); |
| Stmt : Node_Id := First (Stmts); |
| IP_Call : Node_Id := Empty; |
| begin |
| -- Look for a call to the parent IP associated with |
| -- the record extension. |
| -- The call will be inside not one but two |
| -- if-statements (with the same condition). Testing |
| -- the same Early_Init condition twice might seem |
| -- redundant. However, as soon as we exit this loop, |
| -- we are going to hoist the inner if-statement out |
| -- of the outer one; the "redundant" test was built |
| -- in anticipation of this hoisting. |
| |
| while Present (Stmt) loop |
| if Nkind (Stmt) = N_If_Statement then |
| declare |
| Then_Stmt1 : Node_Id := |
| First (Then_Statements (Stmt)); |
| Then_Stmt2 : Node_Id; |
| begin |
| while Present (Then_Stmt1) loop |
| if Nkind (Then_Stmt1) = N_If_Statement then |
| Then_Stmt2 := |
| First (Then_Statements (Then_Stmt1)); |
| |
| if Nkind (Then_Stmt2) = |
| N_Procedure_Call_Statement |
| and then Chars (Name (Then_Stmt2)) = |
| Parent_IP |
| then |
| -- IP_Call is a call wrapped in an |
| -- if statement. |
| IP_Call := Then_Stmt1; |
| exit; |
| end if; |
| end if; |
| Next (Then_Stmt1); |
| end loop; |
| end; |
| end if; |
| |
| Next (Stmt); |
| end loop; |
| |
| -- If found then move it to the beginning of the |
| -- statements of this IP routine |
| |
| if Present (IP_Call) then |
| Remove (IP_Call); |
| Prepend_List_To (Body_Stmts, New_List (IP_Call)); |
| end if; |
| end; |
| end if; |
| |
| Append_List_To (Body_Stmts, Stmts); |
| end; |
| end if; |
| end if; |
| |
| -- Add here the assignment to instantiate the Tag |
| |
| -- The assignment corresponds to the code: |
| |
| -- _Init._Tag := Typ'Tag; |
| |
| -- Suppress the tag assignment when not Tagged_Type_Expansion because |
| -- tags are represented implicitly in objects. It is also suppressed |
| -- in case of CPP_Class types because in this case the tag is |
| -- initialized in the C++ side. |
| |
| if Is_Tagged_Type (Rec_Type) |
| and then Tagged_Type_Expansion |
| and then not No_Run_Time_Mode |
| then |
| -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of |
| -- the actual object and invoke the IP of the parent (in this |
| -- order). The tag must be initialized before the call to the IP |
| -- of the parent and the assignments to other components because |
| -- the initial value of the components may depend on the tag (eg. |
| -- through a dispatching operation on an access to the current |
| -- type). The tag assignment is not done when initializing the |
| -- parent component of a type extension, because in that case the |
| -- tag is set in the extension. |
| |
| if not Is_CPP_Class (Root_Type (Rec_Type)) then |
| |
| -- Initialize the primary tag component |
| |
| Init_Tags_List := New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => |
| New_Occurrence_Of |
| (First_Tag_Component (Rec_Type), Loc)), |
| Expression => |
| New_Occurrence_Of |
| (Node |
| (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); |
| |
| -- Ada 2005 (AI-251): Initialize the secondary tags components |
| -- located at fixed positions (tags whose position depends on |
| -- variable size components are initialized later ---see below) |
| |
| if Ada_Version >= Ada_2005 |
| and then not Is_Interface (Rec_Type) |
| and then Has_Interfaces (Rec_Type) |
| then |
| declare |
| Elab_Sec_DT_Stmts_List : constant List_Id := New_List; |
| Elab_List : List_Id := New_List; |
| |
| begin |
| Init_Secondary_Tags |
| (Typ => Rec_Type, |
| Target => Make_Identifier (Loc, Name_uInit), |
| Init_Tags_List => Init_Tags_List, |
| Stmts_List => Elab_Sec_DT_Stmts_List, |
| Fixed_Comps => True, |
| Variable_Comps => False); |
| |
| Elab_List := New_List ( |
| Make_If_Statement (Loc, |
| Condition => |
| Tag_Init_Condition (Loc, Init_Control_Formal), |
| Then_Statements => Init_Tags_List)); |
| |
| if Elab_Flag_Needed (Rec_Type) then |
| Append_To (Elab_Sec_DT_Stmts_List, |
| Make_Assignment_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (Access_Disp_Table_Elab_Flag (Rec_Type), |
| Loc), |
| Expression => |
| New_Occurrence_Of (Standard_False, Loc))); |
| |
| Append_To (Elab_List, |
| Make_If_Statement (Loc, |
| Condition => |
| New_Occurrence_Of |
| (Access_Disp_Table_Elab_Flag (Rec_Type), Loc), |
| Then_Statements => Elab_Sec_DT_Stmts_List)); |
| end if; |
| |
| Prepend_List_To (Body_Stmts, Elab_List); |
| end; |
| else |
| Prepend_To (Body_Stmts, |
| Make_If_Statement (Loc, |
| Condition => |
| Tag_Init_Condition (Loc, Init_Control_Formal), |
| Then_Statements => Init_Tags_List)); |
| end if; |
| |
| -- Case 2: CPP type. The imported C++ constructor takes care of |
| -- tags initialization. No action needed here because the IP |
| -- is built by Set_CPP_Constructors; in this case the IP is a |
| -- wrapper that invokes the C++ constructor and copies the C++ |
| -- tags locally. Done to inherit the C++ slots in Ada derivations |
| -- (see case 3). |
| |
| elsif Is_CPP_Class (Rec_Type) then |
| pragma Assert (False); |
| null; |
| |
| -- Case 3: Combined hierarchy containing C++ types and Ada tagged |
| -- type derivations. Derivations of imported C++ classes add a |
| -- complication, because we cannot inhibit tag setting in the |
| -- constructor for the parent. Hence we initialize the tag after |
| -- the call to the parent IP (that is, in reverse order compared |
| -- with pure Ada hierarchies ---see comment on case 1). |
| |
| else |
| -- Initialize the primary tag |
| |
| Init_Tags_List := New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => |
| New_Occurrence_Of |
| (First_Tag_Component (Rec_Type), Loc)), |
| Expression => |
| New_Occurrence_Of |
| (Node |
| (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); |
| |
| -- Ada 2005 (AI-251): Initialize the secondary tags components |
| -- located at fixed positions (tags whose position depends on |
| -- variable size components are initialized later ---see below) |
| |
| if Ada_Version >= Ada_2005 |
| and then not Is_Interface (Rec_Type) |
| and then Has_Interfaces (Rec_Type) |
| then |
| Init_Secondary_Tags |
| (Typ => Rec_Type, |
| Target => Make_Identifier (Loc, Name_uInit), |
| Init_Tags_List => Init_Tags_List, |
| Stmts_List => Init_Tags_List, |
| Fixed_Comps => True, |
| Variable_Comps => False); |
| end if; |
| |
| -- Initialize the tag component after invocation of parent IP. |
| |
| -- Generate: |
| -- parent_IP(_init.parent); // Invokes the C++ constructor |
| -- [ typIC; ] // Inherit C++ slots from parent |
| -- init_tags |
| |
| declare |
| Ins_Nod : Node_Id; |
| |
| begin |
| -- Search for the call to the IP of the parent. We assume |
| -- that the first init_proc call is for the parent. |
| -- It is wrapped in an "if Early_Init_Condition" |
| -- if-statement. |
| |
| Ins_Nod := First (Body_Stmts); |
| while Present (Next (Ins_Nod)) |
| and then |
| (Nkind (Ins_Nod) /= N_If_Statement |
| or else (Nkind (First (Then_Statements (Ins_Nod))) |
| /= N_Procedure_Call_Statement) |
| or else not Is_Init_Proc |
| (Name (First (Then_Statements |
| (Ins_Nod))))) |
| loop |
| Next (Ins_Nod); |
| end loop; |
| |
| -- The IC routine copies the inherited slots of the C+ part |
| -- of the dispatch table from the parent and updates the |
| -- overridden C++ slots. |
| |
| if CPP_Num_Prims (Rec_Type) > 0 then |
| declare |
| Init_DT : Entity_Id; |
| New_Nod : Node_Id; |
| |
| begin |
| Init_DT := CPP_Init_Proc (Rec_Type); |
| pragma Assert (Present (Init_DT)); |
| |
| New_Nod := |
| Make_Procedure_Call_Statement (Loc, |
| New_Occurrence_Of (Init_DT, Loc)); |
| Insert_After (Ins_Nod, New_Nod); |
| |
| -- Update location of init tag statements |
| |
| Ins_Nod := New_Nod; |
| end; |
| end if; |
| |
| Insert_List_After (Ins_Nod, Init_Tags_List); |
| end; |
| end if; |
| |
| -- Ada 2005 (AI-251): Initialize the secondary tag components |
| -- located at variable positions. We delay the generation of this |
| -- code until here because the value of the attribute 'Position |
| -- applied to variable size components of the parent type that |
| -- depend on discriminants is only safely read at runtime after |
| -- the parent components have been initialized. |
| |
| if Ada_Version >= Ada_2005 |
| and then not Is_Interface (Rec_Type) |
| and then Has_Interfaces (Rec_Type) |
| and then Has_Discriminants (Etype (Rec_Type)) |
| and then Is_Variable_Size_Record (Etype (Rec_Type)) |
| then |
| Init_Tags_List := New_List; |
| |
| Init_Secondary_Tags |
| (Typ => Rec_Type, |
| Target => Make_Identifier (Loc, Name_uInit), |
| Init_Tags_List => Init_Tags_List, |
| Stmts_List => Init_Tags_List, |
| Fixed_Comps => False, |
| Variable_Comps => True); |
| |
| Append_List_To (Body_Stmts, Init_Tags_List); |
| end if; |
| end if; |
| |
| Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc); |
| Set_Statements (Handled_Stmt_Node, Body_Stmts); |
| |
| -- Generate: |
| -- Deep_Finalize (_init, C1, ..., CN); |
| -- raise; |
| |
| if Counter > 0 |
| and then Needs_Finalization (Rec_Type) |
| and then not Is_Abstract_Type (Rec_Type) |
| and then not Restriction_Active (No_Exception_Propagation) |
| then |
| declare |
| DF_Call : Node_Id; |
| DF_Id : Entity_Id; |
| |
| begin |
| -- Create a local version of Deep_Finalize which has indication |
| -- of partial initialization state. |
| |
| DF_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Name_uFinalizer)); |
| |
| Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id)); |
| |
| DF_Call := |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (DF_Id, Loc), |
| Parameter_Associations => New_List ( |
| Make_Identifier (Loc, Name_uInit), |
| New_Occurrence_Of (Standard_False, Loc))); |
| |
| -- Do not emit warnings related to the elaboration order when a |
| -- controlled object is declared before the body of Finalize is |
| -- seen. |
| |
| if Legacy_Elaboration_Checks then |
| Set_No_Elaboration_Check (DF_Call); |
| end if; |
| |
| Set_Exception_Handlers (Handled_Stmt_Node, New_List ( |
| Make_Exception_Handler (Loc, |
| Exception_Choices => New_List ( |
| Make_Others_Choice (Loc)), |
| Statements => New_List ( |
| DF_Call, |
| Make_Raise_Statement (Loc))))); |
| end; |
| else |
| Set_Exception_Handlers (Handled_Stmt_Node, No_List); |
| end if; |
| |
| Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); |
| |
| if not Debug_Generated_Code then |
| Set_Debug_Info_Off (Proc_Id); |
| end if; |
| |
| -- Associate Init_Proc with type, and determine if the procedure |
| -- is null (happens because of the Initialize_Scalars pragma case, |
| -- where we have to generate a null procedure in case it is called |
| -- by a client with Initialize_Scalars set). Such procedures have |
| -- to be generated, but do not have to be called, so we mark them |
| -- as null to suppress the call. Kill also warnings for the _Init |
| -- out parameter, which is left entirely uninitialized. |
| |
| Set_Init_Proc (Rec_Type, Proc_Id); |
| |
| if Is_Null_Statement_List (Body_Stmts) then |
| Set_Is_Null_Init_Proc (Proc_Id); |
| Set_Warnings_Off (Defining_Identifier (First (Parameters))); |
| end if; |
| end Build_Init_Procedure; |
| |
| --------------------------- |
| -- Build_Init_Statements -- |
| --------------------------- |
| |
| function Build_Init_Statements (Comp_List : Node_Id) return List_Id is |
| Checks : constant List_Id := New_List; |
| Actions : List_Id := No_List; |
| Counter_Id : Entity_Id := Empty; |
| Comp_Loc : Source_Ptr; |
| Decl : Node_Id; |
| Id : Entity_Id; |
| Parent_Stmts : List_Id; |
| Parent_Id : Entity_Id := Empty; |
| Stmts, Late_Stmts : List_Id := Empty_List; |
| Typ : Entity_Id; |
| |
| procedure Increment_Counter |
| (Loc : Source_Ptr; Late : Boolean := False); |
| -- Generate an "increment by one" statement for the current counter |
| -- and append it to the appropriate statement list. |
| |
| procedure Make_Counter (Loc : Source_Ptr); |
| -- Create a new counter for the current component list. The routine |
| -- creates a new defining Id, adds an object declaration and sets |
| -- the Id generator for the next variant. |
| |
| ----------------------- |
| -- Increment_Counter -- |
| ----------------------- |
| |
| procedure Increment_Counter |
| (Loc : Source_Ptr; Late : Boolean := False) is |
| begin |
| -- Generate: |
| -- Counter := Counter + 1; |
| |
| Append_To ((if Late then Late_Stmts else Stmts), |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Counter_Id, Loc), |
| Expression => |
| Make_Op_Add (Loc, |
| Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), |
| Right_Opnd => Make_Integer_Literal (Loc, 1)))); |
| end Increment_Counter; |
| |
| ------------------ |
| -- Make_Counter -- |
| ------------------ |
| |
| procedure Make_Counter (Loc : Source_Ptr) is |
| begin |
| -- Increment the Id generator |
| |
| Counter := Counter + 1; |
| |
| -- Create the entity and declaration |
| |
| Counter_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name ('C', Counter)); |
| |
| -- Generate: |
| -- Cnn : Integer := 0; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Counter_Id, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Integer, Loc), |
| Expression => |
| Make_Integer_Literal (Loc, 0))); |
| end Make_Counter; |
| |
| -- Start of processing for Build_Init_Statements |
| |
| begin |
| if Null_Present (Comp_List) then |
| return New_List (Make_Null_Statement (Loc)); |
| end if; |
| |
| Parent_Stmts := New_List; |
| Stmts := New_List; |
| |
| -- Loop through visible declarations of task types and protected |
| -- types moving any expanded code from the spec to the body of the |
| -- init procedure. |
| |
| if Is_Concurrent_Record_Type (Rec_Type) then |
| declare |
| Decl : constant Node_Id := |
| Parent (Corresponding_Concurrent_Type (Rec_Type)); |
| Def : Node_Id; |
| N1 : Node_Id; |
| N2 : Node_Id; |
| |
| begin |
| if Is_Task_Record_Type (Rec_Type) then |
| Def := Task_Definition (Decl); |
| else |
| Def := Protected_Definition (Decl); |
| end if; |
| |
| if Present (Def) then |
| N1 := First (Visible_Declarations (Def)); |
| while Present (N1) loop |
| N2 := N1; |
| N1 := Next (N1); |
| |
| if Nkind (N2) in N_Statement_Other_Than_Procedure_Call |
| or else Nkind (N2) in N_Raise_xxx_Error |
| or else Nkind (N2) = N_Procedure_Call_Statement |
| then |
| Append_To (Stmts, |
| New_Copy_Tree (N2, New_Scope => Proc_Id)); |
| Rewrite (N2, Make_Null_Statement (Sloc (N2))); |
| Analyze (N2); |
| end if; |
| end loop; |
| end if; |
| end; |
| end if; |
| |
| -- Loop through components, skipping pragmas, in 2 steps. The first |
| -- step deals with regular components. The second step deals with |
| -- components that require late initialization. |
| |
| -- First pass : regular components |
| |
| Decl := First_Non_Pragma (Component_Items (Comp_List)); |
| while Present (Decl) loop |
| Comp_Loc := Sloc (Decl); |
| Build_Record_Checks |
| (Subtype_Indication (Component_Definition (Decl)), Checks); |
| |
| Id := Defining_Identifier (Decl); |
| Typ := Etype (Id); |
| |
| -- Leave any processing of component requiring late initialization |
| -- for the second pass. |
| |
| if Initialization_Control.Requires_Late_Init (Decl, Rec_Type) then |
| if not Has_Late_Init_Comp then |
| Late_Stmts := New_List; |
| end if; |
| Has_Late_Init_Comp := True; |
| |
| -- Regular component cases |
| |
| else |
| -- In the context of the init proc, references to discriminants |
| -- resolve to denote the discriminals: this is where we can |
| -- freeze discriminant dependent component subtypes. |
| |
| if not Is_Frozen (Typ) then |
| Append_List_To (Stmts, Freeze_Entity (Typ, N)); |
| end if; |
| |
| -- Explicit initialization |
| |
| if Present (Expression (Decl)) then |
| if Is_CPP_Constructor_Call (Expression (Decl)) then |
| Actions := |
| Build_Initialization_Call |
| (Comp_Loc, |
| Id_Ref => |
| Make_Selected_Component (Comp_Loc, |
| Prefix => |
| Make_Identifier (Comp_Loc, Name_uInit), |
| Selector_Name => |
| New_Occurrence_Of (Id, Comp_Loc)), |
| Typ => Typ, |
| In_Init_Proc => True, |
| Enclos_Type => Rec_Type, |
| Discr_Map => Discr_Map, |
| Constructor_Ref => Expression (Decl)); |
| else |
| Actions := Build_Assignment (Id, Expression (Decl)); |
| end if; |
| |
| -- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size |
| -- components are filled in with the corresponding rep-item |
| -- expression of the concurrent type (if any). |
| |
| elsif Ekind (Scope (Id)) = E_Record_Type |
| and then Present (Corresponding_Concurrent_Type (Scope (Id))) |
| and then Chars (Id) in Name_uCPU |
| | Name_uDispatching_Domain |
| | Name_uPriority |
| | Name_uSecondary_Stack_Size |
| then |
| declare |
| Exp : Node_Id; |
| Nam : Name_Id; |
| pragma Warnings (Off, Nam); |
| Ritem : Node_Id; |
| |
| begin |
| if Chars (Id) = Name_uCPU then |
| Nam := Name_CPU; |
| |
| elsif Chars (Id) = Name_uDispatching_Domain then |
| Nam := Name_Dispatching_Domain; |
| |
| elsif Chars (Id) = Name_uPriority then |
| Nam := Name_Priority; |
| |
| elsif Chars (Id) = Name_uSecondary_Stack_Size then |
| Nam := Name_Secondary_Stack_Size; |
| end if; |
| |
| -- Get the Rep Item (aspect specification, attribute |
| -- definition clause or pragma) of the corresponding |
| -- concurrent type. |
| |
| Ritem := |
| Get_Rep_Item |
| (Corresponding_Concurrent_Type (Scope (Id)), |
| Nam, |
| Check_Parents => False); |
| |
| if Present (Ritem) then |
| |
| -- Pragma case |
| |
| if Nkind (Ritem) = N_Pragma then |
| Exp := |
| Get_Pragma_Arg |
| (First (Pragma_Argument_Associations (Ritem))); |
| |
| -- Conversion for Priority expression |
| |
| if Nam = Name_Priority then |
| if Pragma_Name (Ritem) = Name_Priority |
| and then not GNAT_Mode |
| then |
| Exp := Convert_To (RTE (RE_Priority), Exp); |
| else |
| Exp := |
| Convert_To (RTE (RE_Any_Priority), Exp); |
| end if; |
| end if; |
| |
| -- Aspect/Attribute definition clause case |
| |
| else |
| Exp := Expression (Ritem); |
| |
| -- Conversion for Priority expression |
| |
| if Nam = Name_Priority then |
| if Chars (Ritem) = Name_Priority |
| and then not GNAT_Mode |
| then |
| Exp := Convert_To (RTE (RE_Priority), Exp); |
| else |
| Exp := |
| Convert_To (RTE (RE_Any_Priority), Exp); |
| end if; |
| end if; |
| end if; |
| |
| -- Conversion for Dispatching_Domain value |
| |
| if Nam = Name_Dispatching_Domain then |
| Exp := |
| Unchecked_Convert_To |
| (RTE (RE_Dispatching_Domain_Access), Exp); |
| |
| -- Conversion for Secondary_Stack_Size value |
| |
| elsif Nam = Name_Secondary_Stack_Size then |
| Exp := Convert_To (RTE (RE_Size_Type), Exp); |
| end if; |
| |
| Actions := Build_Assignment (Id, Exp); |
| |
| -- Nothing needed if no Rep Item |
| |
| else |
| Actions := No_List; |
| end if; |
| end; |
| |
| -- Composite component with its own Init_Proc |
| |
| elsif not Is_Interface (Typ) |
| and then Has_Non_Null_Base_Init_Proc (Typ) |
| then |
| declare |
| use Initialization_Control; |
| Init_Control_Actual : Node_Id := Empty; |
| Is_Parent : constant Boolean := Chars (Id) = Name_uParent; |
| Init_Call_Stmts : List_Id; |
| begin |
| if Is_Parent and then Has_Late_Init_Component (Etype (Id)) |
| then |
| Init_Control_Actual := |
| Make_Mode_Literal (Comp_Loc, Early_Init_Only); |
| -- Parent_Id used later in second call to parent's |
| -- init proc to initialize late-init components. |
| Parent_Id := Id; |
| end if; |
| |
| Init_Call_Stmts := |
| Build_Initialization_Call |
| (Comp_Loc, |
| Make_Selected_Component (Comp_Loc, |
| Prefix => |
| Make_Identifier (Comp_Loc, Name_uInit), |
| Selector_Name => New_Occurrence_Of (Id, Comp_Loc)), |
| Typ, |
| In_Init_Proc => True, |
| Enclos_Type => Rec_Type, |
| Discr_Map => Discr_Map, |
| Init_Control_Actual => Init_Control_Actual); |
| |
| if Is_Parent then |
| -- This is tricky. At first it looks like |
| -- we are going to end up with nested |
| -- if-statements with the same condition: |
| -- if Early_Init_Condition then |
| -- if Early_Init_Condition then |
| -- Parent_TypeIP (...); |
| -- end if; |
| -- end if; |
| -- But later we will hoist the inner if-statement |
| -- out of the outer one; we do this because the |
| -- init-proc call for the _Parent component of a type |
| -- extension has to precede any other initialization. |
| Actions := |
| New_List (Make_If_Statement (Loc, |
| Condition => |
| Early_Init_Condition (Loc, Init_Control_Formal), |
| Then_Statements => Init_Call_Stmts)); |
| else |
| Actions := Init_Call_Stmts; |
| end if; |
| end; |
| |
| Clean_Task_Names (Typ, Proc_Id); |
| |
| -- Simple initialization. If the Esize is not yet set, we pass |
| -- Uint_0 as expected by Get_Simple_Init_Val. |
| |
| elsif Component_Needs_Simple_Initialization (Typ) then |
| Actions := |
| Build_Assignment |
| (Id => Id, |
| Default => |
| Get_Simple_Init_Val |
| (Typ => Typ, |
| N => N, |
| Size => |
| (if Known_Esize (Id) then Esize (Id) |
| else Uint_0))); |
| |
| -- Nothing needed for this case |
| |
| else |
| Actions := No_List; |
| end if; |
| |
| -- When the component's type has a Default_Initial_Condition, |
| -- and the component is default initialized, then check the |
| -- DIC here. |
| |
| if Has_DIC (Typ) |
| and then No (Expression (Decl)) |
| and then Present (DIC_Procedure (Typ)) |
| and then not Has_Null_Body (DIC_Procedure (Typ)) |
| |
| -- The DICs of ancestors are checked as part of the type's |
| -- DIC procedure. |
| |
| and then Chars (Id) /= Name_uParent |
| |
| -- In GNATprove mode, the component DICs are checked by other |
| -- means. They should not be added to the record type DIC |
| -- procedure, so that the procedure can be used to check the |
| -- record type invariants or DICs if any. |
| |
| and then not GNATprove_Mode |
| then |
| Append_New_To (Actions, |
| Build_DIC_Call |
| (Comp_Loc, |
| Make_Selected_Component (Comp_Loc, |
| Prefix => |
| Make_Identifier (Comp_Loc, Name_uInit), |
| Selector_Name => |
| New_Occurrence_Of (Id, Comp_Loc)), |
| Typ)); |
| end if; |
| |
| if Present (Checks) then |
| if Chars (Id) = Name_uParent then |
| Append_List_To (Parent_Stmts, Checks); |
| else |
| Append_List_To (Stmts, Checks); |
| end if; |
| end if; |
| |
| if Present (Actions) then |
| if Chars (Id) = Name_uParent then |
| Append_List_To (Parent_Stmts, Actions); |
| else |
| Append_List_To (Stmts, Actions); |
| |
| -- Preserve initialization state in the current counter |
| |
| if Needs_Finalization (Typ) then |
| if No (Counter_Id) then |
| Make_Counter (Comp_Loc); |
| end if; |
| |
| Increment_Counter (Comp_Loc); |
| end if; |
| end if; |
| end if; |
| end if; |
| |
| Next_Non_Pragma (Decl); |
| end loop; |
| |
| -- The parent field must be initialized first because variable |
| -- size components of the parent affect the location of all the |
| -- new components. |
| |
| Prepend_List_To (Stmts, Parent_Stmts); |
| |
| -- Set up tasks and protected object support. This needs to be done |
| -- before any component with a per-object access discriminant |
| -- constraint, or any variant part (which may contain such |
| -- components) is initialized, because the initialization of these |
| -- components may reference the enclosing concurrent object. |
| |
| -- For a task record type, add the task create call and calls to bind |
| -- any interrupt (signal) entries. |
| |
| if Is_Task_Record_Type (Rec_Type) then |
| |
| -- In the case of the restricted run time the ATCB has already |
| -- been preallocated. |
| |
| if Restricted_Profile then |
| Append_To (Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uInit), |
| Selector_Name => Make_Identifier (Loc, Name_uATCB)), |
| Attribute_Name => Name_Unchecked_Access))); |
| end if; |
| |
| Append_To (Stmts, Make_Task_Create_Call (Rec_Type)); |
| |
| declare |
| Task_Type : constant Entity_Id := |
| Corresponding_Concurrent_Type (Rec_Type); |
| Task_Decl : constant Node_Id := Parent (Task_Type); |
| Task_Def : constant Node_Id := Task_Definition (Task_Decl); |
| Decl_Loc : Source_Ptr; |
| Ent : Entity_Id; |
| Vis_Decl : Node_Id; |
| |
| begin |
| if Present (Task_Def) then |
| Vis_Decl := First (Visible_Declarations (Task_Def)); |
| while Present (Vis_Decl) loop |
| Decl_Loc := Sloc (Vis_Decl); |
| |
| if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then |
| if Get_Attribute_Id (Chars (Vis_Decl)) = |
| Attribute_Address |
| then |
| Ent := Entity (Name (Vis_Decl)); |
| |
| if Ekind (Ent) = E_Entry then |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Decl_Loc, |
| Name => |
| New_Occurrence_Of (RTE ( |
| RE_Bind_Interrupt_To_Entry), Decl_Loc), |
| Parameter_Associations => New_List ( |
| Make_Selected_Component (Decl_Loc, |
| Prefix => |
| Make_Identifier (Decl_Loc, Name_uInit), |
| Selector_Name => |
| Make_Identifier |
| (Decl_Loc, Name_uTask_Id)), |
| Entry_Index_Expression |
| (Decl_Loc, Ent, Empty, Task_Type), |
| Expression (Vis_Decl)))); |
| end if; |
| end if; |
| end if; |
| |
| Next (Vis_Decl); |
| end loop; |
| end if; |
| end; |
| |
| -- For a protected type, add statements generated by |
| -- Make_Initialize_Protection. |
| |
| elsif Is_Protected_Record_Type (Rec_Type) then |
| Append_List_To (Stmts, |
| Make_Initialize_Protection (Rec_Type)); |
| end if; |
| |
| -- Second pass: components that require late initialization |
| |
| if Present (Parent_Id) then |
| declare |
| Parent_Loc : constant Source_Ptr := Sloc (Parent (Parent_Id)); |
| use Initialization_Control; |
| begin |
| -- We are building the init proc for a type extension. |
| -- Call the parent type's init proc a second time, this |
| -- time to initialize the parent's components that require |
| -- late initialization. |
| |
| Append_List_To (Late_Stmts, |
| Build_Initialization_Call |
| (Loc => Parent_Loc, |
| Id_Ref => |
| Make_Selected_Component (Parent_Loc, |
| Prefix => Make_Identifier |
| (Parent_Loc, Name_uInit), |
| Selector_Name => New_Occurrence_Of (Parent_Id, |
| Parent_Loc)), |
| Typ => Etype (Parent_Id), |
| In_Init_Proc => True, |
| Enclos_Type => Rec_Type, |
| Discr_Map => Discr_Map, |
| Init_Control_Actual => Make_Mode_Literal |
| (Parent_Loc, Late_Init_Only))); |
| end; |
| end if; |
| |
| if Has_Late_Init_Comp then |
| Decl := First_Non_Pragma (Component_Items (Comp_List)); |
| while Present (Decl) loop |
| Comp_Loc := Sloc (Decl); |
| Id := Defining_Identifier (Decl); |
| Typ := Etype (Id); |
| |
| if Initialization_Control.Requires_Late_Init (Decl, Rec_Type) |
| then |
| if Present (Expression (Decl)) then |
| Append_List_To (Late_Stmts, |
| Build_Assignment (Id, Expression (Decl))); |
| |
| elsif Has_Non_Null_Base_Init_Proc (Typ) then |
| Append_List_To (Late_Stmts, |
| Build_Initialization_Call (Comp_Loc, |
| Make_Selected_Component (Comp_Loc, |
| Prefix => |
| Make_Identifier (Comp_Loc, Name_uInit), |
| Selector_Name => New_Occurrence_Of (Id, Comp_Loc)), |
| Typ, |
| In_Init_Proc => True, |
| Enclos_Type => Rec_Type, |
| Discr_Map => Discr_Map)); |
| |
| Clean_Task_Names (Typ, Proc_Id); |
| |
| -- Preserve initialization state in the current counter |
| |
| if Needs_Finalization (Typ) then |
| if No (Counter_Id) then |
| Make_Counter (Comp_Loc); |
| end if; |
| |
| Increment_Counter (Comp_Loc, Late => True); |
| end if; |
| elsif Component_Needs_Simple_Initialization (Typ) then |
| Append_List_To (Late_Stmts, |
| Build_Assignment |
| (Id => Id, |
| Default => |
| Get_Simple_Init_Val |
| (Typ => Typ, |
| N => N, |
| Size => Esize (Id)))); |
| end if; |
| end if; |
| |
| Next_Non_Pragma (Decl); |
| end loop; |
| end if; |
| |
| -- Process the variant part (incorrectly ignoring late |
| -- initialization requirements for components therein). |
| |
| if Present (Variant_Part (Comp_List)) then |
| declare |
| Variant_Alts : constant List_Id := New_List; |
| Var_Loc : Source_Ptr := No_Location; |
| Variant : Node_Id; |
| |
| begin |
| Variant := |
| First_Non_Pragma (Variants (Variant_Part (Comp_List))); |
| while Present (Variant) loop |
| Var_Loc := Sloc (Variant); |
| Append_To (Variant_Alts, |
| Make_Case_Statement_Alternative (Var_Loc, |
| Discrete_Choices => |
| New_Copy_List (Discrete_Choices (Variant)), |
| Statements => |
| Build_Init_Statements (Component_List (Variant)))); |
| Next_Non_Pragma (Variant); |
| end loop; |
| |
| -- The expression of the case statement which is a reference |
| -- to one of the discriminants is replaced by the appropriate |
| -- formal parameter of the initialization procedure. |
| |
| Append_To (Stmts, |
| Make_Case_Statement (Var_Loc, |
| Expression => |
| New_Occurrence_Of (Discriminal ( |
| Entity (Name (Variant_Part (Comp_List)))), Var_Loc), |
| Alternatives => Variant_Alts)); |
| end; |
| end if; |
| |
| if No (Init_Control_Formal) then |
| Append_List_To (Stmts, Late_Stmts); |
| |
| -- If no initializations were generated for component declarations |
| -- and included in Stmts, then append a null statement to Stmts |
| -- to make it a valid Ada tree. |
| |
| if Is_Empty_List (Stmts) then |
| Append (Make_Null_Statement (Loc), Stmts); |
| end if; |
| |
| return Stmts; |
| else |
| declare |
| use Initialization_Control; |
| |
| If_Early : constant Node_Id := |
| (if Is_Empty_List (Stmts) then |
| Make_Null_Statement (Loc) |
| else |
| Make_If_Statement (Loc, |
| Condition => |
| Early_Init_Condition (Loc, Init_Control_Formal), |
| Then_Statements => Stmts)); |
| If_Late : constant Node_Id := |
| (if Is_Empty_List (Late_Stmts) then |
| Make_Null_Statement (Loc) |
| else |
| Make_If_Statement (Loc, |
| Condition => |
| Late_Init_Condition (Loc, Init_Control_Formal), |
| Then_Statements => Late_Stmts)); |
| begin |
| return New_List (If_Early, If_Late); |
| end; |
| end if; |
| exception |
| when RE_Not_Available => |
| return Empty_List; |
| end Build_Init_Statements; |
| |
| ------------------------- |
| -- Build_Record_Checks -- |
| ------------------------- |
| |
| procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is |
| Subtype_Mark_Id : Entity_Id; |
| |
| procedure Constrain_Array |
| (SI : Node_Id; |
| Check_List : List_Id); |
| -- Apply a list of index constraints to an unconstrained array type. |
| -- The first parameter is the entity for the resulting subtype. |
| -- Check_List is a list to which the check actions are appended. |
| |
| --------------------- |
| -- Constrain_Array -- |
| --------------------- |
| |
| procedure Constrain_Array |
| (SI : Node_Id; |
| Check_List : List_Id) |
| is |
| C : constant Node_Id := Constraint (SI); |
| Number_Of_Constraints : Nat := 0; |
| Index : Node_Id; |
| S, T : Entity_Id; |
| |
| procedure Constrain_Index |
| (Index : Node_Id; |
| S : Node_Id; |
| Check_List : List_Id); |
| -- Process an index constraint in a constrained array declaration. |
| -- The constraint can be either a subtype name or a range with or |
| -- without an explicit subtype mark. Index is the corresponding |
| -- index of the unconstrained array. S is the range expression. |
| -- Check_List is a list to which the check actions are appended. |
| |
| --------------------- |
| -- Constrain_Index -- |
| --------------------- |
| |
| procedure Constrain_Index |
| (Index : Node_Id; |
| S : Node_Id; |
| Check_List : List_Id) |
| is |
| T : constant Entity_Id := Etype (Index); |
| |
| begin |
| if Nkind (S) = N_Range then |
| Process_Range_Expr_In_Decl (S, T, Check_List => Check_List); |
| end if; |
| end Constrain_Index; |
| |
| -- Start of processing for Constrain_Array |
| |
| begin |
| T := Entity (Subtype_Mark (SI)); |
| |
| if Is_Access_Type (T) then |
| T := Designated_Type (T); |
| end if; |
| |
| S := First (Constraints (C)); |
| while Present (S) loop |
| Number_Of_Constraints := Number_Of_Constraints + 1; |
| Next (S); |
| end loop; |
| |
| -- In either case, the index constraint must provide a discrete |
| -- range for each index of the array type and the type of each |
| -- discrete range must be the same as that of the corresponding |
| -- index. (RM 3.6.1) |
| |
| S := First (Constraints (C)); |
| Index := First_Index (T); |
| Analyze (Index); |
| |
| -- Apply constraints to each index type |
| |
| for J in 1 .. Number_Of_Constraints loop |
| Constrain_Index (Index, S, Check_List); |
| Next (Index); |
| Next (S); |
| end loop; |
| end Constrain_Array; |
| |
| -- Start of processing for Build_Record_Checks |
| |
| begin |
| if Nkind (S) = N_Subtype_Indication then |
| Find_Type (Subtype_Mark (S)); |
| Subtype_Mark_Id := Entity (Subtype_Mark (S)); |
| |
| -- Remaining processing depends on type |
| |
| case Ekind (Subtype_Mark_Id) is |
| when Array_Kind => |
| Constrain_Array (S, Check_List); |
| |
| when others => |
| null; |
| end case; |
| end if; |
| end Build_Record_Checks; |
| |
| ------------------------------------------- |
| -- Component_Needs_Simple_Initialization -- |
| ------------------------------------------- |
| |
| function Component_Needs_Simple_Initialization |
| (T : Entity_Id) return Boolean |
| is |
| begin |
| return |
| Needs_Simple_Initialization (T) |
| and then not Is_RTE (T, RE_Tag) |
| |
| -- Ada 2005 (AI-251): Check also the tag of abstract interfaces |
| |
| and then not Is_RTE (T, RE_Interface_Tag); |
| end Component_Needs_Simple_Initialization; |
| |
| -------------------------------------- |
| -- Parent_Subtype_Renaming_Discrims -- |
| -------------------------------------- |
| |
| function Parent_Subtype_Renaming_Discrims return Boolean is |
| De : Entity_Id; |
| Dp : Entity_Id; |
| |
| begin |
| if Base_Type (Rec_Ent) /= Rec_Ent then |
| return False; |
| end if; |
| |
| if Etype (Rec_Ent) = Rec_Ent |
| or else not Has_Discriminants (Rec_Ent) |
| or else Is_Constrained (Rec_Ent) |
| or else Is_Tagged_Type (Rec_Ent) |
| then |
| return False; |
| end if; |
| |
| -- If there are no explicit stored discriminants we have inherited |
| -- the root type discriminants so far, so no renamings occurred. |
| |
| if First_Discriminant (Rec_Ent) = |
| First_Stored_Discriminant (Rec_Ent) |
| then |
| return False; |
| end if; |
| |
| -- Check if we have done some trivial renaming of the parent |
| -- discriminants, i.e. something like |
| -- |
| -- type DT (X1, X2: int) is new PT (X1, X2); |
| |
| De := First_Discriminant (Rec_Ent); |
| Dp := First_Discriminant (Etype (Rec_Ent)); |
| while Present (De) loop |
| pragma Assert (Present (Dp)); |
| |
| if Corresponding_Discriminant (De) /= Dp then |
| return True; |
| end if; |
| |
| Next_Discriminant (De); |
| Next_Discriminant (Dp); |
| end loop; |
| |
| return Present (Dp); |
| end Parent_Subtype_Renaming_Discrims; |
| |
| ------------------------ |
| -- Requires_Init_Proc -- |
| ------------------------ |
| |
| function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is |
| Comp_Decl : Node_Id; |
| Id : Entity_Id; |
| Typ : Entity_Id; |
| |
| begin |
| -- Definitely do not need one if specifically suppressed |
| |
| if Initialization_Suppressed (Rec_Id) then |
| return False; |
| end if; |
| |
| -- If it is a type derived from a type with unknown discriminants, |
| -- we cannot build an initialization procedure for it. |
| |
| if Has_Unknown_Discriminants (Rec_Id) |
| or else Has_Unknown_Discriminants (Etype (Rec_Id)) |
| then |
| return False; |
| end if; |
| |
| -- Otherwise we need to generate an initialization procedure if |
| -- Is_CPP_Class is False and at least one of the following applies: |
| |
| -- 1. Discriminants are present, since they need to be initialized |
| -- with the appropriate discriminant constraint expressions. |
| -- However, the discriminant of an unchecked union does not |
| -- count, since the discriminant is not present. |
| |
| -- 2. The type is a tagged type, since the implicit Tag component |
| -- needs to be initialized with a pointer to the dispatch table. |
| |
| -- 3. The type contains tasks |
| |
| -- 4. One or more components has an initial value |
| |
| -- 5. One or more components is for a type which itself requires |
| -- an initialization procedure. |
| |
| -- 6. One or more components is a type that requires simple |
| -- initialization (see Needs_Simple_Initialization), except |
| -- that types Tag and Interface_Tag are excluded, since fields |
| -- of these types are initialized by other means. |
| |
| -- 7. The type is the record type built for a task type (since at |
| -- the very least, Create_Task must be called) |
| |
| -- 8. The type is the record type built for a protected type (since |
| -- at least Initialize_Protection must be called) |
| |
| -- 9. The type is marked as a public entity. The reason we add this |
| -- case (even if none of the above apply) is to properly handle |
| -- Initialize_Scalars. If a package is compiled without an IS |
| -- pragma, and the client is compiled with an IS pragma, then |
| -- the client will think an initialization procedure is present |
| -- and call it, when in fact no such procedure is required, but |
| -- since the call is generated, there had better be a routine |
| -- at the other end of the call, even if it does nothing). |
| |
| -- Note: the reason we exclude the CPP_Class case is because in this |
| -- case the initialization is performed by the C++ constructors, and |
| -- the IP is built by Set_CPP_Constructors. |
| |
| if Is_CPP_Class (Rec_Id) then |
| return False; |
| |
| elsif Is_Interface (Rec_Id) then |
| return False; |
| |
| elsif (Has_Discriminants (Rec_Id) |
| and then not Is_Unchecked_Union (Rec_Id)) |
| or else Is_Tagged_Type (Rec_Id) |
| or else Is_Concurrent_Record_Type (Rec_Id) |
| or else Has_Task (Rec_Id) |
| then |
| return True; |
| end if; |
| |
| Id := First_Component (Rec_Id); |
| while Present (Id) loop |
| Comp_Decl := Parent (Id); |
| Typ := Etype (Id); |
| |
| if Present (Expression (Comp_Decl)) |
| or else Has_Non_Null_Base_Init_Proc (Typ) |
| or else Component_Needs_Simple_Initialization (Typ) |
| then |
| return True; |
| end if; |
| |
| Next_Component (Id); |
| end loop; |
| |
| -- As explained above, a record initialization procedure is needed |
| -- for public types in case Initialize_Scalars applies to a client. |
| -- However, such a procedure is not needed in the case where either |
| -- of restrictions No_Initialize_Scalars or No_Default_Initialization |
| -- applies. No_Initialize_Scalars excludes the possibility of using |
| -- Initialize_Scalars in any partition, and No_Default_Initialization |
| -- implies that no initialization should ever be done for objects of |
| -- the type, so is incompatible with Initialize_Scalars. |
| |
| if not Restriction_Active (No_Initialize_Scalars) |
| and then not Restriction_Active (No_Default_Initialization) |
| and then Is_Public (Rec_Id) |
| then |
| return True; |
| end if; |
| |
| return False; |
| end Requires_Init_Proc; |
| |
| -- Start of processing for Build_Record_Init_Proc |
| |
| begin |
| Rec_Type := Defining_Identifier (N); |
| |
| -- This may be full declaration of a private type, in which case |
| -- the visible entity is a record, and the private entity has been |
| -- exchanged with it in the private part of the current package. |
| -- The initialization procedure is built for the record type, which |
| -- is retrievable from the private entity. |
| |
| if Is_Incomplete_Or_Private_Type (Rec_Type) then |
| Rec_Type := Underlying_Type (Rec_Type); |
| end if; |
| |
| -- If we have a variant record with restriction No_Implicit_Conditionals |
| -- in effect, then we skip building the procedure. This is safe because |
| -- if we can see the restriction, so can any caller, calls to initialize |
| -- such records are not allowed for variant records if this restriction |
| -- is active. |
| |
| if Has_Variant_Part (Rec_Type) |
| and then Restriction_Active (No_Implicit_Conditionals) |
| then |
| return; |
| end if; |
| |
| -- If there are discriminants, build the discriminant map to replace |
| -- discriminants by their discriminals in complex bound expressions. |
| -- These only arise for the corresponding records of synchronized types. |
| |
| if Is_Concurrent_Record_Type (Rec_Type) |
| and then Has_Discriminants (Rec_Type) |
| then |
| declare |
| Disc : Entity_Id; |
| begin |
| Disc := First_Discriminant (Rec_Type); |
| while Present (Disc) loop |
| Append_Elmt (Disc, Discr_Map); |
| Append_Elmt (Discriminal (Disc), Discr_Map); |
| Next_Discriminant (Disc); |
| end loop; |
| end; |
| end if; |
| |
| -- Derived types that have no type extension can use the initialization |
| -- procedure of their parent and do not need a procedure of their own. |
| -- This is only correct if there are no representation clauses for the |
| -- type or its parent, and if the parent has in fact been frozen so |
| -- that its initialization procedure exists. |
| |
| if Is_Derived_Type (Rec_Type) |
| and then not Is_Tagged_Type (Rec_Type) |
| and then not Is_Unchecked_Union (Rec_Type) |
| and then not Has_New_Non_Standard_Rep (Rec_Type) |
| and then not Parent_Subtype_Renaming_Discrims |
| and then Present (Base_Init_Proc (Etype (Rec_Type))) |
| then |
| Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type); |
| |
| -- Otherwise if we need an initialization procedure, then build one, |
| -- mark it as public and inlinable and as having a completion. |
| |
| elsif Requires_Init_Proc (Rec_Type) |
| or else Is_Unchecked_Union (Rec_Type) |
| then |
| Proc_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Make_Init_Proc_Name (Rec_Type)); |
| |
| -- If No_Default_Initialization restriction is active, then we don't |
| -- want to build an init_proc, but we need to mark that an init_proc |
| -- would be needed if this restriction was not active (so that we can |
| -- detect attempts to call it), so set a dummy init_proc in place. |
| |
| if Restriction_Active (No_Default_Initialization) then |
| Set_Init_Proc (Rec_Type, Proc_Id); |
| return; |
| end if; |
| |
| Build_Offset_To_Top_Functions; |
| Build_CPP_Init_Procedure; |
| Build_Init_Procedure; |
| |
| Set_Is_Public (Proc_Id, Is_Public (Rec_Ent)); |
| Set_Is_Internal (Proc_Id); |
| Set_Has_Completion (Proc_Id); |
| |
| if not Debug_Generated_Code then |
| Set_Debug_Info_Off (Proc_Id); |
| end if; |
| |
| Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Rec_Type)); |
| |
| -- Do not build an aggregate if Modify_Tree_For_C, this isn't |
| -- needed and may generate early references to non frozen types |
| -- since we expand aggregate much more systematically. |
| |
| if Modify_Tree_For_C then |
| return; |
| end if; |
| |
| declare |
| Agg : constant Node_Id := |
| Build_Equivalent_Record_Aggregate (Rec_Type); |
| |
| procedure Collect_Itypes (Comp : Node_Id); |
| -- Generate references to itypes in the aggregate, because |
| -- the first use of the aggregate may be in a nested scope. |
| |
| -------------------- |
| -- Collect_Itypes -- |
| -------------------- |
| |
| procedure Collect_Itypes (Comp : Node_Id) is |
| Ref : Node_Id; |
| Sub_Aggr : Node_Id; |
| Typ : constant Entity_Id := Etype (Comp); |
| |
| begin |
| if Is_Array_Type (Typ) and then Is_Itype (Typ) then |
| Ref := Make_Itype_Reference (Loc); |
| Set_Itype (Ref, Typ); |
| Append_Freeze_Action (Rec_Type, Ref); |
| |
| Ref := Make_Itype_Reference (Loc); |
| Set_Itype (Ref, Etype (First_Index (Typ))); |
| Append_Freeze_Action (Rec_Type, Ref); |
| |
| -- Recurse on nested arrays |
| |
| Sub_Aggr := First (Expressions (Comp)); |
| while Present (Sub_Aggr) loop |
| Collect_Itypes (Sub_Aggr); |
| Next (Sub_Aggr); |
| end loop; |
| end if; |
| end Collect_Itypes; |
| |
| begin |
| -- If there is a static initialization aggregate for the type, |
| -- generate itype references for the types of its (sub)components, |
| -- to prevent out-of-scope errors in the resulting tree. |
| -- The aggregate may have been rewritten as a Raise node, in which |
| -- case there are no relevant itypes. |
| |
| if Present (Agg) and then Nkind (Agg) = N_Aggregate then |
| Set_Static_Initialization (Proc_Id, Agg); |
| |
| declare |
| Comp : Node_Id; |
| begin |
| Comp := First (Component_Associations (Agg)); |
| while Present (Comp) loop |
| Collect_Itypes (Expression (Comp)); |
| Next (Comp); |
| end loop; |
| end; |
| end if; |
| end; |
| end if; |
| end Build_Record_Init_Proc; |
| |
| ---------------------------- |
| -- Build_Slice_Assignment -- |
| ---------------------------- |
| |
| -- Generates the following subprogram: |
| |
| -- procedure array_typeSA |
| -- (Source, Target : Array_Type, |
| -- Left_Lo, Left_Hi : Index; |
| -- Right_Lo, Right_Hi : Index; |
| -- Rev : Boolean) |
| -- is |
| -- Li1 : Index; |
| -- Ri1 : Index; |
| |
| -- begin |
| -- if Left_Hi < Left_Lo then |
| -- return; |
| -- end if; |
| |
| -- if Rev then |
| -- Li1 := Left_Hi; |
| -- Ri1 := Right_Hi; |
| -- else |
| -- Li1 := Left_Lo; |
| -- Ri1 := Right_Lo; |
| -- end if; |
| |
| -- loop |
| -- Target (Li1) := Source (Ri1); |
| |
| -- if Rev then |
| -- exit when Li1 = Left_Lo; |
| -- Li1 := Index'pred (Li1); |
| -- Ri1 := Index'pred (Ri1); |
| -- else |
| -- exit when Li1 = Left_Hi; |
| -- Li1 := Index'succ (Li1); |
| -- Ri1 := Index'succ (Ri1); |
| -- end if; |
| -- end loop; |
| -- end array_typeSA; |
| |
| procedure Build_Slice_Assignment (Typ : Entity_Id) is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); |
| |
| Larray : constant Entity_Id := Make_Temporary (Loc, 'A'); |
| Rarray : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| Left_Lo : constant Entity_Id := Make_Temporary (Loc, 'L'); |
| Left_Hi : constant Entity_Id := Make_Temporary (Loc, 'L'); |
| Right_Lo : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| Right_Hi : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| Rev : constant Entity_Id := Make_Temporary (Loc, 'D'); |
| -- Formal parameters of procedure |
| |
| Proc_Name : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Make_TSS_Name (Typ, TSS_Slice_Assign)); |
| |
| Lnn : constant Entity_Id := Make_Temporary (Loc, 'L'); |
| Rnn : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| -- Subscripts for left and right sides |
| |
| Decls : List_Id; |
| Loops : Node_Id; |
| Stats : List_Id; |
| |
| begin |
| -- Build declarations for indexes |
| |
| Decls := New_List; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Lnn, |
| Object_Definition => |
| New_Occurrence_Of (Index, Loc))); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Rnn, |
| Object_Definition => |
| New_Occurrence_Of (Index, Loc))); |
| |
| Stats := New_List; |
| |
| -- Build test for empty slice case |
| |
| Append_To (Stats, |
| Make_If_Statement (Loc, |
| Condition => |
| Make_Op_Lt (Loc, |
| Left_Opnd => New_Occurrence_Of (Left_Hi, Loc), |
| Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)), |
| Then_Statements => New_List (Make_Simple_Return_Statement (Loc)))); |
| |
| -- Build initializations for indexes |
| |
| declare |
| F_Init : constant List_Id := New_List; |
| B_Init : constant List_Id := New_List; |
| |
| begin |
| Append_To (F_Init, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Lnn, Loc), |
| Expression => New_Occurrence_Of (Left_Lo, Loc))); |
| |
| Append_To (F_Init, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Rnn, Loc), |
| Expression => New_Occurrence_Of (Right_Lo, Loc))); |
| |
| Append_To (B_Init, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Lnn, Loc), |
| Expression => New_Occurrence_Of (Left_Hi, Loc))); |
| |
| Append_To (B_Init, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Rnn, Loc), |
| Expression => New_Occurrence_Of (Right_Hi, Loc))); |
| |
| Append_To (Stats, |
| Make_If_Statement (Loc, |
| Condition => New_Occurrence_Of (Rev, Loc), |
| Then_Statements => B_Init, |
| Else_Statements => F_Init)); |
| end; |
| |
| -- Now construct the assignment statement |
| |
| Loops := |
| Make_Loop_Statement (Loc, |
| Statements => New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Indexed_Component (Loc, |
| Prefix => New_Occurrence_Of (Larray, Loc), |
| Expressions => New_List (New_Occurrence_Of (Lnn, Loc))), |
| Expression => |
| Make_Indexed_Component (Loc, |
| Prefix => New_Occurrence_Of (Rarray, Loc), |
| Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))), |
| End_Label => Empty); |
| |
| -- Build the exit condition and increment/decrement statements |
| |
| declare |
| F_Ass : constant List_Id := New_List; |
| B_Ass : constant List_Id := New_List; |
| |
| begin |
| Append_To (F_Ass, |
| Make_Exit_Statement (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => New_Occurrence_Of (Lnn, Loc), |
| Right_Opnd => New_Occurrence_Of (Left_Hi, Loc)))); |
| |
| Append_To (F_Ass, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Lnn, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Index, Loc), |
| Attribute_Name => Name_Succ, |
| Expressions => New_List ( |
| New_Occurrence_Of (Lnn, Loc))))); |
| |
| Append_To (F_Ass, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Rnn, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Index, Loc), |
| Attribute_Name => Name_Succ, |
| Expressions => New_List ( |
| New_Occurrence_Of (Rnn, Loc))))); |
| |
| Append_To (B_Ass, |
| Make_Exit_Statement (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => New_Occurrence_Of (Lnn, Loc), |
| Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)))); |
| |
| Append_To (B_Ass, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Lnn, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Index, Loc), |
| Attribute_Name => Name_Pred, |
| Expressions => New_List ( |
| New_Occurrence_Of (Lnn, Loc))))); |
| |
| Append_To (B_Ass, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Rnn, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Index, Loc), |
| Attribute_Name => Name_Pred, |
| Expressions => New_List ( |
| New_Occurrence_Of (Rnn, Loc))))); |
| |
| Append_To (Statements (Loops), |
| Make_If_Statement (Loc, |
| Condition => New_Occurrence_Of (Rev, Loc), |
| Then_Statements => B_Ass, |
| Else_Statements => F_Ass)); |
| end; |
| |
| Append_To (Stats, Loops); |
| |
| declare |
| Spec : Node_Id; |
| Formals : List_Id; |
| |
| begin |
| Formals := New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Larray, |
| Out_Present => True, |
| Parameter_Type => |
| New_Occurrence_Of (Base_Type (Typ), Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Rarray, |
| Parameter_Type => |
| New_Occurrence_Of (Base_Type (Typ), Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Left_Lo, |
| Parameter_Type => |
| New_Occurrence_Of (Index, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Left_Hi, |
| Parameter_Type => |
| New_Occurrence_Of (Index, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Right_Lo, |
| Parameter_Type => |
| New_Occurrence_Of (Index, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Right_Hi, |
| Parameter_Type => |
| New_Occurrence_Of (Index, Loc))); |
| |
| Append_To (Formals, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Rev, |
| Parameter_Type => |
| New_Occurrence_Of (Standard_Boolean, Loc))); |
| |
| Spec := |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Proc_Name, |
| Parameter_Specifications => Formals); |
| |
| Discard_Node ( |
| Make_Subprogram_Body (Loc, |
| Specification => Spec, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stats))); |
| end; |
| |
| Set_TSS (Typ, Proc_Name); |
| Set_Is_Pure (Proc_Name); |
| end Build_Slice_Assignment; |
| |
| ----------------------------- |
| -- Build_Untagged_Equality -- |
| ----------------------------- |
| |
| procedure Build_Untagged_Equality (Typ : Entity_Id) is |
| Build_Eq : Boolean; |
| Comp : Entity_Id; |
| Decl : Node_Id; |
| Op : Entity_Id; |
| Eq_Op : Entity_Id; |
| |
| function User_Defined_Eq (T : Entity_Id) return Entity_Id; |
| -- Check whether the type T has a user-defined primitive equality. If so |
| -- return it, else return Empty. If true for a component of Typ, we have |
| -- to build the primitive equality for it. |
| |
| --------------------- |
| -- User_Defined_Eq -- |
| --------------------- |
| |
| function User_Defined_Eq (T : Entity_Id) return Entity_Id is |
| Op : constant Entity_Id := TSS (T, TSS_Composite_Equality); |
| |
| begin |
| if Present (Op) then |
| return Op; |
| else |
| return Get_User_Defined_Equality (T); |
| end if; |
| end User_Defined_Eq; |
| |
| -- Start of processing for Build_Untagged_Equality |
| |
| begin |
| -- If a record component has a primitive equality operation, we must |
| -- build the corresponding one for the current type. |
| |
| Build_Eq := False; |
| Comp := First_Component (Typ); |
| while Present (Comp) loop |
| if Is_Record_Type (Etype (Comp)) |
| and then Present (User_Defined_Eq (Etype (Comp))) |
| then |
| Build_Eq := True; |
| exit; |
| end if; |
| |
| Next_Component (Comp); |
| end loop; |
| |
| -- If there is a user-defined equality for the type, we do not create |
| -- the implicit one. |
| |
| Eq_Op := Get_User_Defined_Equality (Typ); |
| if Present (Eq_Op) then |
| if Comes_From_Source (Eq_Op) then |
| Build_Eq := False; |
| else |
| Eq_Op := Empty; |
| end if; |
| end if; |
| |
| -- If the type is derived, inherit the operation, if present, from the |
| -- parent type. It may have been declared after the type derivation. If |
| -- the parent type itself is derived, it may have inherited an operation |
| -- that has itself been overridden, so update its alias and related |
| -- flags. Ditto for inequality. |
| |
| if No (Eq_Op) and then Is_Derived_Type (Typ) then |
| Eq_Op := Get_User_Defined_Equality (Etype (Typ)); |
| if Present (Eq_Op) then |
| Copy_TSS (Eq_Op, Typ); |
| Build_Eq := False; |
| |
| declare |
| Op : constant Entity_Id := User_Defined_Eq (Typ); |
| NE_Op : constant Entity_Id := Next_Entity (Eq_Op); |
| |
| begin |
| if Present (Op) then |
| Set_Alias (Op, Eq_Op); |
| Set_Is_Abstract_Subprogram |
| (Op, Is_Abstract_Subprogram (Eq_Op)); |
| |
| if Chars (Next_Entity (Op)) = Name_Op_Ne then |
| Set_Is_Abstract_Subprogram |
| (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op)); |
| end if; |
| end if; |
| end; |
| end if; |
| end if; |
| |
| -- If not inherited and not user-defined, build body as for a type with |
| -- components of record type (i.e. a type for which "=" composes when |
| -- used as a component in an outer composite type). |
| |
| if Build_Eq then |
| Decl := |
| Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality)); |
| Op := Defining_Entity (Decl); |
| Set_TSS (Typ, Op); |
| Set_Is_Pure (Op); |
| |
| if Is_Library_Level_Entity (Typ) then |
| Set_Is_Public (Op); |
| end if; |
| end if; |
| end Build_Untagged_Equality; |
| |
| ----------------------------------- |
| -- Build_Variant_Record_Equality -- |
| ----------------------------------- |
| |
| -- Generates: |
| |
| -- function <<Body_Id>> (Left, Right : T) return Boolean is |
| -- [ X : T renames Left; ] |
| -- [ Y : T renames Right; ] |
| -- -- The above renamings are generated only if the parameters of |
| -- -- this built function (which are passed by the caller) are not |
| -- -- named 'X' and 'Y'; these names are required to reuse several |
| -- -- expander routines when generating this body. |
| |
| -- begin |
| -- -- Compare discriminants |
| |
| -- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then |
| -- return False; |
| -- end if; |
| |
| -- -- Compare components |
| |
| -- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then |
| -- return False; |
| -- end if; |
| |
| -- -- Compare variant part |
| |
| -- case X.D1 is |
| -- when V1 => |
| -- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then |
| -- return False; |
| -- end if; |
| -- ... |
| -- when Vn => |
| -- if X.Cn /= Y.Cn or else ... then |
| -- return False; |
| -- end if; |
| -- end case; |
| |
| -- return True; |
| -- end _Equality; |
| |
| function Build_Variant_Record_Equality |
| (Typ : Entity_Id; |
| Body_Id : Entity_Id; |
| Param_Specs : List_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Def : constant Node_Id := Parent (Typ); |
| Comps : constant Node_Id := Component_List (Type_Definition (Def)); |
| Left : constant Entity_Id := Defining_Identifier (First (Param_Specs)); |
| Right : constant Entity_Id := |
| Defining_Identifier (Next (First (Param_Specs))); |
| Decls : constant List_Id := New_List; |
| Stmts : constant List_Id := New_List; |
| |
| Subp_Body : Node_Id; |
| |
| begin |
| pragma Assert (not Is_Tagged_Type (Typ)); |
| |
| -- In order to reuse the expander routines Make_Eq_If and Make_Eq_Case |
| -- the name of the formals must be X and Y; otherwise we generate two |
| -- renaming declarations for such purpose. |
| |
| if Chars (Left) /= Name_X then |
| Append_To (Decls, |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), |
| Subtype_Mark => New_Occurrence_Of (Typ, Loc), |
| Name => Make_Identifier (Loc, Chars (Left)))); |
| end if; |
| |
| if Chars (Right) /= Name_Y then |
| Append_To (Decls, |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), |
| Subtype_Mark => New_Occurrence_Of (Typ, Loc), |
| Name => Make_Identifier (Loc, Chars (Right)))); |
| end if; |
| |
| -- Unchecked_Unions require additional machinery to support equality. |
| -- Two extra parameters (A and B) are added to the equality function |
| -- parameter list for each discriminant of the type, in order to |
| -- capture the inferred values of the discriminants in equality calls. |
| -- The names of the parameters match the names of the corresponding |
| -- discriminant, with an added suffix. |
| |
| if Is_Unchecked_Union (Typ) then |
| declare |
| A : Entity_Id; |
| B : Entity_Id; |
| Discr : Entity_Id; |
| Discr_Type : Entity_Id; |
| New_Discrs : Elist_Id; |
| |
| begin |
| New_Discrs := New_Elmt_List; |
| |
| Discr := First_Discriminant (Typ); |
| while Present (Discr) loop |
| Discr_Type := Etype (Discr); |
| |
| A := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Chars (Discr), 'A')); |
| |
| B := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Chars (Discr), 'B')); |
| |
| -- Add new parameters to the parameter list |
| |
| Append_To (Param_Specs, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => A, |
| Parameter_Type => |
| New_Occurrence_Of (Discr_Type, Loc))); |
| |
| Append_To (Param_Specs, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => B, |
| Parameter_Type => |
| New_Occurrence_Of (Discr_Type, Loc))); |
| |
| Append_Elmt (A, New_Discrs); |
| |
| -- Generate the following code to compare each of the inferred |
| -- discriminants: |
| |
| -- if a /= b then |
| -- return False; |
| -- end if; |
| |
| Append_To (Stmts, |
| Make_If_Statement (Loc, |
| Condition => |
| Make_Op_Ne (Loc, |
| Left_Opnd => New_Occurrence_Of (A, Loc), |
| Right_Opnd => New_Occurrence_Of (B, Loc)), |
| Then_Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| New_Occurrence_Of (Standard_False, Loc))))); |
| Next_Discriminant (Discr); |
| end loop; |
| |
| -- Generate component-by-component comparison. Note that we must |
| -- propagate the inferred discriminants formals to act as the case |
| -- statement switch. Their value is added when an equality call on |
| -- unchecked unions is expanded. |
| |
| Append_List_To (Stmts, Make_Eq_Case (Typ, Comps, New_Discrs)); |
| end; |
| |
| -- Normal case (not unchecked union) |
| |
| else |
| Append_To (Stmts, |
| Make_Eq_If (Typ, Discriminant_Specifications (Def))); |
| Append_List_To (Stmts, Make_Eq_Case (Typ, Comps)); |
| end if; |
| |
| Append_To (Stmts, |
| Make_Simple_Return_Statement (Loc, |
| Expression => New_Occurrence_Of (Standard_True, Loc))); |
| |
| Subp_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Body_Id, |
| Parameter_Specifications => Param_Specs, |
| Result_Definition => |
| New_Occurrence_Of (Standard_Boolean, Loc)), |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stmts)); |
| |
| return Subp_Body; |
| 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 |
| -- Move this check to sem??? |
| |
| if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then |
| Error_Msg_Name_1 := Nam; |
| Error_Msg_N |
| ("|component& in limited extension must have% attribute", Comp); |
| end if; |
| end Check_Attr; |
| |
| -- Start of processing for Check_Stream_Attributes |
| |
| begin |
| if Par_Read or else Par_Write then |
| Comp := First_Component (Typ); |
| while Present (Comp) loop |
| if Comes_From_Source (Comp) |
| and then Original_Record_Component (Comp) = Comp |
| and then Is_Limited_Type (Etype (Comp)) |
| then |
| if Par_Read then |
| Check_Attr (Name_Read, TSS_Stream_Read); |
| end if; |
| |
| if Par_Write then |
| Check_Attr (Name_Write, TSS_Stream_Write); |
| end if; |
| end if; |
| |
| Next_Component (Comp); |
| end loop; |
| end if; |
| end Check_Stream_Attributes; |
| |
| ---------------------- |
| -- Clean_Task_Names -- |
| ---------------------- |
| |
| procedure Clean_Task_Names |
| (Typ : Entity_Id; |
| Proc_Id : Entity_Id) |
| is |
| begin |
| if Has_Task (Typ) |
| and then not Restriction_Active (No_Implicit_Heap_Allocations) |
| and then not Global_Discard_Names |
| and then Tagged_Type_Expansion |
| then |
| Set_Uses_Sec_Stack (Proc_Id); |
| end if; |
| end Clean_Task_Names; |
| |
| ------------------------------- |
| -- Copy_Discr_Checking_Funcs -- |
| ------------------------------- |
| |
| procedure Copy_Discr_Checking_Funcs (N : Node_Id) is |
| Typ : constant Entity_Id := Defining_Identifier (N); |
| Comp : Entity_Id := First_Component (Typ); |
| Old_Comp : Entity_Id := First_Component |
| (Base_Type (Underlying_Type (Etype (Typ)))); |
| begin |
| while Present (Comp) loop |
| if 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 Copy_Discr_Checking_Funcs; |
| |
| ------------------------------ |
| -- Expand_Freeze_Array_Type -- |
| ------------------------------ |
| |
| procedure Expand_Freeze_Array_Type (N : Node_Id) is |
| Typ : constant Entity_Id := Entity (N); |
| Base : constant Entity_Id := Base_Type (Typ); |
| Comp_Typ : constant Entity_Id := Component_Type (Typ); |
| |
| begin |
| if not Is_Bit_Packed_Array (Typ) then |
| |
| -- If the component contains tasks, so does the array type. This may |
| -- not be indicated in the array type because the component may have |
| -- been a private type at the point of definition. Same if component |
| -- type is controlled or contains protected objects. |
| |
| Propagate_Concurrent_Flags (Base, Comp_Typ); |
| Set_Has_Controlled_Component |
| (Base, Has_Controlled_Component (Comp_Typ) |
| or else Is_Controlled (Comp_Typ)); |
| |
| if No (Init_Proc (Base)) then |
| |
| -- If this is an anonymous array created for a declaration with |
| -- an initial value, its init_proc will never be called. The |
| -- initial value itself may have been expanded into assignments, |
| -- in which case the object declaration is carries the |
| -- No_Initialization flag. |
| |
| if Is_Itype (Base) |
| and then Nkind (Associated_Node_For_Itype (Base)) = |
| N_Object_Declaration |
| and then |
| (Present (Expression (Associated_Node_For_Itype (Base))) |
| or else No_Initialization (Associated_Node_For_Itype (Base))) |
| then |
| null; |
| |
| -- We do not need an init proc for string or wide [wide] string, |
| -- since the only time these need initialization in normalize or |
| -- initialize scalars mode, and these types are treated specially |
| -- and do not need initialization procedures. |
| |
| elsif Is_Standard_String_Type (Base) then |
| null; |
| |
| -- Otherwise we have to build an init proc for the subtype |
| |
| else |
| Build_Array_Init_Proc (Base, N); |
| end if; |
| end if; |
| |
| if Typ = Base and then Has_Controlled_Component (Base) then |
| Build_Controlling_Procs (Base); |
| |
| if not Is_Limited_Type (Comp_Typ) |
| and then Number_Dimensions (Typ) = 1 |
| then |
| Build_Slice_Assignment (Typ); |
| end if; |
| end if; |
| |
| -- For packed case, default initialization, except if the component type |
| -- is itself a packed structure with an initialization procedure, or |
| -- initialize/normalize scalars active, and we have a base type, or the |
| -- type is public, because in that case a client might specify |
| -- Normalize_Scalars and there better be a public Init_Proc for it. |
| |
| elsif (Present (Init_Proc (Component_Type (Base))) |
| and then No (Base_Init_Proc (Base))) |
| or else (Init_Or_Norm_Scalars and then Base = Typ) |
| or else Is_Public (Typ) |
| then |
| Build_Array_Init_Proc (Base, N); |
| end if; |
| end Expand_Freeze_Array_Type; |
| |
| ----------------------------------- |
| -- Expand_Freeze_Class_Wide_Type -- |
| ----------------------------------- |
| |
| procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is |
| function Is_C_Derivation (Typ : Entity_Id) return Boolean; |
| -- Given a type, determine whether it is derived from a C or C++ root |
| |
| --------------------- |
| -- Is_C_Derivation -- |
| --------------------- |
| |
| function Is_C_Derivation (Typ : Entity_Id) return Boolean is |
| T : Entity_Id; |
| |
| begin |
| T := Typ; |
| loop |
| if Is_CPP_Class (T) |
| or else Convention (T) = Convention_C |
| or else Convention (T) = Convention_CPP |
| then |
| return True; |
| end if; |
| |
| exit when T = Etype (T); |
| |
| T := Etype (T); |
| end loop; |
| |
| return False; |
| end Is_C_Derivation; |
| |
| -- Local variables |
| |
| Typ : constant Entity_Id := Entity (N); |
| Root : constant Entity_Id := Root_Type (Typ); |
| |
| -- Start of processing for Expand_Freeze_Class_Wide_Type |
| |
| begin |
| -- Certain run-time configurations and targets do not provide support |
| -- for controlled types. |
| |
| if Restriction_Active (No_Finalization) then |
| return; |
| |
| -- Do not create TSS routine Finalize_Address when dispatching calls are |
| -- disabled since the core of the routine is a dispatching call. |
| |
| elsif Restriction_Active (No_Dispatching_Calls) then |
| return; |
| |
| -- Do not create TSS routine Finalize_Address for concurrent class-wide |
| -- types. Ignore C, C++, CIL and Java types since it is assumed that the |
| -- non-Ada side will handle their destruction. |
| |
| elsif Is_Concurrent_Type (Root) |
| or else Is_C_Derivation (Root) |
| or else Convention (Typ) = Convention_CPP |
| then |
| return; |
| |
| -- Do not create TSS routine Finalize_Address when compiling in CodePeer |
| -- mode since the routine contains an Unchecked_Conversion. |
| |
| elsif CodePeer_Mode then |
| return; |
| end if; |
| |
| -- Create the body of TSS primitive Finalize_Address. This automatically |
| -- sets the TSS entry for the class-wide type. |
| |
| Make_Finalize_Address_Body (Typ); |
| end Expand_Freeze_Class_Wide_Type; |
| |
| ------------------------------------ |
| -- Expand_Freeze_Enumeration_Type -- |
| ------------------------------------ |
| |
| procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is |
| Typ : constant Entity_Id := Entity (N); |
| Loc : constant Source_Ptr := Sloc (Typ); |
| |
| Arr : Entity_Id; |
| Ent : Entity_Id; |
| Fent : Entity_Id; |
| Is_Contiguous : Boolean; |
| Index_Typ : Entity_Id; |
| Ityp : Entity_Id; |
| Last_Repval : Uint; |
| Lst : List_Id; |
| Num : Nat; |
| Pos_Expr : Node_Id; |
| |
| Func : Entity_Id; |
| pragma Warnings (Off, Func); |
| |
| begin |
| -- Various optimizations possible if given representation is contiguous |
| |
| Is_Contiguous := True; |
| |
| Ent := First_Literal (Typ); |
| Last_Repval := Enumeration_Rep (Ent); |
| Num := 1; |
| Next_Literal (Ent); |
| |
| while Present (Ent) loop |
| if Enumeration_Rep (Ent) - Last_Repval /= 1 then |
| Is_Contiguous := False; |
| else |
| Last_Repval := Enumeration_Rep (Ent); |
| end if; |
| |
| Num := Num + 1; |
| Next_Literal (Ent); |
| end loop; |
| |
| if Is_Contiguous then |
| Set_Has_Contiguous_Rep (Typ); |
| |
| -- Now build a subtype declaration |
| |
| -- subtype typI is new Natural range 0 .. num - 1 |
| |
| Index_Typ := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Chars (Typ), 'I')); |
| |
| Append_Freeze_Action (Typ, |
| Make_Subtype_Declaration (Loc, |
| Defining_Identifier => Index_Typ, |
| Subtype_Indication => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (Standard_Natural, Loc), |
| Constraint => |
| Make_Range_Constraint (Loc, |
| Range_Expression => |
| Make_Range (Loc, |
| Low_Bound => |
| Make_Integer_Literal (Loc, 0), |
| High_Bound => |
| Make_Integer_Literal (Loc, Num - 1)))))); |
| |
| Set_Enum_Pos_To_Rep (Typ, Index_Typ); |
| |
| else |
| -- Build list of literal references |
| |
| Lst := New_List; |
| Ent := First_Literal (Typ); |
| while Present (Ent) loop |
| Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent))); |
| Next_Literal (Ent); |
| end loop; |
| |
| -- Now build an array declaration |
| |
| -- typA : constant array (Natural range 0 .. num - 1) of typ := |
| -- (v, v, v, v, v, ....) |
| |
| Arr := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Chars (Typ), 'A')); |
| |
| Append_Freeze_Action (Typ, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Arr, |
| Constant_Present => True, |
| |
| Object_Definition => |
| Make_Constrained_Array_Definition (Loc, |
| Discrete_Subtype_Definitions => New_List ( |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (Standard_Natural, Loc), |
| Constraint => |
| Make_Range_Constraint (Loc, |
| Range_Expression => |
| Make_Range (Loc, |
| Low_Bound => |
| Make_Integer_Literal (Loc, 0), |
| High_Bound => |
| Make_Integer_Literal (Loc, Num - 1))))), |
| |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => False, |
| Subtype_Indication => New_Occurrence_Of (Typ, Loc))), |
| |
| Expression => |
| Make_Aggregate (Loc, |
| Expressions => Lst))); |
| |
| Set_Enum_Pos_To_Rep (Typ, Arr); |
| end if; |
| |
| -- Now we build the function that converts representation values to |
| -- position values. This function has the form: |
| |
| -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is |
| -- begin |
| -- case ityp!(A) is |
| -- when enum-lit'Enum_Rep => return posval; |
| -- when enum-lit'Enum_Rep => return posval; |
| -- ... |
| -- when others => |
| -- [raise Constraint_Error when F "invalid data"] |
| -- return -1; |
| -- end case; |
| -- end; |
| |
| -- Note: the F parameter determines whether the others case (no valid |
| -- representation) raises Constraint_Error or returns a unique value |
| -- of minus one. The latter case is used, e.g. in 'Valid code. |
| |
| -- Note: the reason we use Enum_Rep values in the case here is to avoid |
| -- the code generator making inappropriate assumptions about the range |
| -- of the values in the case where the value is invalid. ityp is a |
| -- signed or unsigned integer type of appropriate width. |
| |
| -- Note: if exceptions are not supported, then we suppress the raise |
| -- and return -1 unconditionally (this is an erroneous program in any |
| -- case and there is no obligation to raise Constraint_Error here). We |
| -- also do this if pragma Restrictions (No_Exceptions) is active. |
| |
| -- Is this right??? What about No_Exception_Propagation??? |
| |
| -- The underlying type is signed. Reset the Is_Unsigned_Type explicitly |
| -- because it might have been inherited from the parent type. |
| |
| if Enumeration_Rep (First_Literal (Typ)) < 0 then |
| Set_Is_Unsigned_Type (Typ, False); |
| end if; |
| |
| Ityp := Integer_Type_For (Esize (Typ), Is_Unsigned_Type (Typ)); |
| |
| -- The body of the function is a case statement. First collect case |
| -- alternatives, or optimize the contiguous case. |
| |
| Lst := New_List; |
| |
| -- If representation is contiguous, Pos is computed by subtracting |
| -- the representation of the first literal. |
| |
| if Is_Contiguous then |
| Ent := First_Literal (Typ); |
| |
| if Enumeration_Rep (Ent) = Last_Repval then |
| |
| -- Another special case: for a single literal, Pos is zero |
| |
| Pos_Expr := Make_Integer_Literal (Loc, Uint_0); |
| |
| else |
| Pos_Expr := |
| Convert_To (Standard_Integer, |
| Make_Op_Subtract (Loc, |
| Left_Opnd => |
| Unchecked_Convert_To |
| (Ityp, Make_Identifier (Loc, Name_uA)), |
| Right_Opnd => |
| Make_Integer_Literal (Loc, |
| Intval => Enumeration_Rep (First_Literal (Typ))))); |
| end if; |
| |
| Append_To (Lst, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List ( |
| Make_Range (Sloc (Enumeration_Rep_Expr (Ent)), |
| Low_Bound => |
| Make_Integer_Literal (Loc, |
| Intval => Enumeration_Rep (Ent)), |
| High_Bound => |
| Make_Integer_Literal (Loc, Intval => Last_Repval))), |
| |
| Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => Pos_Expr)))); |
| |
| else |
| Ent := First_Literal (Typ); |
| while Present (Ent) loop |
| Append_To (Lst, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List ( |
| Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)), |
| Intval => Enumeration_Rep (Ent))), |
| |
| Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Integer_Literal (Loc, |
| Intval => Enumeration_Pos (Ent)))))); |
| |
| Next_Literal (Ent); |
| end loop; |
| end if; |
| |
| -- In normal mode, add the others clause with the test. |
| -- If Predicates_Ignored is True, validity checks do not apply to |
| -- the subtype. |
| |
| if not No_Exception_Handlers_Set |
| and then not Predicates_Ignored (Typ) |
| then |
| Append_To (Lst, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List (Make_Others_Choice (Loc)), |
| Statements => New_List ( |
| Make_Raise_Constraint_Error (Loc, |
| Condition => Make_Identifier (Loc, Name_uF), |
| Reason => CE_Invalid_Data), |
| Make_Simple_Return_Statement (Loc, |
| Expression => Make_Integer_Literal (Loc, -1))))); |
| |
| -- If either of the restrictions No_Exceptions_Handlers/Propagation is |
| -- active then return -1 (we cannot usefully raise Constraint_Error in |
| -- this case). See description above for further details. |
| |
| else |
| Append_To (Lst, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List (Make_Others_Choice (Loc)), |
| Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => Make_Integer_Literal (Loc, -1))))); |
| end if; |
| |
| -- Now we can build the function body |
| |
| Fent := |
| Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos)); |
| |
| Func := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Fent, |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uA), |
| Parameter_Type => New_Occurrence_Of (Typ, Loc)), |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uF), |
| Parameter_Type => |
| New_Occurrence_Of (Standard_Boolean, Loc))), |
| |
| Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)), |
| |
| Declarations => Empty_List, |
| |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_Case_Statement (Loc, |
| Expression => |
| Unchecked_Convert_To |
| (Ityp, Make_Identifier (Loc, Name_uA)), |
| Alternatives => Lst)))); |
| |
| Set_TSS (Typ, Fent); |
| |
| -- Set Pure flag (it will be reset if the current context is not Pure). |
| -- We also pretend there was a pragma Pure_Function so that for purposes |
| -- of optimization and constant-folding, we will consider the function |
| -- Pure even if we are not in a Pure context). |
| |
| Set_Is_Pure (Fent); |
| Set_Has_Pragma_Pure_Function (Fent); |
| |
| -- Unless we are in -gnatD mode, where we are debugging generated code, |
| -- this is an internal entity for which we don't need debug info. |
| |
| if not Debug_Generated_Code then |
| Set_Debug_Info_Off (Fent); |
| end if; |
| |
| Set_Is_Inlined (Fent); |
| |
| exception |
| when RE_Not_Available => |
| return; |
| end Expand_Freeze_Enumeration_Type; |
| |
| ------------------------------- |
| -- Expand_Freeze_Record_Type -- |
| ------------------------------- |
| |
| procedure Expand_Freeze_Record_Type (N : Node_Id) is |
| |
| procedure Build_Class_Condition_Subprograms (Typ : Entity_Id); |
| -- Create internal subprograms of Typ primitives that have class-wide |
| -- preconditions or postconditions; they are invoked by the caller to |
| -- evaluate the conditions. |
| |
| procedure Build_Variant_Record_Equality (Typ : Entity_Id); |
| -- Create An Equality function for the untagged variant record Typ and |
| -- attach it to the TSS list. |
| |
| procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id); |
| -- Register dispatch-table wrappers in the dispatch table of Typ |
| |
| procedure Validate_Tagged_Type_Extra_Formals (Typ : Entity_Id); |
| -- Check extra formals of dispatching primitives of tagged type Typ. |
| -- Used in pragma Debug. |
| |
| --------------------------------------- |
| -- Build_Class_Condition_Subprograms -- |
| --------------------------------------- |
| |
| procedure Build_Class_Condition_Subprograms (Typ : Entity_Id) is |
| Prim_List : constant Elist_Id := Primitive_Operations (Typ); |
| Prim_Elmt : Elmt_Id := First_Elmt (Prim_List); |
| Prim : Entity_Id; |
| |
| begin |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| -- Primitive with class-wide preconditions |
| |
| if Comes_From_Source (Prim) |
| and then Has_Significant_Contract (Prim) |
| and then |
| (Present (Class_Preconditions (Prim)) |
| or else Present (Ignored_Class_Preconditions (Prim))) |
| then |
| if Expander_Active then |
| Make_Class_Precondition_Subps (Prim); |
| end if; |
| |
| -- Wrapper of a primitive that has or inherits class-wide |
| -- preconditions. |
| |
| elsif Is_Primitive_Wrapper (Prim) |
| and then |
| (Present (Nearest_Class_Condition_Subprogram |
| (Spec_Id => Prim, |
| Kind => Class_Precondition)) |
| or else |
| Present (Nearest_Class_Condition_Subprogram |
| (Spec_Id => Prim, |
| Kind => Ignored_Class_Precondition))) |
| then |
| if Expander_Active then |
| Make_Class_Precondition_Subps (Prim); |
| end if; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| end Build_Class_Condition_Subprograms; |
| |
| ----------------------------------- |
| -- Build_Variant_Record_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)); |
| begin |
| -- For a variant record with restriction No_Implicit_Conditionals |
| -- in effect we skip building the procedure. This is safe because |
| -- if we can see the restriction, so can any caller, and calls to |
| -- equality test routines are not allowed for variant records if |
| -- this restriction is active. |
| |
| if Restriction_Active (No_Implicit_Conditionals) then |
| return; |
| end if; |
| |
| -- Derived Unchecked_Union types no longer inherit the equality |
| -- function of their parent. |
| |
| if Is_Derived_Type (Typ) |
| and then not Is_Unchecked_Union (Typ) |
| and then not Has_New_Non_Standard_Rep (Typ) |
| then |
| declare |
| Parent_Eq : constant Entity_Id := |
| TSS (Root_Type (Typ), TSS_Composite_Equality); |
| begin |
| if Present (Parent_Eq) then |
| Copy_TSS (Parent_Eq, Typ); |
| return; |
| end if; |
| end; |
| end if; |
| |
| Discard_Node ( |
| Build_Variant_Record_Equality |
| (Typ => Typ, |
| Body_Id => F, |
| Param_Specs => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_X), |
| Parameter_Type => New_Occurrence_Of (Typ, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_Y), |
| Parameter_Type => New_Occurrence_Of (Typ, Loc))))); |
| |
| 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; |
| |
| -------------------------------------- |
| -- Register_Dispatch_Table_Wrappers -- |
| -------------------------------------- |
| |
| procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id) is |
| Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Typ)); |
| Subp : Entity_Id; |
| |
| begin |
| while Present (Elmt) loop |
| Subp := Node (Elmt); |
| |
| if Is_Dispatch_Table_Wrapper (Subp) then |
| Append_Freeze_Actions (Typ, |
| Register_Primitive (Sloc (Subp), Subp)); |
| end if; |
| |
| Next_Elmt (Elmt); |
| end loop; |
| end Register_Dispatch_Table_Wrappers; |
| |
| ---------------------------------------- |
| -- Validate_Tagged_Type_Extra_Formals -- |
| ---------------------------------------- |
| |
| procedure Validate_Tagged_Type_Extra_Formals (Typ : Entity_Id) is |
| Ovr_Subp : Entity_Id; |
| Elmt : Elmt_Id; |
| Subp : Entity_Id; |
| |
| begin |
| pragma Assert (not Is_Class_Wide_Type (Typ)); |
| |
| -- No check required if expansion is not active since we never |
| -- generate extra formals in such case. |
| |
| if not Expander_Active then |
| return; |
| end if; |
| |
| Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Elmt) loop |
| Subp := Node (Elmt); |
| |
| -- Extra formals of a dispatching primitive must match: |
| |
| -- 1) The extra formals of its covered interface primitive |
| |
| if Present (Interface_Alias (Subp)) then |
| pragma Assert |
| (Extra_Formals_Match_OK |
| (E => Interface_Alias (Subp), |
| Ref_E => Alias (Subp))); |
| end if; |
| |
| -- 2) The extra formals of its renamed primitive |
| |
| if Present (Alias (Subp)) then |
| pragma Assert |
| (Extra_Formals_Match_OK |
| (E => Subp, |
| Ref_E => Ultimate_Alias (Subp))); |
| end if; |
| |
| -- 3) The extra formals of its overridden primitive |
| |
| if Present (Overridden_Operation (Subp)) then |
| Ovr_Subp := Overridden_Operation (Subp); |
| |
| -- Handle controlling function wrapper |
| |
| if Is_Wrapper (Subp) |
| and then Ultimate_Alias (Ovr_Subp) = Subp |
| then |
| if Present (Overridden_Operation (Ovr_Subp)) then |
| pragma Assert |
| (Extra_Formals_Match_OK |
| (E => Subp, |
| Ref_E => Overridden_Operation (Ovr_Subp))); |
| end if; |
| |
| else |
| pragma Assert |
| (Extra_Formals_Match_OK |
| (E => Subp, |
| Ref_E => Ovr_Subp)); |
| end if; |
| end if; |
| |
| Next_Elmt (Elmt); |
| end loop; |
| end Validate_Tagged_Type_Extra_Formals; |
| |
| -- Local variables |
| |
| Typ : constant Node_Id := Entity (N); |
| Typ_Decl : constant Node_Id := Parent (Typ); |
| |
| Comp : Entity_Id; |
| Comp_Typ : Entity_Id; |
| Predef_List : List_Id; |
| |
| Wrapper_Decl_List : List_Id; |
| Wrapper_Body_List : List_Id := No_List; |
| |
| Renamed_Eq : Node_Id := Empty; |
| -- Defining unit name for the predefined equality function in the case |
| -- where the type has a primitive operation that is a renaming of |
| -- predefined equality (but only if there is also an overriding |
| -- user-defined equality function). Used to pass this entity from |
| -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies. |
| |
| -- Start of processing for Expand_Freeze_Record_Type |
| |
| begin |
| -- Build discriminant checking functions if not a derived type (for |
| -- derived types that are not tagged types, always use the discriminant |
| -- checking functions of the parent type). However, for untagged types |
| -- the derivation may have taken place before the parent was frozen, so |
| -- we copy explicitly the discriminant checking functions from the |
| -- parent into the components of the derived type. |
| |
| Build_Or_Copy_Discr_Checking_Funcs (Typ_Decl); |
| |
| if Is_Derived_Type (Typ) |
| and then Is_Limited_Type (Typ) |
| and then Is_Tagged_Type (Typ) |
| then |
| Check_Stream_Attributes (Typ); |
| end if; |
| |
| -- Update task, protected, and controlled component flags, because some |
| -- of the component types may have been private at the point of the |
| -- record declaration. Detect anonymous access-to-controlled components. |
| |
| Comp := First_Component (Typ); |
| while Present (Comp) loop |
| Comp_Typ := Etype (Comp); |
| |
| Propagate_Concurrent_Flags (Typ, Comp_Typ); |
| |
| -- Do not set Has_Controlled_Component on a class-wide equivalent |
| -- type. See Make_CW_Equivalent_Type. |
| |
| if not Is_Class_Wide_Equivalent_Type (Typ) |
| and then |
| (Has_Controlled_Component (Comp_Typ) |
| or else (Chars (Comp) /= Name_uParent |
| and then Is_Controlled (Comp_Typ))) |
| then |
| Set_Has_Controlled_Component (Typ); |
| end if; |
| |
| Next_Component (Comp); |
| end loop; |
| |
| -- Handle constructors of untagged CPP_Class types |
| |
| if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then |
| Set_CPP_Constructors (Typ); |
| end if; |
| |
| -- Creation of the Dispatch Table. Note that a Dispatch Table is built |
| -- for regular tagged types as well as for Ada types deriving from a C++ |
| -- Class, but not for tagged types directly corresponding to C++ classes |
| -- In the later case we assume that it is created in the C++ side and we |
| -- just use it. |
| |
| if Is_Tagged_Type (Typ) then |
| |
| -- Add the _Tag component |
| |
| if Underlying_Type (Etype (Typ)) = Typ then |
| Expand_Tagged_Root (Typ); |
| end if; |
| |
| if Is_CPP_Class (Typ) then |
| Set_All_DT_Position (Typ); |
| |
| -- Create the tag entities with a minimum decoration |
| |
| if Tagged_Type_Expansion then |
| Append_Freeze_Actions (Typ, Make_Tags (Typ)); |
| end if; |
| |
| Set_CPP_Constructors (Typ); |
| |
| else |
| if not Building_Static_DT (Typ) then |
| |
| -- Usually inherited primitives are not delayed but the first |
| -- Ada extension of a CPP_Class is an exception since the |
| -- address of the inherited subprogram has to be inserted in |
| -- the new Ada Dispatch Table and this is a freezing action. |
| |
| -- Similarly, if this is an inherited operation whose parent is |
| -- not frozen yet, it is not in the DT of the parent, and we |
| -- generate an explicit freeze node for the inherited operation |
| -- so it is properly inserted in the DT of the current type. |
| |
| declare |
| Elmt : Elmt_Id; |
| Subp : Entity_Id; |
| |
| begin |
| Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Elmt) loop |
| Subp := Node (Elmt); |
| |
| if Present (Alias (Subp)) then |
| if Is_CPP_Class (Etype (Typ)) then |
| Set_Has_Delayed_Freeze (Subp); |
| |
| elsif Has_Delayed_Freeze (Alias (Subp)) |
| and then not Is_Frozen (Alias (Subp)) |
| then |
| Set_Is_Frozen (Subp, False); |
| Set_Has_Delayed_Freeze (Subp); |
| end if; |
| end if; |
| |
| Next_Elmt (Elmt); |
| end loop; |
| end; |
| end if; |
| |
| -- Unfreeze momentarily the type to add the predefined primitives |
| -- operations. The reason we unfreeze is so that these predefined |
| -- operations will indeed end up as primitive operations (which |
| -- must be before the freeze point). |
| |
| Set_Is_Frozen (Typ, False); |
| |
| -- Do not add the spec of predefined primitives in case of |
| -- CPP tagged type derivations that have convention CPP. |
| |
| if Is_CPP_Class (Root_Type (Typ)) |
| and then Convention (Typ) = Convention_CPP |
| then |
| null; |
| |
| -- Do not add the spec of the predefined primitives if we are |
| -- compiling under restriction No_Dispatching_Calls. |
| |
| elsif not Restriction_Active (No_Dispatching_Calls) then |
| Make_Predefined_Primitive_Specs (Typ, Predef_List, Renamed_Eq); |
| Insert_List_Before_And_Analyze (N, Predef_List); |
| end if; |
| |
| -- Ada 2005 (AI-391): For a nonabstract null extension, create |
| -- wrapper functions for each nonoverridden inherited function |
| -- with a controlling result of the type. The wrapper for such |
| -- a function returns an extension aggregate that invokes the |
| -- parent function. |
| |
| if Ada_Version >= Ada_2005 |
| and then not Is_Abstract_Type (Typ) |
| and then Is_Null_Extension (Typ) |
| then |
| Make_Controlling_Function_Wrappers |
| (Typ, Wrapper_Decl_List, Wrapper_Body_List); |
| Insert_List_Before_And_Analyze (N, Wrapper_Decl_List); |
| end if; |
| |
| -- Ada 2005 (AI-251): For a nonabstract type extension, build |
| -- null procedure declarations for each set of homographic null |
| -- procedures that are inherited from interface types but not |
| -- overridden. This is done to ensure that the dispatch table |
| -- entry associated with such null primitives are properly filled. |
| |
| if Ada_Version >= Ada_2005 |
| and then Etype (Typ) /= Typ |
| and then not Is_Abstract_Type (Typ) |
| and then Has_Interfaces (Typ) |
| then |
| Insert_Actions (N, Make_Null_Procedure_Specs (Typ)); |
| end if; |
| |
| Set_Is_Frozen (Typ); |
| |
| if not Is_Derived_Type (Typ) |
| or else Is_Tagged_Type (Etype (Typ)) |
| then |
| Set_All_DT_Position (Typ); |
| |
| -- If this is a type derived from an untagged private type whose |
| -- full view is tagged, the type is marked tagged for layout |
| -- reasons, but it has no dispatch table. |
| |
| elsif Is_Derived_Type (Typ) |
| and then Is_Private_Type (Etype (Typ)) |
| and then not Is_Tagged_Type (Etype (Typ)) |
| then |
| return; |
| end if; |
| |
| -- Create and decorate the tags. Suppress their creation when |
| -- not Tagged_Type_Expansion because the dispatching mechanism is |
| -- handled internally by the virtual target. |
| |
| if Tagged_Type_Expansion then |
| Append_Freeze_Actions (Typ, Make_Tags (Typ)); |
| |
| -- Generate dispatch table of locally defined tagged type. |
| -- Dispatch tables of library level tagged types are built |
| -- later (see Build_Static_Dispatch_Tables). |
| |
| if not Building_Static_DT (Typ) then |
| Append_Freeze_Actions (Typ, Make_DT (Typ)); |
| |
| -- Register dispatch table wrappers in the dispatch table. |
| -- It could not be done when these wrappers were built |
| -- because, at that stage, the dispatch table was not |
| -- available. |
| |
| Register_Dispatch_Table_Wrappers (Typ); |
| end if; |
| end if; |
| |
| -- If the type has unknown discriminants, propagate dispatching |
| -- information to its underlying record view, which does not get |
| -- its own dispatch table. |
| |
| if Is_Derived_Type (Typ) |
| and then Has_Unknown_Discriminants (Typ) |
| and then Present (Underlying_Record_View (Typ)) |
| then |
| declare |
| Rep : constant Entity_Id := Underlying_Record_View (Typ); |
| begin |
| Set_Access_Disp_Table |
| (Rep, Access_Disp_Table (Typ)); |
| Set_Dispatch_Table_Wrappers |
| (Rep, Dispatch_Table_Wrappers (Typ)); |
| Set_Direct_Primitive_Operations |
| (Rep, Direct_Primitive_Operations (Typ)); |
| end; |
| end if; |
| |
| -- Make sure that the primitives Initialize, Adjust and Finalize |
| -- are Frozen before other TSS subprograms. We don't want them |
| -- Frozen inside. |
| |
| if Is_Controlled (Typ) then |
| if not Is_Limited_Type (Typ) then |
| Append_Freeze_Actions (Typ, |
| Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ)); |
| end if; |
| |
| Append_Freeze_Actions (Typ, |
| Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ)); |
| |
| Append_Freeze_Actions (Typ, |
| Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ)); |
| end if; |
| |
| -- Freeze rest of primitive operations. There is no need to handle |
| -- the predefined primitives if we are compiling under restriction |
| -- No_Dispatching_Calls. |
| |
| if not Restriction_Active (No_Dispatching_Calls) then |
| Append_Freeze_Actions (Typ, Predefined_Primitive_Freeze (Typ)); |
| end if; |
| end if; |
| |
| -- In the untagged case, ever since Ada 83 an equality function must |
| -- be provided for variant records that are not unchecked unions. |
| -- In Ada 2012 the equality function composes, and thus must be built |
| -- explicitly just as for tagged records. |
| |
| elsif Has_Discriminants (Typ) |
| and then not Is_Limited_Type (Typ) |
| then |
| declare |
| Comps : constant Node_Id := |
| Component_List (Type_Definition (Typ_Decl)); |
| begin |
| if Present (Comps) |
| and then Present (Variant_Part (Comps)) |
| then |
| Build_Variant_Record_Equality (Typ); |
| end if; |
| end; |
| |
| -- Otherwise create primitive equality operation (AI05-0123) |
| |
| -- This is done unconditionally to ensure that tools can be linked |
| -- properly with user programs compiled with older language versions. |
| -- In addition, this is needed because "=" composes for bounded strings |
| -- in all language versions (see Exp_Ch4.Expand_Composite_Equality). |
| |
| elsif Comes_From_Source (Typ) |
| and then Convention (Typ) = Convention_Ada |
| and then not Is_Limited_Type (Typ) |
| then |
| Build_Untagged_Equality (Typ); |
| end if; |
| |
| -- Before building the record initialization procedure, if we are |
| -- dealing with a concurrent record value type, then we must go through |
| -- the discriminants, exchanging discriminals between the concurrent |
| -- type and the concurrent record value type. See the section "Handling |
| -- of Discriminants" in the Einfo spec for details. |
| |
| if Is_Concurrent_Record_Type (Typ) |
| and then Has_Discriminants (Typ) |
| then |
| declare |
| Ctyp : constant Entity_Id := |
| Corresponding_Concurrent_Type (Typ); |
| Conc_Discr : Entity_Id; |
| Rec_Discr : Entity_Id; |
| Temp : Entity_Id; |
| |
| begin |
| Conc_Discr := First_Discriminant (Ctyp); |
| Rec_Discr := First_Discriminant (Typ); |
| while Present (Conc_Discr) loop |
| Temp := Discriminal (Conc_Discr); |
| Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); |
| Set_Discriminal (Rec_Discr, Temp); |
| |
| Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); |
| Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); |
| |
| Next_Discriminant (Conc_Discr); |
| Next_Discriminant (Rec_Discr); |
| end loop; |
| end; |
| end if; |
| |
| if Has_Controlled_Component (Typ) then |
| Build_Controlling_Procs (Typ); |
| end if; |
| |
| Adjust_Discriminants (Typ); |
| |
| -- Do not need init for interfaces on virtual targets since they're |
| -- abstract. |
| |
| if Tagged_Type_Expansion or else not Is_Interface (Typ) then |
| Build_Record_Init_Proc (Typ_Decl, Typ); |
| end if; |
| |
| -- For tagged type that are not interfaces, build bodies of primitive |
| -- operations. Note: do this after building the record initialization |
| -- procedure, since the primitive operations may need the initialization |
| -- routine. There is no need to add predefined primitives of interfaces |
| -- because all their predefined primitives are abstract. |
| |
| if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then |
| |
| -- Do not add the body of predefined primitives in case of CPP tagged |
| -- type derivations that have convention CPP. |
| |
| if Is_CPP_Class (Root_Type (Typ)) |
| and then Convention (Typ) = Convention_CPP |
| then |
| null; |
| |
| -- Do not add the body of the predefined primitives if we are |
| -- compiling under restriction No_Dispatching_Calls or if we are |
| -- compiling a CPP tagged type. |
| |
| elsif not Restriction_Active (No_Dispatching_Calls) then |
| |
| -- Create the body of TSS primitive Finalize_Address. This must |
| -- be done before the bodies of all predefined primitives are |
| -- created. If Typ is limited, Stream_Input and Stream_Read may |
| -- produce build-in-place allocations and for those the expander |
| -- needs Finalize_Address. |
| |
| Make_Finalize_Address_Body (Typ); |
| Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq); |
| Append_Freeze_Actions (Typ, Predef_List); |
| end if; |
| |
| -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden |
| -- inherited functions, then add their bodies to the freeze actions. |
| |
| Append_Freeze_Actions (Typ, Wrapper_Body_List); |
| end if; |
| |
| -- Create extra formals for the primitive operations of the type. |
| -- This must be done before analyzing the body of the initialization |
| -- procedure, because a self-referential type might call one of these |
| -- primitives in the body of the init_proc itself. |
| -- |
| -- This is not needed: |
| -- 1) If expansion is disabled, because extra formals are only added |
| -- when we are generating code. |
| -- |
| -- 2) For types with foreign convention since primitives with foreign |
| -- convention don't have extra formals and AI95-117 requires that |
| -- all primitives of a tagged type inherit the convention. |
| |
| if Expander_Active |
| and then Is_Tagged_Type (Typ) |
| and then not Has_Foreign_Convention (Typ) |
| then |
| declare |
| Elmt : Elmt_Id; |
| E : Entity_Id; |
| |
| begin |
| -- Add extra formals to primitive operations |
| |
| Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Elmt) loop |
| Create_Extra_Formals (Node (Elmt)); |
| Next_Elmt (Elmt); |
| end loop; |
| |
| -- Add extra formals to renamings of primitive operations. The |
| -- addition of extra formals is done in two steps to minimize |
| -- the compile time required for this action; the evaluation of |
| -- Find_Dispatching_Type() and Contains() is only done here for |
| -- renamings that are not primitive operations. |
| |
| E := First_Entity (Scope (Typ)); |
| while Present (E) loop |
| if Is_Dispatching_Operation (E) |
| and then Present (Alias (E)) |
| and then Find_Dispatching_Type (E) = Typ |
| and then not Contains (Primitive_Operations (Typ), E) |
| then |
| Create_Extra_Formals (E); |
| end if; |
| |
| Next_Entity (E); |
| end loop; |
| |
| pragma Debug (Validate_Tagged_Type_Extra_Formals (Typ)); |
| end; |
| end if; |
| |
| -- Build internal subprograms of primitives with class-wide |
| -- pre/postconditions. |
| |
| if Is_Tagged_Type (Typ) then |
| Build_Class_Condition_Subprograms (Typ); |
| end if; |
| end Expand_Freeze_Record_Type; |
| |
| ------------------------------------ |
| -- Expand_N_Full_Type_Declaration -- |
| ------------------------------------ |
| |
| procedure Expand_N_Full_Type_Declaration (N : Node_Id) is |
| procedure Build_Master (Ptr_Typ : Entity_Id); |
| -- Create the master associated with Ptr_Typ |
| |
| ------------------ |
| -- Build_Master -- |
| ------------------ |
| |
| procedure Build_Master (Ptr_Typ : Entity_Id) is |
| Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ); |
| |
| begin |
| -- If the designated type is an incomplete view coming from a |
| -- limited-with'ed package, we need to use the nonlimited view in |
| -- case it has tasks. |
| |
| if Is_Incomplete_Type (Desig_Typ) |
| and then Present (Non_Limited_View (Desig_Typ)) |
| then |
| Desig_Typ := Non_Limited_View (Desig_Typ); |
| end if; |
| |
| -- Anonymous access types are created for the components of the |
| -- record parameter for an entry declaration. No master is created |
| -- for such a type. |
| |
| if Has_Task (Desig_Typ) then |
| Build_Master_Entity (Ptr_Typ); |
| Build_Master_Renaming (Ptr_Typ); |
| |
| -- Create a class-wide master because a Master_Id must be generated |
| -- for access-to-limited-class-wide types whose root may be extended |
| -- with task components. |
| |
| -- Note: This code covers access-to-limited-interfaces because they |
| -- can be used to reference tasks implementing them. |
| |
| -- Suppress the master creation for access types created for entry |
| -- formal parameters (parameter block component types). Seems like |
| -- suppression should be more general for compiler-generated types, |
| -- but testing Comes_From_Source may be too general in this case |
| -- (affects some test output)??? |
| |
| elsif not Is_Param_Block_Component_Type (Ptr_Typ) |
| and then Is_Limited_Class_Wide_Type (Desig_Typ) |
| then |
| Build_Class_Wide_Master (Ptr_Typ); |
| end if; |
| end Build_Master; |
| |
| -- Local declarations |
| |
| Def_Id : constant Entity_Id := Defining_Identifier (N); |
| B_Id : constant Entity_Id := Base_Type (Def_Id); |
| FN : Node_Id; |
| Par_Id : Entity_Id; |
| |
| -- Start of processing for Expand_N_Full_Type_Declaration |
| |
| begin |
| if Is_Access_Type (Def_Id) then |
| Build_Master (Def_Id); |
| |
| if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then |
| Expand_Access_Protected_Subprogram_Type (N); |
| end if; |
| |
| -- Array of anonymous access-to-task pointers |
| |
| elsif Ada_Version >= Ada_2005 |
| and then Is_Array_Type (Def_Id) |
| and then Is_Access_Type (Component_Type (Def_Id)) |
| and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type |
| then |
| Build_Master (Component_Type (Def_Id)); |
| |
| elsif Has_Task (Def_Id) then |
| Expand_Previous_Access_Type (Def_Id); |
| |
| -- Check the components of a record type or array of records for |
| -- anonymous access-to-task pointers. |
| |
| elsif Ada_Version >= Ada_2005 |
| and then (Is_Record_Type (Def_Id) |
| or else |
| (Is_Array_Type (Def_Id) |
| and then Is_Record_Type (Component_Type (Def_Id)))) |
| then |
| declare |
| Comp : Entity_Id; |
| First : Boolean; |
| M_Id : Entity_Id := Empty; |
| Typ : Entity_Id; |
| |
| begin |
| if Is_Array_Type (Def_Id) then |
| Comp := First_Entity (Component_Type (Def_Id)); |
| else |
| Comp := First_Entity (Def_Id); |
| end if; |
| |
| -- Examine all components looking for anonymous access-to-task |
| -- types. |
| |
| First := True; |
| while Present (Comp) loop |
| Typ := Etype (Comp); |
| |
| if Ekind (Typ) = E_Anonymous_Access_Type |
| and then Might_Have_Tasks |
| (Available_View (Designated_Type (Typ))) |
| and then No (Master_Id (Typ)) |
| then |
| -- Ensure that the record or array type have a _master |
| |
| if First then |
| Build_Master_Entity (Def_Id); |
| Build_Master_Renaming (Typ); |
| M_Id := Master_Id (Typ); |
| |
| First := False; |
| |
| -- Reuse the same master to service any additional types |
| |
| else |
| pragma Assert (Present (M_Id)); |
| Set_Master_Id (Typ, M_Id); |
| end if; |
| end if; |
| |
| Next_Entity (Comp); |
| end loop; |
| end; |
| end if; |
| |
| Par_Id := Etype (B_Id); |
| |
| -- The parent type is private then we need to inherit any TSS operations |
| -- from the full view. |
| |
| if Is_Private_Type (Par_Id) |
| and then Present (Full_View (Par_Id)) |
| then |
| Par_Id := Base_Type (Full_View (Par_Id)); |
| end if; |
| |
| if Nkind (Type_Definition (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 Is_Private_Type (B_Id) |
| and then Present (Full_View (B_Id)) |
| then |
| Ensure_Freeze_Node (Base_Type (Full_View (B_Id))); |
| Set_TSS_Elist |
| (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN)); |
| end if; |
| end; |
| end if; |
| end Expand_N_Full_Type_Declaration; |
| |
| --------------------------------- |
| -- Expand_N_Object_Declaration -- |
| --------------------------------- |
| |
| procedure Expand_N_Object_Declaration (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Def_Id : constant Entity_Id := Defining_Identifier (N); |
| Expr : constant Node_Id := Expression (N); |
| Obj_Def : constant Node_Id := Object_Definition (N); |
| Typ : constant Entity_Id := Etype (Def_Id); |
| Base_Typ : constant Entity_Id := Base_Type (Typ); |
| Next_N : constant Node_Id := Next (N); |
| |
| function Build_Equivalent_Aggregate return Boolean; |
| -- If the object has a constrained discriminated type and no initial |
| -- value, it may be possible to build an equivalent aggregate instead, |
| -- and prevent an actual call to the initialization procedure. |
| |
| function Build_Heap_Or_Pool_Allocator |
| (Temp_Id : Entity_Id; |
| Temp_Typ : Entity_Id; |
| Func_Id : Entity_Id; |
| Ret_Typ : Entity_Id; |
| Alloc_Expr : Node_Id) return Node_Id; |
| -- Create the statements necessary to allocate a return object on the |
| -- heap or user-defined storage pool. The object may need finalization |
| -- actions depending on the return type. |
| -- |
| -- * Controlled case |
| -- |
| -- if BIPfinalizationmaster = null then |
| -- Temp_Id := <Alloc_Expr>; |
| -- else |
| -- declare |
| -- type Ptr_Typ is access Ret_Typ; |
| -- for Ptr_Typ'Storage_Pool use |
| -- Base_Pool (BIPfinalizationmaster.all).all; |
| -- Local : Ptr_Typ; |
| -- |
| -- begin |
| -- procedure Allocate (...) is |
| -- begin |
| -- System.Storage_Pools.Subpools.Allocate_Any (...); |
| -- end Allocate; |
| -- |
| -- Local := <Alloc_Expr>; |
| -- Temp_Id := Temp_Typ (Local); |
| -- end; |
| -- end if; |
| -- |
| -- * Non-controlled case |
| -- |
| -- Temp_Id := <Alloc_Expr>; |
| -- |
| -- Temp_Id is the temporary which is used to reference the internally |
| -- created object in all allocation forms. Temp_Typ is the type of the |
| -- temporary. Func_Id is the enclosing function. Ret_Typ is the return |
| -- type of Func_Id. Alloc_Expr is the actual allocator. |
| |
| procedure Count_Default_Sized_Task_Stacks |
| (Typ : Entity_Id; |
| Pri_Stacks : out Int; |
| Sec_Stacks : out Int); |
| -- Count the number of default-sized primary and secondary task stacks |
| -- required for task objects contained within type Typ. If the number of |
| -- task objects contained within the type is not known at compile time |
| -- the procedure will return the stack counts of zero. |
| |
| procedure Default_Initialize_Object (After : Node_Id); |
| -- Generate all default initialization actions for object Def_Id. Any |
| -- new code is inserted after node After. |
| |
| function OK_To_Rename_Ref (N : Node_Id) return Boolean; |
| -- Return True if N denotes an entity with OK_To_Rename set |
| |
| -------------------------------- |
| -- Build_Equivalent_Aggregate -- |
| -------------------------------- |
| |
| function Build_Equivalent_Aggregate return Boolean is |
| Aggr : Node_Id; |
| Comp : Entity_Id; |
| Discr : Elmt_Id; |
| Full_Type : Entity_Id; |
| |
| begin |
| Full_Type := Typ; |
| |
| if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then |
| Full_Type := Full_View (Typ); |
| end if; |
| |
| -- Only perform this transformation if Elaboration_Code is forbidden |
| -- or undesirable, and if this is a global entity of a constrained |
| -- record type. |
| |
| -- If Initialize_Scalars might be active this transformation cannot |
| -- be performed either, because it will lead to different semantics |
| -- or because elaboration code will in fact be created. |
| |
| if Ekind (Full_Type) /= E_Record_Subtype |
| or else not Has_Discriminants (Full_Type) |
| or else not Is_Constrained (Full_Type) |
| or else Is_Controlled (Full_Type) |
| or else Is_Limited_Type (Full_Type) |
| or else not Restriction_Active (No_Initialize_Scalars) |
| then |
| return False; |
| end if; |
| |
| if Ekind (Current_Scope) = E_Package |
| and then |
| (Restriction_Active (No_Elaboration_Code) |
| or else Is_Preelaborated (Current_Scope)) |
| then |
| -- Building a static aggregate is possible if the discriminants |
| -- have static values and the other components have static |
| -- defaults or none. |
| |
| Discr := First_Elmt (Discriminant_Constraint (Full_Type)); |
| while Present (Discr) loop |
| if not Is_OK_Static_Expression (Node (Discr)) then |
| return False; |
| end if; |
| |
| Next_Elmt (Discr); |
| end loop; |
| |
| -- Check that initialized components are OK, and that non- |
| -- initialized components do not require a call to their own |
| -- initialization procedure. |
| |
| Comp := First_Component (Full_Type); |
| while Present (Comp) loop |
| if Present (Expression (Parent (Comp))) |
| and then |
| not Is_OK_Static_Expression (Expression (Parent (Comp))) |
| then |
| return False; |
| |
| elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then |
| return False; |
| |
| end if; |
| |
| Next_Component (Comp); |
| end loop; |
| |
| -- Everything is static, assemble the aggregate, discriminant |
| -- values first. |
| |
| Aggr := |
| Make_Aggregate (Loc, |
| Expressions => New_List, |
| Component_Associations => New_List); |
| |
| Discr := First_Elmt (Discriminant_Constraint (Full_Type)); |
| while Present (Discr) loop |
| Append_To (Expressions (Aggr), New_Copy (Node (Discr))); |
| Next_Elmt (Discr); |
| end loop; |
| |
| -- Now collect values of initialized components |
| |
| Comp := First_Component (Full_Type); |
| while Present (Comp) loop |
| if Present (Expression (Parent (Comp))) then |
| Append_To (Component_Associations (Aggr), |
| Make_Component_Association (Loc, |
| Choices => New_List (New_Occurrence_Of (Comp, Loc)), |
| Expression => New_Copy_Tree |
| (Expression (Parent (Comp))))); |
| end if; |
| |
| Next_Component (Comp); |
| end loop; |
| |
| -- Finally, box-initialize remaining components |
| |
| Append_To (Component_Associations (Aggr), |
| Make_Component_Association (Loc, |
| Choices => New_List (Make_Others_Choice (Loc)), |
| Expression => Empty)); |
| Set_Box_Present (Last (Component_Associations (Aggr))); |
| Set_Expression (N, Aggr); |
| |
| if Typ /= Full_Type then |
| Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type))); |
| Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr)); |
| Analyze_And_Resolve (Aggr, Typ); |
| else |
| Analyze_And_Resolve (Aggr, Full_Type); |
| end if; |
| |
| return True; |
| |
| else |
| return False; |
| end if; |
| end Build_Equivalent_Aggregate; |
| |
| ---------------------------------- |
| -- Build_Heap_Or_Pool_Allocator -- |
| ---------------------------------- |
| |
| function Build_Heap_Or_Pool_Allocator |
| (Temp_Id : Entity_Id; |
| Temp_Typ : Entity_Id; |
| Func_Id : Entity_Id; |
| Ret_Typ : Entity_Id; |
| Alloc_Expr : Node_Id) return Node_Id |
| is |
| begin |
| pragma Assert (Is_Build_In_Place_Function (Func_Id)); |
| |
| -- Processing for objects that require finalization actions |
| |
| if Needs_Finalization (Ret_Typ) then |
| declare |
| Decls : constant List_Id := New_List; |
| Fin_Mas_Id : constant Entity_Id := |
| Build_In_Place_Formal (Func_Id, BIP_Finalization_Master); |
| Orig_Expr : constant Node_Id := New_Copy_Tree (Alloc_Expr); |
| Stmts : constant List_Id := New_List; |
| Local_Id : Entity_Id; |
| Pool_Id : Entity_Id; |
| Ptr_Typ : Entity_Id; |
| |
| begin |
| -- Generate: |
| -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all; |
| |
| Pool_Id := Make_Temporary (Loc, 'P'); |
| |
| Append_To (Decls, |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => Pool_Id, |
| Subtype_Mark => |
| New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc), |
| Name => |
| Make_Explicit_Dereference (Loc, |
| Prefix => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Base_Pool), Loc), |
| Parameter_Associations => New_List ( |
| Make_Explicit_Dereference (Loc, |
| Prefix => |
| New_Occurrence_Of (Fin_Mas_Id, Loc))))))); |
| |
| -- Create an access type which uses the storage pool of the |
| -- caller's master. This additional type is necessary because |
| -- the finalization master cannot be associated with the type |
| -- of the temporary. Otherwise the secondary stack allocation |
| -- will fail. |
| |
| -- Generate: |
| -- type Ptr_Typ is access Ret_Typ; |
| |
| Ptr_Typ := Make_Temporary (Loc, 'P'); |
| |
| Append_To (Decls, |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => Ptr_Typ, |
| Type_Definition => |
| Make_Access_To_Object_Definition (Loc, |
| Subtype_Indication => |
| New_Occurrence_Of (Ret_Typ, Loc)))); |
| |
| -- Perform minor decoration in order to set the master and the |
| -- storage pool attributes. |
| |
| Mutate_Ekind (Ptr_Typ, E_Access_Type); |
| Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); |
| Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); |
| |
| -- Create the temporary, generate: |
| -- Local_Id : Ptr_Typ; |
| |
| Local_Id := Make_Temporary (Loc, 'T'); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Local_Id, |
| Object_Definition => |
| New_Occurrence_Of (Ptr_Typ, Loc))); |
| |
| -- Allocate the object, generate: |
| -- Local_Id := <Alloc_Expr>; |
| |
| Append_To (Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Local_Id, Loc), |
| Expression => Alloc_Expr)); |
| |
| -- Generate: |
| -- Temp_Id := Temp_Typ (Local_Id); |
| |
| Append_To (Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Temp_Id, Loc), |
| Expression => |
| Unchecked_Convert_To (Temp_Typ, |
| New_Occurrence_Of (Local_Id, Loc)))); |
| |
| -- Wrap the allocation in a block. This is further conditioned |
| -- by checking the caller finalization master at runtime. A |
| -- null value indicates a non-existent master, most likely due |
| -- to a Finalize_Storage_Only allocation. |
| |
| -- Generate: |
| -- if BIPfinalizationmaster = null then |
| -- Temp_Id := <Orig_Expr>; |
| -- else |
| -- declare |
| -- <Decls> |
| -- begin |
| -- <Stmts> |
| -- end; |
| -- end if; |
| |
| return |
| Make_If_Statement (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc), |
| Right_Opnd => Make_Null (Loc)), |
| |
| Then_Statements => New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Temp_Id, Loc), |
| Expression => Orig_Expr)), |
| |
| Else_Statements => New_List ( |
| Make_Block_Statement (Loc, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stmts)))); |
| end; |
| |
| -- For all other cases, generate: |
| -- Temp_Id := <Alloc_Expr>; |
| |
| else |
| return |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Temp_Id, Loc), |
| Expression => Alloc_Expr); |
| end if; |
| end Build_Heap_Or_Pool_Allocator; |
| |
| ------------------------------------- |
| -- Count_Default_Sized_Task_Stacks -- |
| ------------------------------------- |
| |
| procedure Count_Default_Sized_Task_Stacks |
| (Typ : Entity_Id; |
| Pri_Stacks : out Int; |
| Sec_Stacks : out Int) |
| is |
| Component : Entity_Id; |
| |
| begin |
| -- To calculate the number of default-sized task stacks required for |
| -- an object of Typ, a depth-first recursive traversal of the AST |
| -- from the Typ entity node is undertaken. Only type nodes containing |
| -- task objects are visited. |
| |
| Pri_Stacks := 0; |
| Sec_Stacks := 0; |
| |
| if not Has_Task (Typ) then |
| return; |
| end if; |
| |
| case Ekind (Typ) is |
| when E_Task_Subtype |
| | E_Task_Type |
| => |
| -- A task type is found marking the bottom of the descent. If |
| -- the type has no representation aspect for the corresponding |
| -- stack then that stack is using the default size. |
| |
| if Present (Get_Rep_Item (Typ, Name_Storage_Size)) then |
| Pri_Stacks := 0; |
| else |
| Pri_Stacks := 1; |
| end if; |
| |
| if Present (Get_Rep_Item (Typ, Name_Secondary_Stack_Size)) then |
| Sec_Stacks := 0; |
| else |
| Sec_Stacks := 1; |
| end if; |
| |
| when E_Array_Subtype |
| | E_Array_Type |
| => |
| -- First find the number of default stacks contained within an |
| -- array component. |
| |
| Count_Default_Sized_Task_Stacks |
| (Component_Type (Typ), |
| Pri_Stacks, |
| Sec_Stacks); |
| |
| -- Then multiply the result by the size of the array |
| |
| declare |
| Quantity : constant Int := Number_Of_Elements_In_Array (Typ); |
| -- Number_Of_Elements_In_Array is non-trival, consequently |
| -- its result is captured as an optimization. |
| |
| begin |
| Pri_Stacks := Pri_Stacks * Quantity; |
| Sec_Stacks := Sec_Stacks * Quantity; |
| end; |
| |
| when E_Protected_Subtype |
| | E_Protected_Type |
| | E_Record_Subtype |
| | E_Record_Type |
| => |
| Component := First_Component_Or_Discriminant (Typ); |
| |
| -- Recursively descend each component of the composite type |
| -- looking for tasks, but only if the component is marked as |
| -- having a task. |
| |
| while Present (Component) loop |
| if Has_Task (Etype (Component)) then |
| declare |
| P : Int; |
| S : Int; |
| |
| begin |
| Count_Default_Sized_Task_Stacks |
| (Etype (Component), P, S); |
| Pri_Stacks := Pri_Stacks + P; |
| Sec_Stacks := Sec_Stacks + S; |
| end; |
| end if; |
| |
| Next_Component_Or_Discriminant (Component); |
| end loop; |
| |
| when E_Limited_Private_Subtype |
| | E_Limited_Private_Type |
| | E_Record_Subtype_With_Private |
| | E_Record_Type_With_Private |
| => |
| -- Switch to the full view of the private type to continue |
| -- search. |
| |
| Count_Default_Sized_Task_Stacks |
| (Full_View (Typ), Pri_Stacks, Sec_Stacks); |
| |
| -- Other types should not contain tasks |
| |
| when others => |
| raise Program_Error; |
| end case; |
| end Count_Default_Sized_Task_Stacks; |
| |
| ------------------------------- |
| -- Default_Initialize_Object -- |
| ------------------------------- |
| |
| procedure Default_Initialize_Object (After : Node_Id) is |
| function New_Object_Reference return Node_Id; |
| -- Return a new reference to Def_Id with attributes Assignment_OK and |
| -- Must_Not_Freeze already set. |
| |
| function Simple_Initialization_OK |
| (Init_Typ : Entity_Id) return Boolean; |
| -- Determine whether object declaration N with entity Def_Id needs |
| -- simple initialization, assuming that it is of type Init_Typ. |
| |
| -------------------------- |
| -- New_Object_Reference -- |
| -------------------------- |
| |
| function New_Object_Reference return Node_Id is |
| Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc); |
| |
| begin |
| -- The call to the type init proc or [Deep_]Finalize must not |
| -- freeze the related object as the call is internally generated. |
| -- This way legal rep clauses that apply to the object will not be |
| -- flagged. Note that the initialization call may be removed if |
| -- pragma Import is encountered or moved to the freeze actions of |
| -- the object because of an address clause. |
| |
| Set_Assignment_OK (Obj_Ref); |
| Set_Must_Not_Freeze (Obj_Ref); |
| |
| return Obj_Ref; |
| end New_Object_Reference; |
| |
| ------------------------------ |
| -- Simple_Initialization_OK -- |
| ------------------------------ |
| |
| function Simple_Initialization_OK |
| (Init_Typ : Entity_Id) return Boolean |
| is |
| begin |
| -- Do not consider the object declaration if it comes with an |
| -- initialization expression, or is internal in which case it |
| -- will be assigned later. |
| |
| return |
| not Is_Internal (Def_Id) |
| and then not Has_Init_Expression (N) |
| and then Needs_Simple_Initialization |
| (Typ => Init_Typ, |
| Consider_IS => |
| Initialize_Scalars |
| and then No (Following_Address_Clause (N))); |
| end Simple_Initialization_OK; |
| |
| -- Local variables |
| |
| Exceptions_OK : constant Boolean := |
| not Restriction_Active (No_Exception_Propagation); |
| |
| Aggr_Init : Node_Id; |
| Comp_Init : List_Id := No_List; |
| Fin_Block : Node_Id; |
| Fin_Call : Node_Id; |
| Init_Stmts : List_Id := No_List; |
| Obj_Init : Node_Id := Empty; |
| Obj_Ref : Node_Id; |
| |
| -- Start of processing for Default_Initialize_Object |
| |
| begin |
| -- Default initialization is suppressed for objects that are already |
| -- known to be imported (i.e. whose declaration specifies the Import |
| -- aspect). Note that for objects with a pragma Import, we generate |
| -- initialization here, and then remove it downstream when processing |
| -- the pragma. It is also suppressed for variables for which a pragma |
| -- Suppress_Initialization has been explicitly given |
| |
| if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then |
| return; |
| |
| -- Nothing to do if the object being initialized is of a task type |
| -- and restriction No_Tasking is in effect, because this is a direct |
| -- violation of the restriction. |
| |
| elsif Is_Task_Type (Base_Typ) |
| and then Restriction_Active (No_Tasking) |
| then |
| return; |
| end if; |
| |
| -- The expansion performed by this routine is as follows: |
| |
| -- begin |
| -- Abort_Defer; |
| -- Type_Init_Proc (Obj); |
| |
| -- begin |
| -- [Deep_]Initialize (Obj); |
| |
| -- exception |
| -- when others => |
| -- [Deep_]Finalize (Obj, Self => False); |
| -- raise; |
| -- end; |
| -- at end |
| -- Abort_Undefer_Direct; |
| -- end; |
| |
| -- Initialize the components of the object |
| |
| if Has_Non_Null_Base_Init_Proc (Typ) |
| and then not No_Initialization (N) |
| and then not Initialization_Suppressed (Typ) |
| then |
| -- Do not initialize the components if No_Default_Initialization |
| -- applies as the actual restriction check will occur later when |
| -- the object is frozen as it is not known yet whether the object |
| -- is imported or not. |
| |
| if not Restriction_Active (No_Default_Initialization) then |
| |
| -- If the values of the components are compile-time known, use |
| -- their prebuilt aggregate form directly. |
| |
| Aggr_Init := Static_Initialization (Base_Init_Proc (Typ)); |
| |
| if Present (Aggr_Init) then |
| Set_Expression (N, |
| New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope)); |
| |
| -- If type has discriminants, try to build an equivalent |
| -- aggregate using discriminant values from the declaration. |
| -- This is a useful optimization, in particular if restriction |
| -- No_Elaboration_Code is active. |
| |
| elsif Build_Equivalent_Aggregate then |
| null; |
| |
| -- Optimize the default initialization of an array object when |
| -- pragma Initialize_Scalars or Normalize_Scalars is in effect. |
| -- Construct an in-place initialization aggregate which may be |
| -- convert into a fast memset by the backend. |
| |
| elsif Init_Or_Norm_Scalars |
| and then Is_Array_Type (Typ) |
| |
| -- The array must lack atomic components because they are |
| -- treated as non-static, and as a result the backend will |
| -- not initialize the memory in one go. |
| |
| and then not Has_Atomic_Components (Typ) |
| |
| -- The array must not be packed because the invalid values |
| -- in System.Scalar_Values are multiples of Storage_Unit. |
| |
| and then not Is_Packed (Typ) |
| |
| -- The array must have static non-empty ranges, otherwise |
| -- the backend cannot initialize the memory in one go. |
| |
| and then Has_Static_Non_Empty_Array_Bounds (Typ) |
| |
| -- The optimization is only relevant for arrays of scalar |
| -- types. |
| |
| and then Is_Scalar_Type (Component_Type (Typ)) |
| |
| -- Similar to regular array initialization using a type |
| -- init proc, predicate checks are not performed because the |
| -- initialization values are intentionally invalid, and may |
| -- violate the predicate. |
| |
| and then not Has_Predicates (Component_Type (Typ)) |
| |
| -- The component type must have a single initialization value |
| |
| and then Simple_Initialization_OK (Component_Type (Typ)) |
| then |
| Set_No_Initialization (N, False); |
| Set_Expression (N, |
| Get_Simple_Init_Val |
| (Typ => Typ, |
| N => Obj_Def, |
| Size => (if Known_Esize (Def_Id) then Esize (Def_Id) |
| else Uint_0))); |
| |
| Analyze_And_Resolve |
| (Expression (N), Typ, Suppress => All_Checks); |
| |
| -- Otherwise invoke the type init proc, generate: |
| -- Type_Init_Proc (Obj); |
| |
| else |
| Obj_Ref := New_Object_Reference; |
| |
| if Comes_From_Source (Def_Id) then |
| Initialization_Warning (Obj_Ref); |
| end if; |
| |
| Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ); |
| end if; |
| end if; |
| |
| -- Provide a default value if the object needs simple initialization |
| |
| elsif Simple_Initialization_OK (Typ) then |
| Set_No_Initialization (N, False); |
| Set_Expression (N, |
| Get_Simple_Init_Val |
| (Typ => Typ, |
| N => Obj_Def, |
| Size => |
| (if Known_Esize (Def_Id) then Esize (Def_Id) else Uint_0))); |
| |
| Analyze_And_Resolve (Expression (N), Typ); |
| end if; |
| |
| -- Initialize the object, generate: |
| -- [Deep_]Initialize (Obj); |
| |
| if Needs_Finalization (Typ) and then not No_Initialization (N) then |
| Obj_Init := |
| Make_Init_Call |
| (Obj_Ref => New_Object_Reference, |
| Typ => Typ); |
| end if; |
| |
| -- Build a special finalization block when both the object and its |
| -- controlled components are to be initialized. The block finalizes |
| -- the components if the object initialization fails. Generate: |
| |
| -- begin |
| -- <Obj_Init> |
| |
| -- exception |
| -- when others => |
| -- <Fin_Call> |
| -- raise; |
| -- end; |
| |
| if Has_Controlled_Component (Typ) |
| and then Present (Comp_Init) |
| and then Present (Obj_Init) |
| and then Exceptions_OK |
| then |
| Init_Stmts := Comp_Init; |
| |
| Fin_Call := |
| Make_Final_Call |
| (Obj_Ref => New_Object_Reference, |
| Typ => Typ, |
| Skip_Self => True); |
| |
| if Present (Fin_Call) then |
| |
| -- Do not emit warnings related to the elaboration order when a |
| -- controlled object is declared before the body of Finalize is |
| -- seen. |
| |
| if Legacy_Elaboration_Checks then |
| Set_No_Elaboration_Check (Fin_Call); |
| end if; |
| |
| Fin_Block := |
| Make_Block_Statement (Loc, |
| Declarations => No_List, |
| |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Obj_Init), |
| |
| Exception_Handlers => New_List ( |
| Make_Exception_Handler (Loc, |
| Exception_Choices => New_List ( |
| Make_Others_Choice (Loc)), |
| |
| Statements => New_List ( |
| Fin_Call, |
| Make_Raise_Statement (Loc)))))); |
| |
| -- Signal the ABE mechanism that the block carries out |
| -- initialization actions. |
| |
| Set_Is_Initialization_Block (Fin_Block); |
| |
| Append_To (Init_Stmts, Fin_Block); |
| end if; |
| |
| -- Otherwise finalization is not required, the initialization calls |
| -- are passed to the abort block building circuitry, generate: |
| |
| -- Type_Init_Proc (Obj); |
| -- [Deep_]Initialize (Obj); |
| |
| else |
| if Present (Comp_Init) then |
| Init_Stmts := Comp_Init; |
| end if; |
| |
| if Present (Obj_Init) then |
| if No (Init_Stmts) then |
| Init_Stmts := New_List; |
| end if; |
| |
| Append_To (Init_Stmts, Obj_Init); |
| end if; |
| end if; |
| |
| -- Build an abort block to protect the initialization calls |
| |
| if Abort_Allowed |
| and then Present (Comp_Init) |
| and then Present (Obj_Init) |
| then |
| -- Generate: |
| -- Abort_Defer; |
| |
| Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); |
| |
| -- When exceptions are propagated, abort deferral must take place |
| -- in the presence of initialization or finalization exceptions. |
| -- Generate: |
| |
| -- begin |
| -- Abort_Defer; |
| -- <Init_Stmts> |
| -- at end |
| -- Abort_Undefer_Direct; |
| -- end; |
| |
| if Exceptions_OK then |
| Init_Stmts := New_List ( |
| Build_Abort_Undefer_Block (Loc, |
| Stmts => Init_Stmts, |
| Context => N)); |
| |
| -- Otherwise exceptions are not propagated. Generate: |
| |
| -- Abort_Defer; |
| -- <Init_Stmts> |
| -- Abort_Undefer; |
| |
| else |
| Append_To (Init_Stmts, |
| Build_Runtime_Call (Loc, RE_Abort_Undefer)); |
| end if; |
| end if; |
| |
| -- Insert the whole initialization sequence into the tree. If the |
| -- object has a delayed freeze, as will be the case when it has |
| -- aspect specifications, the initialization sequence is part of |
| -- the freeze actions. |
| |
| if Present (Init_Stmts) then |
| if Has_Delayed_Freeze (Def_Id) then |
| Append_Freeze_Actions (Def_Id, Init_Stmts); |
| else |
| Insert_Actions_After (After, Init_Stmts); |
| end if; |
| end if; |
| end Default_Initialize_Object; |
| |
| ---------------------- |
| -- OK_To_Rename_Ref -- |
| ---------------------- |
| |
| function OK_To_Rename_Ref (N : Node_Id) return Boolean is |
| begin |
| return Is_Entity_Name (N) |
| and then Ekind (Entity (N)) = E_Variable |
| and then OK_To_Rename (Entity (N)); |
| end OK_To_Rename_Ref; |
| |
| -- Local variables |
| |
| Adj_Call : Node_Id; |
| Expr_Q : Node_Id; |
| Id_Ref : Node_Id; |
| Tag_Assign : Node_Id; |
| |
| Init_After : Node_Id := N; |
| -- Node after which the initialization actions are to be inserted. This |
| -- is normally N, except for the case of a shared passive variable, in |
| -- which case the init proc call must be inserted only after the bodies |
| -- of the shared variable procedures have been seen. |
| |
| Rewrite_As_Renaming : Boolean := False; |
| -- Whether to turn the declaration into a renaming at the end |
| |
| -- Start of processing for Expand_N_Object_Declaration |
| |
| begin |
| -- Don't do anything for deferred constants. All proper actions will be |
| -- expanded during the full declaration. |
| |
| if No (Expr) and Constant_Present (N) then |
| return; |
| end if; |
| |
| -- The type of the object cannot be abstract. This is diagnosed at the |
| -- point the object is frozen, which happens after the declaration is |
| -- fully expanded, so simply return now. |
| |
| if Is_Abstract_Type (Typ) then |
| return; |
| end if; |
| |
| -- No action needed for the internal imported dummy object added by |
| -- Make_DT to compute the offset of the components that reference |
| -- secondary dispatch tables; required to avoid never-ending loop |
| -- processing this internal object declaration. |
| |
| if Tagged_Type_Expansion |
| and then Is_Internal (Def_Id) |
| and then Is_Imported (Def_Id) |
| and then Related_Type (Def_Id) = Implementation_Base_Type (Typ) |
| then |
| return; |
| end if; |
| |
| -- Make shared memory routines for shared passive variable |
| |
| if Is_Shared_Passive (Def_Id) then |
| Init_After := Make_Shared_Var_Procs (N); |
| end if; |
| |
| -- If tasks are 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) or else Might_Have_Tasks (Typ) then |
| Build_Activation_Chain_Entity (N); |
| |
| if Has_Task (Typ) then |
| Build_Master_Entity (Def_Id); |
| |
| -- Handle objects initialized with BIP function calls |
| |
| elsif Present (Expr) then |
| Expr_Q := Unqualify (Expr); |
| |
| if Is_Build_In_Place_Function_Call (Expr_Q) |
| or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) |
| or else (Nkind (Expr_Q) = N_Reference |
| and then |
| Is_Build_In_Place_Function_Call (Prefix (Expr_Q))) |
| then |
| Build_Master_Entity (Def_Id); |
| end if; |
| end if; |
| end if; |
| |
| -- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations |
| -- restrictions are active then default-sized secondary stacks are |
| -- generated by the binder and allocated by SS_Init. To provide the |
| -- binder the number of stacks to generate, the number of default-sized |
| -- stacks required for task objects contained within the object |
| -- declaration N is calculated here as it is at this point where |
| -- unconstrained types become constrained. The result is stored in the |
| -- enclosing unit's Unit_Record. |
| |
| -- Note if N is an array object declaration that has an initialization |
| -- expression, a second object declaration for the initialization |
| -- expression is created by the compiler. To prevent double counting |
| -- of the stacks in this scenario, the stacks of the first array are |
| -- not counted. |
| |
| if Might_Have_Tasks (Typ) |
| and then not Restriction_Active (No_Secondary_Stack) |
| and then (Restriction_Active (No_Implicit_Heap_Allocations) |
| or else Restriction_Active (No_Implicit_Task_Allocations)) |
| and then not (Ekind (Typ) in E_Array_Type | E_Array_Subtype |
| and then (Has_Init_Expression (N))) |
| then |
| declare |
| PS_Count, SS_Count : Int := 0; |
| begin |
| Count_Default_Sized_Task_Stacks (Typ, PS_Count, SS_Count); |
| Increment_Primary_Stack_Count (PS_Count); |
| Increment_Sec_Stack_Count (SS_Count); |
| end; |
| end if; |
| |
| -- Default initialization required, and no expression present |
| |
| if No (Expr) then |
| Expr_Q := Expr; |
| |
| -- If we have a type with a variant part, the initialization proc |
| -- will contain implicit tests of the discriminant values, which |
| -- counts as a violation of the restriction No_Implicit_Conditionals. |
| |
| if Has_Variant_Part (Typ) then |
| declare |
| Msg : Boolean; |
| |
| begin |
| Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def); |
| |
| if Msg then |
| Error_Msg_N |
| ("\initialization of variant record tests discriminants", |
| Obj_Def); |
| return; |
| end if; |
| end; |
| end if; |
| |
| -- For the default initialization case, if we have a private type |
| -- with invariants, and invariant checks are enabled, then insert an |
| -- invariant check after the object declaration. Note that it is OK |
| -- to clobber the object with an invalid value since if the exception |
| -- is raised, then the object will go out of scope. In the case where |
| -- an array object is initialized with an aggregate, the expression |
| -- is removed. Check flag Has_Init_Expression to avoid generating a |
| -- junk invariant check and flag No_Initialization to avoid checking |
| -- an uninitialized object such as a compiler temporary used for an |
| -- aggregate. |
| |
| if Has_Invariants (Base_Typ) |
| and then Present (Invariant_Procedure (Base_Typ)) |
| and then not Has_Init_Expression (N) |
| and then not No_Initialization (N) |
| then |
| -- If entity has an address clause or aspect, make invariant |
| -- call into a freeze action for the explicit freeze node for |
| -- object. Otherwise insert invariant check after declaration. |
| |
| if Present (Following_Address_Clause (N)) |
| or else Has_Aspect (Def_Id, Aspect_Address) |
| then |
| Ensure_Freeze_Node (Def_Id); |
| Set_Has_Delayed_Freeze (Def_Id); |
| Set_Is_Frozen (Def_Id, False); |
| |
| if not Partial_View_Has_Unknown_Discr (Typ) then |
| Append_Freeze_Action (Def_Id, |
| Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); |
| end if; |
| |
| elsif not Partial_View_Has_Unknown_Discr (Typ) then |
| Insert_After (N, |
| Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); |
| end if; |
| end if; |
| |
| if not Is_Build_In_Place_Return_Object (Def_Id) then |
| Default_Initialize_Object (Init_After); |
| 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 not Has_Init_Expression (N) |
| and then Is_Library_Level_Entity (Def_Id) |
| then |
| declare |
| Prag : Node_Id; |
| begin |
| Prag := |
| Make_Linker_Section_Pragma |
| (Def_Id, Sloc (N), ".persistent.bss"); |
| Insert_After (N, Prag); |
| Analyze (Prag); |
| end; |
| end if; |
| |
| -- If access type, then we know it is null if not initialized |
| |
| if Is_Access_Type (Typ) then |
| Set_Is_Known_Null (Def_Id); |
| end if; |
| |
| -- Explicit initialization present |
| |
| else |
| -- Obtain actual expression from qualified expression |
| |
| Expr_Q := Unqualify (Expr); |
| |
| -- 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 |
| |
| -- An aggregate that must be built in place is not resolved and |
| -- expanded until the enclosing construct is expanded. This will |
| -- happen when the aggregate is limited and the declared object |
| -- has a following address clause; it happens also when generating |
| -- C code for an aggregate that has an alignment or address clause |
| -- (see Analyze_Object_Declaration). Resolution is done without |
| -- expansion because it will take place when the declaration |
| -- itself is expanded. |
| |
| if (Is_Limited_Type (Typ) or else Modify_Tree_For_C) |
| and then not Analyzed (Expr) |
| then |
| Expander_Mode_Save_And_Set (False); |
| Resolve (Expr, Typ); |
| Expander_Mode_Restore; |
| end if; |
| |
| if not Is_Build_In_Place_Return_Object (Def_Id) then |
| Convert_Aggr_In_Object_Decl (N); |
| end if; |
| |
| -- Ada 2005 (AI-318-02): If the initialization expression is a call |
| -- to a build-in-place function, then access to the declared object |
| -- must be passed to the function. Currently we limit such functions |
| -- to those with constrained limited result subtypes, but eventually |
| -- plan to expand the allowed forms of functions that are treated as |
| -- build-in-place. |
| |
| elsif Is_Build_In_Place_Function_Call (Expr_Q) then |
| Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q); |
| |
| -- The previous call expands the expression initializing the |
| -- built-in-place object into further code that will be analyzed |
| -- later. No further expansion needed here. |
| |
| return; |
| |
| -- This is the same as the previous 'elsif', except that the call has |
| -- been transformed by other expansion activities into something like |
| -- F(...)'Reference. |
| |
| elsif Nkind (Expr_Q) = N_Reference |
| and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q)) |
| and then not Is_Expanded_Build_In_Place_Call |
| (Unqual_Conv (Prefix (Expr_Q))) |
| then |
| Make_Build_In_Place_Call_In_Anonymous_Context (Prefix (Expr_Q)); |
| |
| -- The previous call expands the expression initializing the |
| -- built-in-place object into further code that will be analyzed |
| -- later. No further expansion needed here. |
| |
| return; |
| |
| -- Ada 2005 (AI-318-02): Specialization of the previous case for |
| -- expressions containing a build-in-place function call whose |
| -- returned object covers interface types, and Expr_Q has calls to |
| -- Ada.Tags.Displace to displace the pointer to the returned build- |
| -- in-place object to reference the secondary dispatch table of a |
| -- covered interface type. |
| |
| elsif Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) then |
| Make_Build_In_Place_Iface_Call_In_Object_Declaration (N, Expr_Q); |
| |
| -- The previous call expands the expression initializing the |
| -- built-in-place object into further code that will be analyzed |
| -- later. No further expansion needed here. |
| |
| return; |
| |
| -- Ada 2005 (AI-251): Rewrite the expression that initializes a |
| -- class-wide interface object to ensure that we copy the full |
| -- object, unless we are targetting a VM where interfaces are handled |
| -- by VM itself. Note that if the root type of Typ is an ancestor of |
| -- Expr's type, both types share the same dispatch table and there is |
| -- no need to displace the pointer. |
| |
| elsif Is_Interface (Typ) |
| |
| -- Avoid never-ending recursion because if Equivalent_Type is set |
| -- then we've done it already and must not do it again. |
| |
| and then not |
| (Nkind (Obj_Def) = N_Identifier |
| and then Present (Equivalent_Type (Entity (Obj_Def)))) |
| then |
| pragma Assert (Is_Class_Wide_Type (Typ)); |
| |
| -- If the object is a built-in-place return object, bypass special |
| -- treatment of class-wide interface initialization below. In this |
| -- case, the expansion of the return statement will take care of |
| -- creating the object (via allocator) and initializing it. |
| |
| if Is_Build_In_Place_Return_Object (Def_Id) then |
| null; |
| |
| elsif Tagged_Type_Expansion then |
| declare |
| Iface : constant Entity_Id := Root_Type (Typ); |
| Expr_N : Node_Id := Expr; |
| Expr_Typ : Entity_Id; |
| New_Expr : Node_Id; |
| Obj_Id : Entity_Id; |
| Tag_Comp : Node_Id; |
| |
| begin |
| -- If the original node of the expression was a conversion |
| -- to this specific class-wide interface type then restore |
| -- the original node because we must copy the object before |
| -- displacing the pointer to reference the secondary tag |
| -- component. This code must be kept synchronized with the |
| -- expansion done by routine Expand_Interface_Conversion |
| |
| if not Comes_From_Source (Expr_N) |
| and then Nkind (Expr_N) = N_Explicit_Dereference |
| and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion |
| and then Etype (Original_Node (Expr_N)) = Typ |
| then |
| Rewrite (Expr_N, Original_Node (Expression (N))); |
| end if; |
| |
| -- Avoid expansion of redundant interface conversion |
| |
| if Is_Interface (Etype (Expr_N)) |
| and then Nkind (Expr_N) = N_Type_Conversion |
| and then Etype (Expr_N) = Typ |
| then |
| Expr_N := Expression (Expr_N); |
| Set_Expression (N, Expr_N); |
| end if; |
| |
| Obj_Id := Make_Temporary (Loc, 'D', Expr_N); |
| Expr_Typ := Base_Type (Etype (Expr_N)); |
| |
| if Is_Class_Wide_Type (Expr_Typ) then |
| Expr_Typ := Root_Type (Expr_Typ); |
| end if; |
| |
| -- Replace |
| -- CW : I'Class := Obj; |
| -- by |
| -- Tmp : T := Obj; |
| -- type Ityp is not null access I'Class; |
| -- CW : I'Class renames Ityp (Tmp.I_Tag'Address).all; |
| |
| if Comes_From_Source (Expr_N) |
| and then Nkind (Expr_N) = N_Identifier |
| and then not Is_Interface (Expr_Typ) |
| and then Interface_Present_In_Ancestor (Expr_Typ, Typ) |
| and then (Expr_Typ = Etype (Expr_Typ) |
| or else not |
| Is_Variable_Size_Record (Etype (Expr_Typ))) |
| then |
| -- Copy the object |
| |
| Insert_Action (N, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Obj_Id, |
| Object_Definition => |
| New_Occurrence_Of (Expr_Typ, Loc), |
| Expression => Relocate_Node (Expr_N))); |
| |
| -- Statically reference the tag associated with the |
| -- interface |
| |
| Tag_Comp := |
| Make_Selected_Component (Loc, |
| Prefix => New_Occurrence_Of (Obj_Id, Loc), |
| Selector_Name => |
| New_Occurrence_Of |
| (Find_Interface_Tag (Expr_Typ, Iface), Loc)); |
| |
| -- Replace |
| -- IW : I'Class := Obj; |
| -- by |
| -- type Equiv_Record is record ... end record; |
| -- implicit subtype CW is <Class_Wide_Subtype>; |
| -- Tmp : CW := CW!(Obj); |
| -- type Ityp is not null access I'Class; |
| -- IW : I'Class renames |
| -- Ityp!(Displace (Temp'Address, I'Tag)).all; |
| |
| else |
| -- Generate the equivalent record type and update the |
| -- subtype indication to reference it. |
| |
| Expand_Subtype_From_Expr |
| (N => N, |
| Unc_Type => Typ, |
| Subtype_Indic => Obj_Def, |
| Exp => Expr_N); |
| |
| if not Is_Interface (Etype (Expr_N)) then |
| New_Expr := Relocate_Node (Expr_N); |
| |
| -- For interface types we use 'Address which displaces |
| -- the pointer to the base of the object (if required) |
| |
| else |
| New_Expr := |
| Unchecked_Convert_To (Etype (Obj_Def), |
| Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To (RTE (RE_Tag_Ptr), |
| Make_Attribute_Reference (Loc, |
| Prefix => Relocate_Node (Expr_N), |
| Attribute_Name => Name_Address)))); |
| end if; |
| |
| -- Copy the object |
| |
| if not Is_Limited_Record (Expr_Typ) then |
| Insert_Action (N, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Obj_Id, |
| Object_Definition => |
| New_Occurrence_Of (Etype (Obj_Def), Loc), |
| Expression => New_Expr)); |
| |
| -- Rename limited type object since they cannot be copied |
| -- This case occurs when the initialization expression |
| -- has been previously expanded into a temporary object. |
| |
| else pragma Assert (not Comes_From_Source (Expr_Q)); |
| Insert_Action (N, |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => Obj_Id, |
| Subtype_Mark => |
| New_Occurrence_Of (Etype (Obj_Def), Loc), |
| Name => |
| Unchecked_Convert_To |
| (Etype (Obj_Def), New_Expr))); |
| end if; |
| |
| -- Dynamically reference the tag associated with the |
| -- interface. |
| |
| Tag_Comp := |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Displace), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Obj_Id, Loc), |
| Attribute_Name => Name_Address), |
| New_Occurrence_Of |
| (Node (First_Elmt (Access_Disp_Table (Iface))), |
| Loc))); |
| end if; |
| |
| Rewrite (N, |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => Make_Temporary (Loc, 'D'), |
| Subtype_Mark => New_Occurrence_Of (Typ, Loc), |
| Name => |
| Convert_Tag_To_Interface (Typ, Tag_Comp))); |
| |
| -- If the original entity comes from source, then mark the |
| -- new entity as needing debug information, even though it's |
| -- defined by a generated renaming that does not come from |
| -- source, so that Materialize_Entity will be set on the |
| -- entity when Debug_Renaming_Declaration is called during |
| -- analysis. |
| |
| if Comes_From_Source (Def_Id) then |
| Set_Debug_Info_Needed (Defining_Identifier (N)); |
| end if; |
| |
| Analyze (N, Suppress => All_Checks); |
| |
| -- Replace internal identifier of rewritten node by the |
| -- identifier found in the sources. We also have to exchange |
| -- entities containing their defining identifiers to ensure |
| -- the correct replacement of the object declaration by this |
| -- object renaming declaration because these identifiers |
| -- were previously added by Enter_Name to the current scope. |
| -- We must preserve the homonym chain of the source entity |
| -- as well. We must also preserve the kind of the entity, |
| -- which may be a constant. Preserve entity chain because |
| -- itypes may have been generated already, and the full |
| -- chain must be preserved for final freezing. Finally, |
| -- preserve Comes_From_Source setting, so that debugging |
| -- and cross-referencing information is properly kept, and |
| -- preserve source location, to prevent spurious errors when |
| -- entities are declared (they must have their own Sloc). |
| |
| declare |
| New_Id : constant Entity_Id := Defining_Identifier (N); |
| Next_Temp : constant Entity_Id := Next_Entity (New_Id); |
| Save_CFS : constant Boolean := |
| Comes_From_Source (Def_Id); |
| Save_SP : constant Node_Id := SPARK_Pragma (Def_Id); |
| Save_SPI : constant Boolean := |
| SPARK_Pragma_Inherited (Def_Id); |
| |
| begin |
| Link_Entities (New_Id, Next_Entity (Def_Id)); |
| Link_Entities (Def_Id, Next_Temp); |
| |
| Set_Chars (Defining_Identifier (N), Chars (Def_Id)); |
| Set_Homonym (Defining_Identifier (N), Homonym (Def_Id)); |
| Mutate_Ekind (Defining_Identifier (N), Ekind (Def_Id)); |
| Set_Sloc (Defining_Identifier (N), Sloc (Def_Id)); |
| |
| Set_Comes_From_Source (Def_Id, False); |
| |
| -- ??? This is extremely dangerous!!! Exchanging entities |
| -- is very low level, and as a result it resets flags and |
| -- fields which belong to the original Def_Id. Several of |
| -- these attributes are saved and restored, but there may |
| -- be many more that need to be preserverd. |
| |
| Exchange_Entities (Defining_Identifier (N), Def_Id); |
| |
| -- Restore clobbered attributes |
| |
| Set_Comes_From_Source (Def_Id, Save_CFS); |
| Set_SPARK_Pragma (Def_Id, Save_SP); |
| Set_SPARK_Pragma_Inherited (Def_Id, Save_SPI); |
| end; |
| end; |
| |
| return; |
| |
| else |
| return; |
| end if; |
| |
| -- Common case of explicit object initialization |
| |
| else |
| -- In most cases, we must check that the initial value meets any |
| -- constraint imposed by the declared type. However, there is one |
| -- very important exception to this rule. If the entity has an |
| -- unconstrained nominal subtype, then it acquired its constraints |
| -- from the expression in the first place, and not only does this |
| -- mean that the constraint check is not needed, but an attempt to |
| -- perform the constraint check can cause order of elaboration |
| -- problems. |
| |
| if not Is_Constr_Subt_For_U_Nominal (Typ) then |
| |
| -- If this is an allocator for an aggregate that has been |
| -- allocated in place, delay checks until assignments are |
| -- made, because the discriminants are not initialized. |
| |
| if Nkind (Expr) = N_Allocator |
| and then No_Initialization (Expr) |
| then |
| null; |
| |
| -- Otherwise apply a constraint check now if no prev error |
| |
| elsif Nkind (Expr) /= N_Error then |
| Apply_Constraint_Check (Expr, Typ); |
| |
| -- Deal with possible range check |
| |
| if Do_Range_Check (Expr) then |
| |
| -- If assignment checks are suppressed, turn off flag |
| |
| if Suppress_Assignment_Checks (N) then |
| Set_Do_Range_Check (Expr, False); |
| |
| -- Otherwise generate the range check |
| |
| else |
| Generate_Range_Check |
| (Expr, Typ, CE_Range_Check_Failed); |
| end if; |
| end if; |
| end if; |
| end if; |
| |
| -- For tagged types, when an init value is given, the tag has to |
| -- be re-initialized separately in order to avoid the propagation |
| -- of a wrong tag coming from a view conversion unless the type |
| -- is class wide (in this case the tag comes from the init value). |
| -- Suppress the tag assignment when not Tagged_Type_Expansion |
| -- because tags are represented implicitly in objects. Ditto for |
| -- types that are CPP_CLASS, and for initializations that are |
| -- aggregates, because they have to have the right tag. |
| |
| -- The re-assignment of the tag has to be done even if the object |
| -- is a constant. The assignment must be analyzed after the |
| -- declaration. If an address clause follows, this is handled as |
| -- part of the freeze actions for the object, otherwise insert |
| -- tag assignment here. |
| |
| Tag_Assign := Make_Tag_Assignment (N); |
| |
| if Present (Tag_Assign) then |
| if Present (Following_Address_Clause (N)) then |
| Ensure_Freeze_Node (Def_Id); |
| |
| else |
| Insert_Action_After (Init_After, Tag_Assign); |
| end if; |
| |
| -- Handle C++ constructor calls. Note that we do not check that |
| -- Typ is a tagged type since the equivalent Ada type of a C++ |
| -- class that has no virtual methods is an untagged limited |
| -- record type. |
| |
| elsif Is_CPP_Constructor_Call (Expr) then |
| |
| -- The call to the initialization procedure does NOT freeze the |
| -- object being initialized. |
| |
| Id_Ref := New_Occurrence_Of (Def_Id, Loc); |
| Set_Must_Not_Freeze (Id_Ref); |
| Set_Assignment_OK (Id_Ref); |
| |
| Insert_Actions_After (Init_After, |
| Build_Initialization_Call (Loc, Id_Ref, Typ, |
| Constructor_Ref => Expr)); |
| |
| -- We remove here the original call to the constructor |
| -- to avoid its management in the backend |
| |
| Set_Expression (N, Empty); |
| return; |
| |
| -- Handle initialization of limited tagged types |
| |
| elsif Is_Tagged_Type (Typ) |
| and then Is_Class_Wide_Type (Typ) |
| and then Is_Limited_Record (Typ) |
| and then not Is_Limited_Interface (Typ) |
| then |
| -- Given that the type is limited we cannot perform a copy. If |
| -- Expr_Q is the reference to a variable we mark the variable |
| -- as OK_To_Rename to expand this declaration into a renaming |
| -- declaration (see below). |
| |
| if Is_Entity_Name (Expr_Q) then |
| Set_OK_To_Rename (Entity (Expr_Q)); |
| |
| -- If we cannot convert the expression into a renaming we must |
| -- consider it an internal error because the backend does not |
| -- have support to handle it. But avoid crashing on a raise |
| -- expression or conditional expression. |
| |
| elsif Nkind (Original_Node (Expr_Q)) not in |
| N_Raise_Expression | N_If_Expression | N_Case_Expression |
| then |
| raise Program_Error; |
| end if; |
| |
| -- For discrete types, set the Is_Known_Valid flag if the |
| -- initializing value is known to be valid. Only do this for |
| -- source assignments, since otherwise we can end up turning |
| -- on the known valid flag prematurely from inserted code. |
| |
| elsif Comes_From_Source (N) |
| and then Is_Discrete_Type (Typ) |
| and then Expr_Known_Valid (Expr) |
| and then Safe_To_Capture_Value (N, Def_Id) |
| then |
| Set_Is_Known_Valid (Def_Id); |
| |
| elsif Is_Access_Type (Typ) then |
| |
| -- For access types set the Is_Known_Non_Null flag if the |
| -- initializing value is known to be non-null. We can also set |
| -- Can_Never_Be_Null if this is a constant. |
| |
| if Known_Non_Null (Expr) then |
| Set_Is_Known_Non_Null (Def_Id, True); |
| |
| if Constant_Present (N) then |
| Set_Can_Never_Be_Null (Def_Id); |
| end if; |
| end if; |
| end if; |
| |
| -- If validity checking on copies, validate initial expression. |
| -- But skip this if declaration is for a generic type, since it |
| -- makes no sense to validate generic types. Not clear if this |
| -- can happen for legal programs, but it definitely can arise |
| -- from previous instantiation errors. |
| |
| if Validity_Checks_On |
| and then Comes_From_Source (N) |
| and then Validity_Check_Copies |
| and then not Is_Generic_Type (Typ) |
| then |
| Ensure_Valid (Expr); |
| if Safe_To_Capture_Value (N, Def_Id) then |
| Set_Is_Known_Valid (Def_Id); |
| end if; |
| end if; |
| |
| -- Now determine whether we will use a renaming |
| |
| Rewrite_As_Renaming := |
| |
| -- The declaration cannot be rewritten if it has got constraints |
| -- in other words the nominal subtype must be unconstrained. |
| |
| Is_Entity_Name (Original_Node (Obj_Def)) |
| |
| -- The aliased case has to be excluded because the expression |
| -- will not be aliased in the general case. |
| |
| and then not Aliased_Present (N) |
| |
| -- If the object declaration originally appears in the form |
| |
| -- Obj : Typ := Func (...); |
| |
| -- and has been rewritten as the dereference of a reference |
| -- to the function result built either on the primary or the |
| -- secondary stack, then the declaration can be rewritten as |
| -- the renaming of this dereference: |
| |
| -- type Axx is access all Typ; |
| -- Rxx : constant Axx := Func (...)'reference; |
| -- Obj : Typ renames Rxx.all; |
| |
| -- This avoids an extra copy and, in the case where Typ needs |
| -- finalization, a pair of Adjust/Finalize calls (see below). |
| |
| and then |
| ((not Is_Library_Level_Entity (Def_Id) |
| and then Nkind (Expr_Q) = N_Explicit_Dereference |
| and then not Comes_From_Source (Expr_Q) |
| and then Nkind (Original_Node (Expr_Q)) = N_Function_Call |
| and then not Is_Class_Wide_Type (Typ)) |
| |
| -- If the initializing expression is a variable with the |
| -- flag OK_To_Rename set, then transform: |
| |
| -- Obj : Typ := Expr; |
| |
| -- into |
| |
| -- Obj : Typ renames Expr; |
| |
| or else OK_To_Rename_Ref (Expr_Q) |
| |
| -- Likewise if it is a slice of such a variable |
| |
| or else (Nkind (Expr_Q) = N_Slice |
| and then OK_To_Rename_Ref (Prefix (Expr_Q)))); |
| |
| -- If the type needs finalization and is not inherently limited, |
| -- then the target is adjusted after the copy and attached to the |
| -- finalization list. However, no adjustment is needed in the case |
| -- where the object has been initialized by a call to a function |
| -- returning on the primary stack (see Expand_Ctrl_Function_Call) |
| -- since no copy occurred, given that the type is by-reference. |
| -- Similarly, no adjustment is needed if we are going to rewrite |
| -- the object declaration into a renaming declaration. |
| |
| if Needs_Finalization (Typ) |
| and then not Is_Limited_View (Typ) |
| and then Nkind (Expr_Q) /= N_Function_Call |
| and then not Rewrite_As_Renaming |
| then |
| Adj_Call := |
| Make_Adjust_Call ( |
| Obj_Ref => New_Occurrence_Of (Def_Id, Loc), |
| Typ => Base_Typ); |
| |
| -- Guard against a missing [Deep_]Adjust when the base type |
| -- was not properly frozen. |
| |
| if Present (Adj_Call) then |
| Insert_Action_After (Init_After, Adj_Call); |
| end if; |
| end if; |
| end if; |
| |
| -- Cases where the back end cannot handle the initialization |
| -- directly. In such cases, we expand an assignment that will |
| -- be appropriately handled by Expand_N_Assignment_Statement. |
| |
| -- The exclusion of the unconstrained case is wrong, but for now it |
| -- is too much trouble ??? |
| |
| if (Is_Possibly_Unaligned_Slice (Expr) |
| or else (Is_Possibly_Unaligned_Object (Expr) |
| and then not Represented_As_Scalar (Etype (Expr)))) |
| and then not (Is_Array_Type (Etype (Expr)) |
| and then not Is_Constrained (Etype (Expr))) |
| then |
| declare |
| Stat : constant Node_Id := |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Def_Id, Loc), |
| Expression => Relocate_Node (Expr)); |
| begin |
| Set_Assignment_OK (Name (Stat)); |
| Set_No_Ctrl_Actions (Stat); |
| Insert_Action_After (Init_After, Stat); |
| Set_Expression (N, Empty); |
| Set_No_Initialization (N); |
| end; |
| end if; |
| end if; |
| |
| if Nkind (Obj_Def) = N_Access_Definition |
| and then not Is_Local_Anonymous_Access (Typ) |
| then |
| -- An Ada 2012 stand-alone object of an anonymous access type |
| |
| declare |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| Level : constant Entity_Id := |
| Make_Defining_Identifier (Sloc (N), |
| Chars => |
| New_External_Name (Chars (Def_Id), Suffix => "L")); |
| |
| Level_Decl : Node_Id; |
| Level_Expr : Node_Id; |
| |
| begin |
| Mutate_Ekind (Level, Ekind (Def_Id)); |
| Set_Etype (Level, Standard_Natural); |
| Set_Scope (Level, Scope (Def_Id)); |
| |
| -- Set accessibility level of null |
| |
| if No (Expr) then |
| Level_Expr := |
| Make_Integer_Literal |
| (Loc, Scope_Depth (Standard_Standard)); |
| |
| -- When the expression of the object is a function which returns |
| -- an anonymous access type the master of the call is the object |
| -- being initialized instead of the type. |
| |
| elsif Nkind (Expr) = N_Function_Call |
| and then Ekind (Etype (Name (Expr))) = E_Anonymous_Access_Type |
| then |
| Level_Expr := Accessibility_Level |
| (Def_Id, Object_Decl_Level); |
| |
| -- General case |
| |
| else |
| Level_Expr := Accessibility_Level (Expr, Dynamic_Level); |
| end if; |
| |
| Level_Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Level, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Natural, Loc), |
| Expression => Level_Expr, |
| Constant_Present => Constant_Present (N), |
| Has_Init_Expression => True); |
| |
| Insert_Action_After (Init_After, Level_Decl); |
| |
| Set_Extra_Accessibility (Def_Id, Level); |
| end; |
| end if; |
| |
| -- If the object is default initialized and its type is subject to |
| -- pragma Default_Initial_Condition, add a runtime check to verify |
| -- the assumption of the pragma (SPARK RM 7.3.3). Generate: |
| |
| -- <Base_Typ>DIC (<Base_Typ> (Def_Id)); |
| |
| -- Note that the check is generated for source objects only |
| |
| if Comes_From_Source (Def_Id) |
| and then Has_DIC (Typ) |
| and then Present (DIC_Procedure (Typ)) |
| and then not Has_Null_Body (DIC_Procedure (Typ)) |
| and then not Has_Init_Expression (N) |
| and then No (Expr) |
| and then not Is_Imported (Def_Id) |
| then |
| declare |
| DIC_Call : constant Node_Id := |
| Build_DIC_Call |
| (Loc, New_Occurrence_Of (Def_Id, Loc), Typ); |
| begin |
| if Present (Next_N) then |
| Insert_Before_And_Analyze (Next_N, DIC_Call); |
| |
| -- The object declaration is the last node in a declarative or a |
| -- statement list. |
| |
| else |
| Append_To (List_Containing (N), DIC_Call); |
| Analyze (DIC_Call); |
| end if; |
| end; |
| end if; |
| |
| -- If this is the return object of a build-in-place function, locate the |
| -- implicit BIPaccess parameter designating the caller-supplied return |
| -- object and convert the declaration to a renaming of a dereference of |
| -- this parameter. If the declaration includes an expression, add an |
| -- assignment statement to ensure the return object gets initialized. |
| |
| -- Result : T [:= <expression>]; |
| |
| -- is converted to |
| |
| -- Result : T renames BIPaccess.all; |
| -- [Result := <expression>;] |
| |
| -- in the constrained case, or to |
| |
| -- type Txx is access all ...; |
| -- Rxx : Txx := null; |
| |
| -- if BIPalloc = 1 then |
| -- Rxx := BIPaccess; |
| -- Rxx.all := <expression>; |
| -- elsif BIPalloc = 2 then |
| -- Rxx := new <expression-type>'(<expression>)[storage_pool = |
| -- system__secondary_stack__ss_pool][procedure_to_call = |
| -- system__secondary_stack__ss_allocate]; |
| -- elsif BIPalloc = 3 then |
| -- Rxx := new <expression-type>'(<expression>) |
| -- elsif BIPalloc = 4 then |
| -- Pxx : system__storage_pools__root_storage_pool renames |
| -- BIPstoragepool.all; |
| -- Rxx := new <expression-type>'(<expression>)[storage_pool = |
| -- Pxx][procedure_to_call = |
| -- system__storage_pools__allocate_any]; |
| -- else |
| -- [program_error "build in place mismatch"] |
| -- end if; |
| |
| -- Result : T renames Rxx.all; |
| |
| -- in the unconstrained case. |
| |
| if Is_Build_In_Place_Return_Object (Def_Id) then |
| declare |
| Func_Id : constant Entity_Id := Return_Applies_To (Scope (Def_Id)); |
| |
| Init_Stmt : Node_Id; |
| Obj_Acc_Formal : Entity_Id; |
| |
| begin |
| -- Retrieve the implicit access parameter passed by the caller |
| |
| Obj_Acc_Formal := |
| Build_In_Place_Formal (Func_Id, BIP_Object_Access); |
| |
| -- If the return object's declaration includes an expression |
| -- and the declaration isn't marked as No_Initialization, then |
| -- we need to generate an assignment to the object and insert |
| -- it after the declaration before rewriting it as a renaming |
| -- (otherwise we'll lose the initialization). The case where |
| -- the result type is an interface (or class-wide interface) |
| -- is also excluded because the context of the function call |
| -- must be unconstrained, so the initialization will always |
| -- be done as part of an allocator evaluation (storage pool |
| -- or secondary stack), never to a constrained target object |
| -- passed in by the caller. Besides the assignment being |
| -- unneeded in this case, it avoids problems with trying to |
| -- generate a dispatching assignment when the return expression |
| -- is a nonlimited descendant of a limited interface (the |
| -- interface has no assignment operation). |
| |
| if Present (Expr_Q) |
| and then not Is_Delayed_Aggregate (Expr_Q) |
| and then not No_Initialization (N) |
| and then not Is_Interface (Typ) |
| then |
| if Is_Class_Wide_Type (Typ) |
| and then not Is_Class_Wide_Type (Etype (Expr_Q)) |
| then |
| Init_Stmt := |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Def_Id, Loc), |
| Expression => |
| Make_Type_Conversion (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (Typ, Loc), |
| Expression => New_Copy_Tree (Expr_Q))); |
| |
| else |
| Init_Stmt := |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Def_Id, Loc), |
| Expression => New_Copy_Tree (Expr_Q)); |
| end if; |
| |
| Set_Assignment_OK (Name (Init_Stmt)); |
| Set_No_Ctrl_Actions (Init_Stmt); |
| |
| else |
| Init_Stmt := Empty; |
| end if; |
| |
| -- When the function's subtype is unconstrained, a run-time |
| -- test may be needed to decide the form of allocation to use |
| -- for the return object. The function has an implicit formal |
| -- parameter indicating this. If the BIP_Alloc_Form formal has |
| -- the value one, then the caller has passed access to an |
| -- existing object for use as the return object. If the value |
| -- is two, then the return object must be allocated on the |
| -- secondary stack. If the value is three, then the return |
| -- object must be allocated on the heap. Otherwise, the object |
| -- must be allocated in a storage pool. We generate an if |
| -- statement to test the BIP_Alloc_Form formal and initialize |
| -- a local access value appropriately. |
| |
| if Needs_BIP_Alloc_Form (Func_Id) then |
| declare |
| Desig_Typ : constant Entity_Id := |
| (if Ekind (Typ) = E_Array_Subtype |
| then Etype (Func_Id) else Typ); |
| -- Ensure that the we use a fat pointer when allocating |
| -- an unconstrained array on the heap. In this case the |
| -- result object's type is a constrained array type even |
| -- though the function's type is unconstrained. |
| Obj_Alloc_Formal : constant Entity_Id := |
| Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); |
| Pool_Id : constant Entity_Id := |
| Make_Temporary (Loc, 'P'); |
| |
| function Make_Allocator_For_BIP_Return return Node_Id; |
| -- Make an allocator for the BIP return being processed |
| |
| ----------------------------------- |
| -- Make_Allocator_For_BIP_Return -- |
| ----------------------------------- |
| |
| function Make_Allocator_For_BIP_Return return Node_Id is |
| Alloc : Node_Id; |
| |
| begin |
| if Present (Expr_Q) |
| and then not Is_Delayed_Aggregate (Expr_Q) |
| and then not No_Initialization (N) |
| then |
| -- Always use the type of the expression for the |
| -- qualified expression, rather than the result type. |
| -- In general we cannot always use the result type |
| -- for the allocator, because the expression might be |
| -- of a specific type, such as in the case of an |
| -- aggregate or even a nonlimited object when the |
| -- result type is a limited class-wide interface type. |
| |
| Alloc := |
| Make_Allocator (Loc, |
| Expression => |
| Make_Qualified_Expression (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (Etype (Expr_Q), Loc), |
| Expression => New_Copy_Tree (Expr_Q))); |
| |
| else |
| -- If the function returns a class-wide type we cannot |
| -- use the return type for the allocator. Instead we |
| -- use the type of the expression, which must be an |
| -- aggregate of a definite type. |
| |
| if Is_Class_Wide_Type (Typ) then |
| Alloc := |
| Make_Allocator (Loc, |
| Expression => |
| New_Occurrence_Of (Etype (Expr_Q), Loc)); |
| |
| else |
| Alloc := |
| Make_Allocator (Loc, |
| Expression => |
| New_Occurrence_Of (Typ, Loc)); |
| end if; |
| |
| -- If the object requires default initialization then |
| -- that will happen later following the elaboration of |
| -- the object renaming. If we don't turn it off here |
| -- then the object will be default initialized twice. |
| |
| Set_No_Initialization (Alloc); |
| end if; |
| |
| -- Set the flag indicating that the allocator came from |
| -- a build-in-place return statement, so we can avoid |
| -- adjusting the allocated object. |
| |
| Set_Alloc_For_BIP_Return (Alloc); |
| |
| return Alloc; |
| end Make_Allocator_For_BIP_Return; |
| |
| Acc_Typ : Entity_Id; |
| Alloc_Obj_Decl : Node_Id; |
| Alloc_Obj_Id : Entity_Id; |
| Alloc_Stmt : Node_Id; |
| Guard_Except : Node_Id; |
| Heap_Allocator : Node_Id; |
| Pool_Allocator : Node_Id; |
| Pool_Decl : Node_Id; |
| Ptr_Typ_Decl : Node_Id; |
| SS_Allocator : Node_Id; |
| |
| begin |
| -- Create an access type designating the function's |
| -- result subtype. |
| |
| Acc_Typ := Make_Temporary (Loc, 'A'); |
| |
| Ptr_Typ_Decl := |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => Acc_Typ, |
| Type_Definition => |
| Make_Access_To_Object_Definition (Loc, |
| All_Present => True, |
| Subtype_Indication => |
| New_Occurrence_Of (Desig_Typ, Loc))); |
| |
| Insert_Action (N, Ptr_Typ_Decl, Suppress => All_Checks); |
| |
| -- Create an access object that will be initialized to an |
| -- access value denoting the return object, either coming |
| -- from an implicit access value passed in by the caller |
| -- or from the result of an allocator. |
| |
| Alloc_Obj_Id := Make_Temporary (Loc, 'R'); |
| |
| Alloc_Obj_Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Alloc_Obj_Id, |
| Object_Definition => |
| New_Occurrence_Of (Acc_Typ, Loc)); |
| |
| Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks); |
| |
| -- First create the Heap_Allocator |
| |
| Heap_Allocator := Make_Allocator_For_BIP_Return; |
| |
| -- The Pool_Allocator is just like the Heap_Allocator, |
| -- except we set Storage_Pool and Procedure_To_Call so |
| -- it will use the user-defined storage pool. |
| |
| Pool_Allocator := Make_Allocator_For_BIP_Return; |
| |
| -- Do not generate the renaming of the build-in-place |
| -- pool parameter on ZFP because the parameter is not |
| -- created in the first place. |
| |
| if RTE_Available (RE_Root_Storage_Pool_Ptr) then |
| Pool_Decl := |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => Pool_Id, |
| Subtype_Mark => |
| New_Occurrence_Of |
| (RTE (RE_Root_Storage_Pool), Loc), |
| Name => |
| Make_Explicit_Dereference (Loc, |
| New_Occurrence_Of |
| (Build_In_Place_Formal |
| (Func_Id, BIP_Storage_Pool), Loc))); |
| Set_Storage_Pool (Pool_Allocator, Pool_Id); |
| Set_Procedure_To_Call |
| (Pool_Allocator, RTE (RE_Allocate_Any)); |
| else |
| Pool_Decl := Make_Null_Statement (Loc); |
| end if; |
| |
| -- If the No_Allocators restriction is active, then only |
| -- an allocator for secondary stack allocation is needed. |
| -- It's OK for such allocators to have Comes_From_Source |
| -- set to False, because gigi knows not to flag them as |
| -- being a violation of No_Implicit_Heap_Allocations. |
| |
| if Restriction_Active (No_Allocators) then |
| SS_Allocator := Heap_Allocator; |
| Heap_Allocator := Make_Null (Loc); |
| Pool_Allocator := Make_Null (Loc); |
| |
| -- Otherwise the heap and pool allocators may be needed, |
| -- so we make another allocator for secondary stack |
| -- allocation. |
| |
| else |
| SS_Allocator := Make_Allocator_For_BIP_Return; |
| |
| -- The heap and pool allocators are marked as |
| -- Comes_From_Source since they correspond to an |
| -- explicit user-written allocator (that is, it will |
| -- only be executed on behalf of callers that call the |
| -- function as initialization for such an allocator). |
| -- Prevents errors when No_Implicit_Heap_Allocations |
| -- is in force. |
| |
| Set_Comes_From_Source (Heap_Allocator, True); |
| Set_Comes_From_Source (Pool_Allocator, True); |
| end if; |
| |
| -- The allocator is returned on the secondary stack |
| |
| Check_Restriction (No_Secondary_Stack, N); |
| Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); |
| Set_Procedure_To_Call |
| (SS_Allocator, RTE (RE_SS_Allocate)); |
| |
| -- The allocator is returned on the secondary stack, |
| -- so indicate that the function return, as well as |
| -- all blocks that encloses the allocator, must not |
| -- release it. The flags must be set now because |
| -- the decision to use the secondary stack is done |
| -- very late in the course of expanding the return |
| -- statement, past the point where these flags are |
| -- normally set. |
| |
| Set_Uses_Sec_Stack (Func_Id); |
| Set_Uses_Sec_Stack (Scope (Def_Id)); |
| Set_Sec_Stack_Needed_For_Return (Scope (Def_Id)); |
| |
| -- Guard against poor expansion on the caller side by |
| -- using a raise statement to catch out-of-range values |
| -- of formal parameter BIP_Alloc_Form. |
| |
| if Exceptions_OK then |
| Guard_Except := |
| Make_Raise_Program_Error (Loc, |
| Reason => PE_Build_In_Place_Mismatch); |
| else |
| Guard_Except := Make_Null_Statement (Loc); |
| end if; |
| |
| -- Create an if statement to test the BIP_Alloc_Form |
| -- formal and initialize the access object to either the |
| -- BIP_Object_Access formal (BIP_Alloc_Form = |
| -- Caller_Allocation), the result of allocating the |
| -- object in the secondary stack (BIP_Alloc_Form = |
| -- Secondary_Stack), or else an allocator to create the |
| -- return object in the heap or user-defined pool |
| -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool). |
| |
| -- ??? An unchecked type conversion must be made in the |
| -- case of assigning the access object formal to the |
| -- local access object, because a normal conversion would |
| -- be illegal in some cases (such as converting access- |
| -- to-unconstrained to access-to-constrained), but the |
| -- the unchecked conversion will presumably fail to work |
| -- right in just such cases. It's not clear at all how to |
| -- handle this. |
| |
| Alloc_Stmt := |
| Make_If_Statement (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (Obj_Alloc_Formal, Loc), |
| Right_Opnd => |
| Make_Integer_Literal (Loc, |
| UI_From_Int (BIP_Allocation_Form'Pos |
| (Caller_Allocation)))), |
| |
| Then_Statements => New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => |
| New_Occurrence_Of (Alloc_Obj_Id, Loc), |
| Expression => |
| Unchecked_Convert_To |
| (Acc_Typ, |
| New_Occurrence_Of (Obj_Acc_Formal, Loc)))), |
| |
| Elsif_Parts => New_List ( |
| Make_Elsif_Part (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (Obj_Alloc_Formal, Loc), |
| Right_Opnd => |
| Make_Integer_Literal (Loc, |
| UI_From_Int (BIP_Allocation_Form'Pos |
| (Secondary_Stack)))), |
| |
| Then_Statements => New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => |
| New_Occurrence_Of (Alloc_Obj_Id, Loc), |
| Expression => SS_Allocator))), |
| |
| Make_Elsif_Part (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (Obj_Alloc_Formal, Loc), |
| Right_Opnd => |
| Make_Integer_Literal (Loc, |
| UI_From_Int (BIP_Allocation_Form'Pos |
| (Global_Heap)))), |
| |
| Then_Statements => New_List ( |
| Build_Heap_Or_Pool_Allocator |
| (Temp_Id => Alloc_Obj_Id, |
| Temp_Typ => Acc_Typ, |
| Func_Id => Func_Id, |
| Ret_Typ => Desig_Typ, |
| Alloc_Expr => Heap_Allocator))), |
| |
| -- ??? If all is well, we can put the following |
| -- 'elsif' in the 'else', but this is a useful |
| -- self-check in case caller and callee don't agree |
| -- on whether BIPAlloc and so on should be passed. |
| |
| Make_Elsif_Part (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (Obj_Alloc_Formal, Loc), |
| Right_Opnd => |
| Make_Integer_Literal (Loc, |
| UI_From_Int (BIP_Allocation_Form'Pos |
| (User_Storage_Pool)))), |
| |
| Then_Statements => New_List ( |
| Pool_Decl, |
| Build_Heap_Or_Pool_Allocator |
| (Temp_Id => Alloc_Obj_Id, |
| Temp_Typ => Acc_Typ, |
| Func_Id => Func_Id, |
| Ret_Typ => Desig_Typ, |
| Alloc_Expr => Pool_Allocator)))), |
| |
| -- Raise Program_Error if it's none of the above; |
| -- this is a compiler bug. |
| |
| Else_Statements => New_List (Guard_Except)); |
| |
| -- If a separate initialization assignment was created |
| -- earlier, append that following the assignment of the |
| -- implicit access formal to the access object, to ensure |
| -- that the return object is initialized in that case. In |
| -- this situation, the target of the assignment must be |
| -- rewritten to denote a dereference of the access to the |
| -- return object passed in by the caller. |
| |
| if Present (Init_Stmt) then |
| Set_Name (Init_Stmt, |
| Make_Explicit_Dereference (Loc, |
| Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc))); |
| Set_Assignment_OK (Name (Init_Stmt)); |
| |
| Append_To (Then_Statements (Alloc_Stmt), Init_Stmt); |
| Init_Stmt := Empty; |
| end if; |
| |
| Insert_Action (N, Alloc_Stmt, Suppress => All_Checks); |
| |
| -- From now on, the type of the return object is the |
| -- designated type. |
| |
| Set_Etype (Def_Id, Desig_Typ); |
| |
| -- Remember the local access object for use in the |
| -- dereference of the renaming created below. |
| |
| Obj_Acc_Formal := Alloc_Obj_Id; |
| end; |
| |
| -- When the function's type is unconstrained and a run-time test |
| -- is not needed, we nevertheless need to build the return using |
| -- the return object's type. |
| |
| elsif not Is_Constrained (Underlying_Type (Etype (Func_Id))) then |
| declare |
| Acc_Typ : Entity_Id; |
| Alloc_Obj_Decl : Node_Id; |
| Alloc_Obj_Id : Entity_Id; |
| Ptr_Typ_Decl : Node_Id; |
| |
| begin |
| -- Create an access type designating the function's |
| -- result subtype. |
| |
| Acc_Typ := Make_Temporary (Loc, 'A'); |
| |
| Ptr_Typ_Decl := |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => Acc_Typ, |
| Type_Definition => |
| Make_Access_To_Object_Definition (Loc, |
| All_Present => True, |
| Subtype_Indication => |
| New_Occurrence_Of (Typ, Loc))); |
| |
| Insert_Action (N, Ptr_Typ_Decl, Suppress => All_Checks); |
| |
| -- Create an access object initialized to the conversion |
| -- of the implicit access value passed in by the caller. |
| |
| Alloc_Obj_Id := Make_Temporary (Loc, 'R'); |
| |
| -- See the ??? comment a few lines above about the use of |
| -- an unchecked conversion here. |
| |
| Alloc_Obj_Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Alloc_Obj_Id, |
| Object_Definition => |
| New_Occurrence_Of (Acc_Typ, Loc), |
| Expression => |
| Unchecked_Convert_To |
| (Acc_Typ, New_Occurrence_Of (Obj_Acc_Formal, Loc))); |
| |
| Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks); |
| |
| -- Remember the local access object for use in the |
| -- dereference of the renaming created below. |
| |
| Obj_Acc_Formal := Alloc_Obj_Id; |
| end; |
| end if; |
| |
| -- Initialize the object now that it has got its final subtype, |
| -- but before rewriting it as a renaming. |
| |
| if No (Expr_Q) then |
| Default_Initialize_Object (Init_After); |
| |
| elsif Is_Delayed_Aggregate (Expr_Q) |
| and then not No_Initialization (N) |
| then |
| Convert_Aggr_In_Object_Decl (N); |
| |
| elsif Present (Init_Stmt) then |
| Insert_Action_After (Init_After, Init_Stmt); |
| Set_Expression (N, Empty); |
| end if; |
| |
| -- Replace the return object declaration with a renaming of a |
| -- dereference of the access value designating the return object. |
| |
| Expr_Q := |
| Make_Explicit_Dereference (Loc, |
| Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc)); |
| Set_Etype (Expr_Q, Etype (Def_Id)); |
| |
| Rewrite_As_Renaming := True; |
| end; |
| end if; |
| |
| -- Final transformation - turn the object declaration into a renaming |
| -- if appropriate. If this is the completion of a deferred constant |
| -- declaration, then this transformation generates what would be |
| -- illegal code if written by hand, but that's OK. |
| |
| if Rewrite_As_Renaming then |
| Rewrite (N, |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => Def_Id, |
| Subtype_Mark => New_Occurrence_Of (Etype (Def_Id), Loc), |
| Name => Expr_Q)); |
| |
| -- We do not analyze this renaming declaration, because all its |
| -- components have already been analyzed, and if we were to go |
| -- ahead and analyze it, we would in effect be trying to generate |
| -- another declaration of X, which won't do. |
| |
| Set_Renamed_Object (Def_Id, Expr_Q); |
| Set_Analyzed (N); |
| |
| -- We do need to deal with debug issues for this renaming |
| |
| -- First, if entity comes from source, then mark it as needing |
| -- debug information, even though it is defined by a generated |
| -- renaming that does not come from source. |
| |
| Set_Debug_Info_Defining_Id (N); |
| |
| -- Now call the routine to generate debug info for the renaming |
| |
| Insert_Action (N, Debug_Renaming_Declaration (N)); |
| end if; |
| |
| -- Exception on library entity not available |
| |
| exception |
| when RE_Not_Available => |
| return; |
| end Expand_N_Object_Declaration; |
| |
| --------------------------------- |
| -- Expand_N_Subtype_Indication -- |
| --------------------------------- |
| |
| -- Add a check on the range of the subtype and deal with validity checking |
| |
| procedure Expand_N_Subtype_Indication (N : Node_Id) is |
| Ran : constant Node_Id := Range_Expression (Constraint (N)); |
| Typ : constant Entity_Id := Entity (Subtype_Mark (N)); |
| |
| begin |
| if Nkind (Constraint (N)) = N_Range_Constraint then |
| Validity_Check_Range (Range_Expression (Constraint (N))); |
| end if; |
| |
| -- Do not duplicate the work of Process_Range_Expr_In_Decl in Sem_Ch3 |
| |
| if Nkind (Parent (N)) in N_Constrained_Array_Definition | N_Slice |
| and then Nkind (Parent (Parent (N))) not in |
| N_Full_Type_Declaration | N_Object_Declaration |
| then |
| Apply_Range_Check (Ran, Typ); |
| end if; |
| end Expand_N_Subtype_Indication; |
| |
| --------------------------- |
| -- Expand_N_Variant_Part -- |
| --------------------------- |
| |
| -- Note: this procedure no longer has any effect. It used to be that we |
| -- would replace the choices in the last variant by a when others, and |
| -- also expanded static predicates in variant choices here, but both of |
| -- those activities were being done too early, since we can't check the |
| -- choices until the statically predicated subtypes are frozen, which can |
| -- happen as late as the free point of the record, and we can't change the |
| -- last choice to an others before checking the choices, which is now done |
| -- at the freeze point of the record. |
| |
| procedure Expand_N_Variant_Part (N : Node_Id) is |
| begin |
| null; |
| end Expand_N_Variant_Part; |
| |
| --------------------------------- |
| -- Expand_Previous_Access_Type -- |
| --------------------------------- |
| |
| procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is |
| Ptr_Typ : Entity_Id; |
| |
| begin |
| -- Find all access types in the current scope whose designated type is |
| -- Def_Id and build master renamings for them. |
| |
| Ptr_Typ := First_Entity (Current_Scope); |
| while Present (Ptr_Typ) loop |
| if Is_Access_Type (Ptr_Typ) |
| and then Designated_Type (Ptr_Typ) = Def_Id |
| and then No (Master_Id (Ptr_Typ)) |
| then |
| -- Ensure that the designated type has a master |
| |
| Build_Master_Entity (Def_Id); |
| |
| -- Private and incomplete types complicate the insertion of master |
| -- renamings because the access type may precede the full view of |
| -- the designated type. For this reason, the master renamings are |
| -- inserted relative to the designated type. |
| |
| Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id)); |
| end if; |
| |
| Next_Entity (Ptr_Typ); |
| end loop; |
| end Expand_Previous_Access_Type; |
| |
| ----------------------------- |
| -- Expand_Record_Extension -- |
| ----------------------------- |
| |
| -- Add a field _parent at the beginning of the record extension. This is |
| -- used to implement inheritance. Here are some examples of expansion: |
| |
| -- 1. no discriminants |
| -- type T2 is new T1 with null record; |
| -- gives |
| -- type T2 is new T1 with record |
| -- _Parent : T1; |
| -- end record; |
| |
| -- 2. renamed discriminants |
| -- type T2 (B, C : Int) is new T1 (A => B) with record |
| -- _Parent : T1 (A => B); |
| -- D : Int; |
| -- end; |
| |
| -- 3. inherited discriminants |
| -- type T2 is new T1 with record -- discriminant A inherited |
| -- _Parent : T1 (A); |
| -- D : Int; |
| -- end; |
| |
| procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is |
| Indic : constant Node_Id := Subtype_Indication (Def); |
| Loc : constant Source_Ptr := Sloc (Def); |
| Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); |
| Par_Subtype : Entity_Id; |
| Comp_List : Node_Id; |
| Comp_Decl : Node_Id; |
| Parent_N : Node_Id; |
| D : Entity_Id; |
| List_Constr : constant List_Id := New_List; |
| |
| begin |
| -- Expand_Record_Extension is called directly from the semantics, so |
| -- we must check to see whether expansion is active before proceeding, |
| -- because this affects the visibility of selected components in bodies |
| -- of instances. Within a generic we still need to set Parent_Subtype |
| -- link because the visibility of inherited components will have to be |
| -- verified in subsequent instances. |
| |
| if not Expander_Active then |
| if Inside_A_Generic and then Ekind (T) = E_Record_Type then |
| Set_Parent_Subtype (T, Etype (T)); |
| end if; |
| return; |
| end if; |
| |
| -- This may be a derivation of an untagged private type whose full |
| -- view is tagged, in which case the Derived_Type_Definition has no |
| -- extension part. Build an empty one now. |
| |
| if No (Rec_Ext_Part) then |
| Rec_Ext_Part := |
| Make_Record_Definition (Loc, |
| End_Label => Empty, |
| Component_List => Empty, |
| Null_Present => True); |
| |
| Set_Record_Extension_Part (Def, Rec_Ext_Part); |
| Mark_Rewrite_Insertion (Rec_Ext_Part); |
| end if; |
| |
| Comp_List := Component_List (Rec_Ext_Part); |
| |
| Parent_N := Make_Defining_Identifier (Loc, Name_uParent); |
| |
| -- If the derived type inherits its discriminants the type of the |
| -- _parent field must be constrained by the inherited discriminants |
| |
| if Has_Discriminants (T) |
| and then Nkind (Indic) /= N_Subtype_Indication |
| and then not Is_Constrained (Entity (Indic)) |
| then |
| D := First_Discriminant (T); |
| while Present (D) loop |
| Append_To (List_Constr, New_Occurrence_Of (D, Loc)); |
| Next_Discriminant (D); |
| end loop; |
| |
| Par_Subtype := |
| Process_Subtype ( |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => List_Constr)), |
| Def); |
| |
| -- Otherwise the original subtype_indication is just what is needed |
| |
| else |
| Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); |
| end if; |
| |
| Set_Parent_Subtype (T, Par_Subtype); |
| |
| Comp_Decl := |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => Parent_N, |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Aliased_Present => False, |
| Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc))); |
| |
| if Null_Present (Rec_Ext_Part) then |
| Set_Component_List (Rec_Ext_Part, |
| Make_Component_List (Loc, |
| Component_Items => New_List (Comp_Decl), |
| Variant_Part => Empty, |
| Null_Present => False)); |
| Set_Null_Present (Rec_Ext_Part, False); |
| |
| elsif Null_Present (Comp_List) |
| or else Is_Empty_List (Component_Items (Comp_List)) |
| then |
| Set_Component_Items (Comp_List, New_List (Comp_Decl)); |
| Set_Null_Present (Comp_List, False); |
| |
| else |
| Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); |
| end if; |
| |
| Analyze (Comp_Decl); |
| end Expand_Record_Extension; |
| |
| ------------------------ |
| -- Expand_Tagged_Root -- |
| ------------------------ |
| |
| procedure Expand_Tagged_Root (T : Entity_Id) is |
| Def : constant Node_Id := Type_Definition (Parent (T)); |
| Comp_List : Node_Id; |
| Comp_Decl : Node_Id; |
| Sloc_N : Source_Ptr; |
| |
| begin |
| if Null_Present (Def) then |
| Set_Component_List (Def, |
| Make_Component_List (Sloc (Def), |
| Component_Items => Empty_List, |
| Variant_Part => Empty, |
| Null_Present => True)); |
| end if; |
| |
| Comp_List := Component_List (Def); |
| |
| if Null_Present (Comp_List) |
| or else Is_Empty_List (Component_Items (Comp_List)) |
| then |
| Sloc_N := Sloc (Comp_List); |
| else |
| Sloc_N := Sloc (First (Component_Items (Comp_List))); |
| end if; |
| |
| Comp_Decl := |
| Make_Component_Declaration (Sloc_N, |
| Defining_Identifier => First_Tag_Component (T), |
| Component_Definition => |
| Make_Component_Definition (Sloc_N, |
| Aliased_Present => False, |
| Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N))); |
| |
| if Null_Present (Comp_List) |
| or else Is_Empty_List (Component_Items (Comp_List)) |
| then |
| Set_Component_Items (Comp_List, New_List (Comp_Decl)); |
| Set_Null_Present (Comp_List, False); |
| |
| else |
| Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); |
| end if; |
| |
| -- We don't Analyze the whole expansion because the tag component has |
| -- already been analyzed previously. Here we just insure that the tree |
| -- is coherent with the semantic decoration |
| |
| Find_Type (Subtype_Indication (Component_Definition (Comp_Decl))); |
| |
| exception |
| when RE_Not_Available => |
| return; |
| end Expand_Tagged_Root; |
| |
| ------------------------------ |
| -- Freeze_Stream_Operations -- |
| ------------------------------ |
| |
| procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is |
| Names : constant array (1 .. 4) of TSS_Name_Type := |
| (TSS_Stream_Input, |
| TSS_Stream_Output, |
| TSS_Stream_Read, |
| TSS_Stream_Write); |
| Stream_Op : Entity_Id; |
| |
| begin |
| -- Primitive operations of tagged types are frozen when the dispatch |
| -- table is constructed. |
| |
| if not Comes_From_Source (Typ) or else Is_Tagged_Type (Typ) then |
| return; |
| end if; |
| |
| for J in Names'Range loop |
| Stream_Op := TSS (Typ, Names (J)); |
| |
| if Present (Stream_Op) |
| and then Is_Subprogram (Stream_Op) |
| and then Nkind (Unit_Declaration_Node (Stream_Op)) = |
| N_Subprogram_Declaration |
| and then not Is_Frozen (Stream_Op) |
| then |
| Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N)); |
| end if; |
| end loop; |
| end Freeze_Stream_Operations; |
| |
| ----------------- |
| -- Freeze_Type -- |
| ----------------- |
| |
| -- Full type declarations are expanded at the point at which the type is |
| -- frozen. The formal N is the Freeze_Node for the type. Any statements or |
| -- declarations generated by the freezing (e.g. the procedure generated |
| -- for initialization) are chained in the Actions field list of the freeze |
| -- node using Append_Freeze_Actions. |
| |
| -- WARNING: This routine manages Ghost regions. Return statements must be |
| -- replaced by gotos which jump to the end of the routine and restore the |
| -- Ghost mode. |
| |
| function Freeze_Type (N : Node_Id) return Boolean is |
| procedure Process_RACW_Types (Typ : Entity_Id); |
| -- Validate and generate stubs for all RACW types associated with type |
| -- Typ. |
| |
| procedure Process_Pending_Access_Types (Typ : Entity_Id); |
| -- Associate type Typ's Finalize_Address primitive with the finalization |
| -- masters of pending access-to-Typ types. |
| |
| ------------------------ |
| -- Process_RACW_Types -- |
| ------------------------ |
| |
| procedure Process_RACW_Types (Typ : Entity_Id) is |
| List : constant Elist_Id := Access_Types_To_Process (N); |
| E : Elmt_Id; |
| Seen : Boolean := False; |
| |
| begin |
| if Present (List) then |
| E := First_Elmt (List); |
| while Present (E) loop |
| if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then |
| Validate_RACW_Primitives (Node (E)); |
| Seen := True; |
| end if; |
| |
| Next_Elmt (E); |
| end loop; |
| end if; |
| |
| -- If there are RACWs designating this type, make stubs now |
| |
| if Seen then |
| Remote_Types_Tagged_Full_View_Encountered (Typ); |
| end if; |
| end Process_RACW_Types; |
| |
| ---------------------------------- |
| -- Process_Pending_Access_Types -- |
| ---------------------------------- |
| |
| procedure Process_Pending_Access_Types (Typ : Entity_Id) is |
| E : Elmt_Id; |
| |
| begin |
| -- Finalize_Address is not generated in CodePeer mode because the |
| -- body contains address arithmetic. This processing is disabled. |
| |
| if CodePeer_Mode then |
| null; |
| |
| -- Certain itypes are generated for contexts that cannot allocate |
| -- objects and should not set primitive Finalize_Address. |
| |
| elsif Is_Itype (Typ) |
| and then Nkind (Associated_Node_For_Itype (Typ)) = |
| N_Explicit_Dereference |
| then |
| null; |
| |
| -- When an access type is declared after the incomplete view of a |
| -- Taft-amendment type, the access type is considered pending in |
| -- case the full view of the Taft-amendment type is controlled. If |
| -- this is indeed the case, associate the Finalize_Address routine |
| -- of the full view with the finalization masters of all pending |
| -- access types. This scenario applies to anonymous access types as |
| -- well. |
| |
| elsif Needs_Finalization (Typ) |
| and then Present (Pending_Access_Types (Typ)) |
| then |
| E := First_Elmt (Pending_Access_Types (Typ)); |
| while Present (E) loop |
| |
| -- Generate: |
| -- Set_Finalize_Address |
| -- (Ptr_Typ, <Typ>FD'Unrestricted_Access); |
| |
| Append_Freeze_Action (Typ, |
| Make_Set_Finalize_Address_Call |
| (Loc => Sloc (N), |
| Ptr_Typ => Node (E))); |
| |
| Next_Elmt (E); |
| end loop; |
| end if; |
| end Process_Pending_Access_Types; |
| |
| -- Local variables |
| |
| Def_Id : constant Entity_Id := Entity (N); |
| |
| Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; |
| Saved_IGR : constant Node_Id := Ignored_Ghost_Region; |
| -- Save the Ghost-related attributes to restore on exit |
| |
| Result : Boolean := False; |
| |
| -- Start of processing for Freeze_Type |
| |
| begin |
| -- The type being frozen may be subject to pragma Ghost. Set the mode |
| -- now to ensure that any nodes generated during freezing are properly |
| -- marked as Ghost. |
| |
| Set_Ghost_Mode (Def_Id); |
| |
| -- Process any remote access-to-class-wide types designating the type |
| -- being frozen. |
| |
| Process_RACW_Types (Def_Id); |
| |
| -- Freeze processing for record types |
| |
| if Is_Record_Type (Def_Id) then |
| if Ekind (Def_Id) = E_Record_Type then |
| Expand_Freeze_Record_Type (N); |
| elsif Is_Class_Wide_Type (Def_Id) then |
| Expand_Freeze_Class_Wide_Type (N); |
| end if; |
| |
| -- Freeze processing for array types |
| |
| elsif Is_Array_Type (Def_Id) then |
| Expand_Freeze_Array_Type (N); |
| |
| -- Freeze processing for access types |
| |
| -- For pool-specific access types, find out the pool object used for |
| -- this type, needs actual expansion of it in some cases. Here are the |
| -- different cases : |
| |
| -- 1. Rep Clause "for Def_Id'Storage_Size use 0;" |
| -- ---> don't use any storage pool |
| |
| -- 2. Rep Clause : for Def_Id'Storage_Size use Expr. |
| -- Expand: |
| -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment); |
| |
| -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" |
| -- ---> Storage Pool is the specified one |
| |
| -- See GNAT Pool packages in the Run-Time for more details |
| |
| elsif Ekind (Def_Id) in E_Access_Type | E_General_Access_Type then |
| declare |
| Loc : constant Source_Ptr := Sloc (N); |
| Desig_Type : constant Entity_Id := Designated_Type (Def_Id); |
| |
| Freeze_Action_Typ : Entity_Id; |
| Pool_Object : Entity_Id; |
| |
| begin |
| -- Case 1 |
| |
| -- Rep Clause "for Def_Id'Storage_Size use 0;" |
| -- ---> don't use any storage pool |
| |
| if No_Pool_Assigned (Def_Id) then |
| null; |
| |
| -- Case 2 |
| |
| -- Rep Clause : for Def_Id'Storage_Size use Expr. |
| -- ---> Expand: |
| -- Def_Id__Pool : Stack_Bounded_Pool |
| -- (Expr, DT'Size, DT'Alignment); |
| |
| elsif Has_Storage_Size_Clause (Def_Id) then |
| declare |
| DT_Align : Node_Id; |
| DT_Size : Node_Id; |
| |
| begin |
| -- For unconstrained composite types we give a size of zero |
| -- so that the pool knows that it needs a special algorithm |
| -- for variable size object allocation. |
| |
| if Is_Composite_Type (Desig_Type) |
| and then not Is_Constrained (Desig_Type) |
| then |
| DT_Size := Make_Integer_Literal (Loc, 0); |
| DT_Align := Make_Integer_Literal (Loc, Maximum_Alignment); |
| |
| else |
| DT_Size := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Desig_Type, Loc), |
| Attribute_Name => Name_Max_Size_In_Storage_Elements); |
| |
| DT_Align := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Desig_Type, Loc), |
| Attribute_Name => Name_Alignment); |
| end if; |
| |
| Pool_Object := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Chars (Def_Id), 'P')); |
| |
| -- We put the code associated with the pools in the entity |
| -- that has the later freeze node, usually the access type |
| -- but it can also be the designated_type; because the pool |
| -- code requires both those types to be frozen |
| |
| if Is_Frozen (Desig_Type) |
| and then (No (Freeze_Node (Desig_Type)) |
| or else Analyzed (Freeze_Node (Desig_Type))) |
| then |
| Freeze_Action_Typ := Def_Id; |
| |
| -- A Taft amendment type cannot get the freeze actions |
| -- since the full view is not there. |
| |
| elsif Is_Incomplete_Or_Private_Type (Desig_Type) |
| and then No (Full_View (Desig_Type)) |
| then |
| Freeze_Action_Typ := Def_Id; |
| |
| else |
| Freeze_Action_Typ := Desig_Type; |
| end if; |
| |
| Append_Freeze_Action (Freeze_Action_Typ, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Pool_Object, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of |
| (RTE (RE_Stack_Bounded_Pool), Loc), |
| |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List ( |
| |
| -- First discriminant is the Pool Size |
| |
| New_Occurrence_Of ( |
| Storage_Size_Variable (Def_Id), Loc), |
| |
| -- Second discriminant is the element size |
| |
| DT_Size, |
| |
| -- Third discriminant is the alignment |
| |
| DT_Align))))); |
| end; |
| |
| Set_Associated_Storage_Pool (Def_Id, Pool_Object); |
| |
| -- Case 3 |
| |
| -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" |
| -- ---> Storage Pool is the specified one |
| |
| -- When compiling in Ada 2012 mode, ensure that the accessibility |
| -- level of the subpool access type is not deeper than that of the |
| -- pool_with_subpools. |
| |
| elsif Ada_Version >= Ada_2012 |
| and then Present (Associated_Storage_Pool (Def_Id)) |
| and then RTU_Loaded (System_Storage_Pools_Subpools) |
| then |
| declare |
| Loc : constant Source_Ptr := Sloc (Def_Id); |
| Pool : constant Entity_Id := |
| Associated_Storage_Pool (Def_Id); |
| |
| begin |
| -- It is known that the accessibility level of the access |
| -- type is deeper than that of the pool. |
| |
| if Type_Access_Level (Def_Id) |
| > Static_Accessibility_Level (Pool, Object_Decl_Level) |
| and then Is_Class_Wide_Type (Etype (Pool)) |
| and then not Accessibility_Checks_Suppressed (Def_Id) |
| and then not Accessibility_Checks_Suppressed (Pool) |
| then |
| -- When the pool is of a class-wide type, it may or may |
| -- not support subpools depending on the path of |
| -- derivation. Generate: |
| |
| -- if Def_Id in RSPWS'Class then |
| -- raise Program_Error; |
| -- end if; |
| |
| Append_Freeze_Action (Def_Id, |
| Make_If_Statement (Loc, |
| Condition => |
| Make_In (Loc, |
| Left_Opnd => New_Occurrence_Of (Pool, Loc), |
| Right_Opnd => |
| New_Occurrence_Of |
| (Class_Wide_Type |
| (RTE |
| (RE_Root_Storage_Pool_With_Subpools)), |
| Loc)), |
| Then_Statements => New_List ( |
| Make_Raise_Program_Error (Loc, |
| Reason => PE_Accessibility_Check_Failed)))); |
| end if; |
| end; |
| end if; |
| |
| -- For access-to-controlled types (including class-wide types and |
| -- Taft-amendment types, which potentially have controlled |
| -- components), expand the list controller object that will store |
| -- the dynamically allocated objects. Don't do this transformation |
| -- for expander-generated access types, except do it for types |
| -- that are the full view of types derived from other private |
| -- types and for access types used to implement indirect temps. |
| -- 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) |
| and then not Old_Attr_Util.Indirect_Temps |
| .Is_Access_Type_For_Indirect_Temp (Def_Id) |
| then |
| null; |
| |
| -- An exception is made for types defined in the run-time because |
| -- Ada.Tags.Tag itself is such a type and cannot afford this |
| -- unnecessary overhead that would generates a loop in the |
| -- expansion scheme. Another exception is if Restrictions |
| -- (No_Finalization) is active, since then we know nothing is |
| -- controlled. |
| |
| elsif Restriction_Active (No_Finalization) |
| or else In_Runtime (Def_Id) |
| then |
| null; |
| |
| -- Create a finalization master for an access-to-controlled type |
| -- or an access-to-incomplete type. It is assumed that the full |
| -- view will be controlled. |
| |
| elsif Needs_Finalization (Desig_Type) |
| or else (Is_Incomplete_Type (Desig_Type) |
| and then No (Full_View (Desig_Type))) |
| then |
| Build_Finalization_Master (Def_Id); |
| |
| -- Create a finalization master when the designated type contains |
| -- a private component. It is assumed that the full view will be |
| -- controlled. |
| |
| elsif Has_Private_Component (Desig_Type) then |
| Build_Finalization_Master |
| (Typ => Def_Id, |
| For_Private => True, |
| Context_Scope => Scope (Def_Id), |
| Insertion_Node => Declaration_Node (Desig_Type)); |
| end if; |
| end; |
| |
| -- Freeze processing for enumeration types |
| |
| elsif Ekind (Def_Id) = E_Enumeration_Type then |
| |
| -- We only have something to do if we have a non-standard |
| -- representation (i.e. at least one literal whose pos value |
| -- is not the same as its representation) |
| |
| if Has_Non_Standard_Rep (Def_Id) then |
| Expand_Freeze_Enumeration_Type (N); |
| end if; |
| |
| -- Private types that are completed by a derivation from a private |
| -- type have an internally generated full view, that needs to be |
| -- frozen. This must be done explicitly because the two views share |
| -- the freeze node, and the underlying full view is not visible when |
| -- the freeze node is analyzed. |
| |
| elsif Is_Private_Type (Def_Id) |
| and then Is_Derived_Type (Def_Id) |
| and then Present (Full_View (Def_Id)) |
| and then Is_Itype (Full_View (Def_Id)) |
| and then Has_Private_Declaration (Full_View (Def_Id)) |
| and then Freeze_Node (Full_View (Def_Id)) = N |
| then |
| Set_Entity (N, Full_View (Def_Id)); |
| Result := Freeze_Type (N); |
| Set_Entity (N, Def_Id); |
| |
| -- All other types require no expander action. There are such cases |
| -- (e.g. task types and protected types). In such cases, the freeze |
| -- nodes are there for use by Gigi. |
| |
| end if; |
| |
| -- Complete the initialization of all pending access types' finalization |
| -- masters now that the designated type has been is frozen and primitive |
| -- Finalize_Address generated. |
| |
| Process_Pending_Access_Types (Def_Id); |
| Freeze_Stream_Operations (N, Def_Id); |
| |
| -- Generate the [spec and] body of the invariant procedure tasked with |
| -- the runtime verification of all invariants that pertain to the type. |
| -- This includes invariants on the partial and full view, inherited |
| -- class-wide invariants from parent types or interfaces, and invariants |
| -- on array elements or record components. But skip internal types. |
| |
| if Is_Itype (Def_Id) then |
| null; |
| |
| elsif Is_Interface (Def_Id) then |
| |
| -- Interfaces are treated as the partial view of a private type in |
| -- order to achieve uniformity with the general case. As a result, an |
| -- interface receives only a "partial" invariant procedure which is |
| -- never called. |
| |
| if Has_Own_Invariants (Def_Id) then |
| Build_Invariant_Procedure_Body |
| (Typ => Def_Id, |
| Partial_Invariant => Is_Interface (Def_Id)); |
| end if; |
| |
| -- Non-interface types |
| |
| -- Do not generate invariant procedure within other assertion |
| -- subprograms, which may involve local declarations of local |
| -- subtypes to which these checks do not apply. |
| |
| else |
| if Has_Invariants (Def_Id) then |
| if not Predicate_Check_In_Scope (Def_Id) |
| or else (Ekind (Current_Scope) = E_Function |
| and then Is_Predicate_Function (Current_Scope)) |
| then |
| null; |
| else |
| Build_Invariant_Procedure_Body (Def_Id); |
| end if; |
| end if; |
| |
| -- Generate the [spec and] body of the procedure tasked with the |
| -- run-time verification of pragma Default_Initial_Condition's |
| -- expression. |
| |
| if Has_DIC (Def_Id) then |
| Build_DIC_Procedure_Body (Def_Id); |
| end if; |
| end if; |
| |
| Restore_Ghost_Region (Saved_GM, Saved_IGR); |
| |
| return Result; |
| |
| exception |
| when RE_Not_Available => |
| Restore_Ghost_Region (Saved_GM, Saved_IGR); |
| |
| return False; |
| end Freeze_Type; |
| |
| ------------------------- |
| -- Get_Simple_Init_Val -- |
| ------------------------- |
| |
| function Get_Simple_Init_Val |
| (Typ : Entity_Id; |
| N : Node_Id; |
| Size : Uint := No_Uint) return Node_Id |
| is |
| IV_Attribute : constant Boolean := |
| Nkind (N) = N_Attribute_Reference |
| and then Attribute_Name (N) = Name_Invalid_Value; |
| |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| procedure Extract_Subtype_Bounds |
| (Lo_Bound : out Uint; |
| Hi_Bound : out Uint); |
| -- Inspect subtype Typ as well its ancestor subtypes and derived types |
| -- to determine the best known information about the bounds of the type. |
| -- The output parameters are set as follows: |
| -- |
| -- * Lo_Bound - Set to No_Unit when there is no information available, |
| -- or to the known low bound. |
| -- |
| -- * Hi_Bound - Set to No_Unit when there is no information available, |
| -- or to the known high bound. |
| |
| function Simple_Init_Array_Type return Node_Id; |
| -- Build an expression to initialize array type Typ |
| |
| function Simple_Init_Defaulted_Type return Node_Id; |
| -- Build an expression to initialize type Typ which is subject to |
| -- aspect Default_Value. |
| |
| function Simple_Init_Initialize_Scalars_Type |
| (Size_To_Use : Uint) return Node_Id; |
| -- Build an expression to initialize scalar type Typ which is subject to |
| -- pragma Initialize_Scalars. Size_To_Use is the size of the object. |
| |
| function Simple_Init_Normalize_Scalars_Type |
| (Size_To_Use : Uint) return Node_Id; |
| -- Build an expression to initialize scalar type Typ which is subject to |
| -- pragma Normalize_Scalars. Size_To_Use is the size of the object. |
| |
| function Simple_Init_Private_Type return Node_Id; |
| -- Build an expression to initialize private type Typ |
| |
| function Simple_Init_Scalar_Type return Node_Id; |
| -- Build an expression to initialize scalar type Typ |
| |
| ---------------------------- |
| -- Extract_Subtype_Bounds -- |
| ---------------------------- |
| |
| procedure Extract_Subtype_Bounds |
| (Lo_Bound : out Uint; |
| Hi_Bound : out Uint) |
| is |
| ST1 : Entity_Id; |
| ST2 : Entity_Id; |
| Lo : Node_Id; |
| Hi : Node_Id; |
| Lo_Val : Uint; |
| Hi_Val : Uint; |
| |
| begin |
| Lo_Bound := No_Uint; |
| Hi_Bound := No_Uint; |
| |
| -- Loop to climb ancestor subtypes and derived types |
| |
| ST1 := Typ; |
| 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 |
| Lo_Val := Expr_Value (Lo); |
| |
| if No (Lo_Bound) or else Lo_Bound < Lo_Val then |
| Lo_Bound := Lo_Val; |
| end if; |
| end if; |
| |
| if Compile_Time_Known_Value (Hi) then |
| Hi_Val := Expr_Value (Hi); |
| |
| if No (Hi_Bound) or else Hi_Bound > Hi_Val then |
| Hi_Bound := Hi_Val; |
| 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 Extract_Subtype_Bounds; |
| |
| ---------------------------- |
| -- Simple_Init_Array_Type -- |
| ---------------------------- |
| |
| function Simple_Init_Array_Type return Node_Id is |
| Comp_Typ : constant Entity_Id := Component_Type (Typ); |
| |
| function Simple_Init_Dimension (Index : Node_Id) return Node_Id; |
| -- Initialize a single array dimension with index constraint Index |
| |
| -------------------- |
| -- Simple_Init_Dimension -- |
| -------------------- |
| |
| function Simple_Init_Dimension (Index : Node_Id) return Node_Id is |
| begin |
| -- Process the current dimension |
| |
| if Present (Index) then |
| |
| -- Build a suitable "others" aggregate for the next dimension, |
| -- or initialize the component itself. Generate: |
| -- |
| -- (others => ...) |
| |
| return |
| Make_Aggregate (Loc, |
| Component_Associations => New_List ( |
| Make_Component_Association (Loc, |
| Choices => New_List (Make_Others_Choice (Loc)), |
| Expression => |
| Simple_Init_Dimension (Next_Index (Index))))); |
| |
| -- Otherwise all dimensions have been processed. Initialize the |
| -- component itself. |
| |
| else |
| return |
| Get_Simple_Init_Val |
| (Typ => Comp_Typ, |
| N => N, |
| Size => Esize (Comp_Typ)); |
| end if; |
| end Simple_Init_Dimension; |
| |
| -- Start of processing for Simple_Init_Array_Type |
| |
| begin |
| return Simple_Init_Dimension (First_Index (Typ)); |
| end Simple_Init_Array_Type; |
| |
| -------------------------------- |
| -- Simple_Init_Defaulted_Type -- |
| -------------------------------- |
| |
| function Simple_Init_Defaulted_Type return Node_Id is |
| Subtyp : Entity_Id := First_Subtype (Typ); |
| |
| begin |
| -- When the first subtype is private, retrieve the expression of the |
| -- Default_Value from the underlying type. |
| |
| if Is_Private_Type (Subtyp) then |
| Subtyp := Full_View (Subtyp); |
| end if; |
| |
| -- Use the Sloc of the context node when constructing the initial |
| -- value because the expression of Default_Value may come from a |
| -- different unit. Updating the Sloc will result in accurate error |
| -- diagnostics. |
| |
| return |
| OK_Convert_To |
| (Typ => Typ, |
| Expr => |
| New_Copy_Tree |
| (Source => Default_Aspect_Value (Subtyp), |
| New_Sloc => Loc)); |
| end Simple_Init_Defaulted_Type; |
| |
| ----------------------------------------- |
| -- Simple_Init_Initialize_Scalars_Type -- |
| ----------------------------------------- |
| |
| function Simple_Init_Initialize_Scalars_Type |
| (Size_To_Use : Uint) return Node_Id |
| is |
| Float_Typ : Entity_Id; |
| Hi_Bound : Uint; |
| Lo_Bound : Uint; |
| Scal_Typ : Scalar_Id; |
| |
| begin |
| Extract_Subtype_Bounds (Lo_Bound, Hi_Bound); |
| |
| -- Float types |
| |
| if Is_Floating_Point_Type (Typ) then |
| Float_Typ := Root_Type (Typ); |
| |
| if Float_Typ = Standard_Short_Float then |
| Scal_Typ := Name_Short_Float; |
| elsif Float_Typ = Standard_Float then |
| Scal_Typ := Name_Float; |
| elsif Float_Typ = Standard_Long_Float then |
| Scal_Typ := Name_Long_Float; |
| else pragma Assert (Float_Typ = Standard_Long_Long_Float); |
| Scal_Typ := Name_Long_Long_Float; |
| end if; |
| |
| -- If zero is invalid, it is a convenient value to use that is for |
| -- sure an appropriate invalid value in all situations. |
| |
| elsif Present (Lo_Bound) and then Lo_Bound > Uint_0 then |
| return Make_Integer_Literal (Loc, 0); |
| |
| -- Unsigned types |
| |
| elsif Is_Unsigned_Type (Typ) then |
| if Size_To_Use <= 8 then |
| Scal_Typ := Name_Unsigned_8; |
| elsif Size_To_Use <= 16 then |
| Scal_Typ := Name_Unsigned_16; |
| elsif Size_To_Use <= 32 then |
| Scal_Typ := Name_Unsigned_32; |
| elsif Size_To_Use <= 64 then |
| Scal_Typ := Name_Unsigned_64; |
| else |
| Scal_Typ := Name_Unsigned_128; |
| end if; |
| |
| -- Signed types |
| |
| else |
| if Size_To_Use <= 8 then |
| Scal_Typ := Name_Signed_8; |
| elsif Size_To_Use <= 16 then |
| Scal_Typ := Name_Signed_16; |
| elsif Size_To_Use <= 32 then |
| Scal_Typ := Name_Signed_32; |
| elsif Size_To_Use <= 64 then |
| Scal_Typ := Name_Signed_64; |
| else |
| Scal_Typ := Name_Signed_128; |
| end if; |
| end if; |
| |
| -- Use the values specified by pragma Initialize_Scalars or the ones |
| -- provided by the binder. Higher precedence is given to the pragma. |
| |
| return Invalid_Scalar_Value (Loc, Scal_Typ); |
| end Simple_Init_Initialize_Scalars_Type; |
| |
| ---------------------------------------- |
| -- Simple_Init_Normalize_Scalars_Type -- |
| ---------------------------------------- |
| |
| function Simple_Init_Normalize_Scalars_Type |
| (Size_To_Use : Uint) return Node_Id |
| is |
| Signed_Size : constant Uint := UI_Min (Uint_63, Size_To_Use - 1); |
| |
| Expr : Node_Id; |
| Hi_Bound : Uint; |
| Lo_Bound : Uint; |
| |
| begin |
| Extract_Subtype_Bounds (Lo_Bound, Hi_Bound); |
| |
| -- If zero is invalid, it is a convenient value to use that is for |
| -- sure an appropriate invalid value in all situations. |
| |
| if Present (Lo_Bound) and then Lo_Bound > Uint_0 then |
| Expr := Make_Integer_Literal (Loc, 0); |
| |
| -- Cases where all one bits is the appropriate invalid value |
| |
| -- For modular types, all 1 bits is either invalid or valid. If it |
| -- is valid, then there is nothing that can be done since there are |
| -- no invalid values (we ruled out zero already). |
| |
| -- For signed integer types that have no negative values, either |
| -- there is room for negative values, or there is not. If there |
| -- is, then all 1-bits may be interpreted as minus one, which is |
| -- certainly invalid. Alternatively it is treated as the largest |
| -- positive value, in which case the observation for modular types |
| -- still applies. |
| |
| -- For float types, all 1-bits is a NaN (not a number), which is |
| -- certainly an appropriately invalid value. |
| |
| elsif Is_Enumeration_Type (Typ) |
| or else Is_Floating_Point_Type (Typ) |
| or else Is_Unsigned_Type (Typ) |
| then |
| Expr := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1); |
| |
| -- Resolve as Long_Long_Long_Unsigned, because the largest number |
| -- we can generate is out of range of universal integer. |
| |
| Analyze_And_Resolve (Expr, Standard_Long_Long_Long_Unsigned); |
| |
| -- Case of signed types |
| |
| else |
| -- 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 Present (Lo_Bound) and then Present (Hi_Bound) |
| and then Lo_Bound <= (-(2 ** Signed_Size)) |
| and then Hi_Bound < 2 ** Signed_Size |
| then |
| Expr := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1); |
| |
| -- Normal case of largest negative value |
| |
| else |
| Expr := Make_Integer_Literal (Loc, -(2 ** Signed_Size)); |
| end if; |
| end if; |
| |
| return Expr; |
| end Simple_Init_Normalize_Scalars_Type; |
| |
| ------------------------------ |
| -- Simple_Init_Private_Type -- |
| ------------------------------ |
| |
| function Simple_Init_Private_Type return Node_Id is |
| Under_Typ : constant Entity_Id := Underlying_Type (Typ); |
| Expr : Node_Id; |
| |
| begin |
| -- The availability of the underlying view must be checked by routine |
| -- Needs_Simple_Initialization. |
| |
| pragma Assert (Present (Under_Typ)); |
| |
| Expr := Get_Simple_Init_Val (Under_Typ, N, Size); |
| |
| -- If the initial value is null or an aggregate, qualify it with the |
| -- underlying type in order to provide a proper context. |
| |
| if Nkind (Expr) in N_Aggregate | N_Null then |
| Expr := |
| Make_Qualified_Expression (Loc, |
| Subtype_Mark => New_Occurrence_Of (Under_Typ, Loc), |
| Expression => Expr); |
| end if; |
| |
| Expr := Unchecked_Convert_To (Typ, Expr); |
| |
| -- Do not truncate the result when scalar types are involved and |
| -- Initialize/Normalize_Scalars is in effect. |
| |
| if Nkind (Expr) = N_Unchecked_Type_Conversion |
| and then Is_Scalar_Type (Under_Typ) |
| then |
| Set_No_Truncation (Expr); |
| end if; |
| |
| return Expr; |
| end Simple_Init_Private_Type; |
| |
| ----------------------------- |
| -- Simple_Init_Scalar_Type -- |
| ----------------------------- |
| |
| function Simple_Init_Scalar_Type return Node_Id is |
| Expr : Node_Id; |
| Size_To_Use : Uint; |
| |
| begin |
| pragma Assert (Init_Or_Norm_Scalars or IV_Attribute); |
| |
| -- Determine the size of the object. This is either the size provided |
| -- by the caller, or the Esize of the scalar type. |
| |
| if No (Size) or else Size <= Uint_0 then |
| Size_To_Use := UI_Max (Uint_1, Esize (Typ)); |
| else |
| Size_To_Use := Size; |
| end if; |
| |
| -- The maximum size to use is System_Max_Integer_Size bits. This |
| -- will create values of type Long_Long_Long_Unsigned and the range |
| -- must fit this type. |
| |
| if Present (Size_To_Use) |
| and then Size_To_Use > System_Max_Integer_Size |
| then |
| Size_To_Use := UI_From_Int (System_Max_Integer_Size); |
| end if; |
| |
| if Normalize_Scalars and then not IV_Attribute then |
| Expr := Simple_Init_Normalize_Scalars_Type (Size_To_Use); |
| else |
| Expr := Simple_Init_Initialize_Scalars_Type (Size_To_Use); |
| end if; |
| |
| -- The final expression is obtained by doing an unchecked conversion |
| -- of this result to the base type of the required subtype. Use the |
| -- base type to prevent the unchecked conversion from chopping bits, |
| -- and then we set Kill_Range_Check to preserve the "bad" value. |
| |
| Expr := Unchecked_Convert_To (Base_Type (Typ), Expr); |
| |
| -- Ensure that the expression is not truncated since the "bad" bits |
| -- are desired, and also kill the range checks. |
| |
| if Nkind (Expr) = N_Unchecked_Type_Conversion then |
| Set_Kill_Range_Check (Expr); |
| Set_No_Truncation (Expr); |
| end if; |
| |
| return Expr; |
| end Simple_Init_Scalar_Type; |
| |
| -- Start of processing for Get_Simple_Init_Val |
| |
| begin |
| if Is_Private_Type (Typ) then |
| return Simple_Init_Private_Type; |
| |
| elsif Is_Scalar_Type (Typ) then |
| if Has_Default_Aspect (Typ) then |
| return Simple_Init_Defaulted_Type; |
| else |
| return Simple_Init_Scalar_Type; |
| end if; |
| |
| -- Array type with Initialize or Normalize_Scalars |
| |
| elsif Is_Array_Type (Typ) then |
| pragma Assert (Init_Or_Norm_Scalars); |
| return Simple_Init_Array_Type; |
| |
| -- Access type is initialized to null |
| |
| elsif Is_Access_Type (Typ) then |
| return Make_Null (Loc); |
| |
| -- No other possibilities should arise, since we should only be calling |
| -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True, |
| -- indicating one of the above cases held. |
| |
| else |
| raise Program_Error; |
| end if; |
| |
| exception |
| when RE_Not_Available => |
| return Empty; |
| end Get_Simple_Init_Val; |
| |
| ------------------------------ |
| -- Has_New_Non_Standard_Rep -- |
| ------------------------------ |
| |
| function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is |
| begin |
| if not Is_Derived_Type (T) then |
| return Has_Non_Standard_Rep (T) |
| or else Has_Non_Standard_Rep (Root_Type (T)); |
| |
| -- If Has_Non_Standard_Rep is not set on the derived type, the |
| -- representation is fully inherited. |
| |
| elsif not Has_Non_Standard_Rep (T) then |
| return False; |
| |
| else |
| return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T)); |
| |
| -- May need a more precise check here: the First_Rep_Item may be a |
| -- stream attribute, which does not affect the representation of the |
| -- type ??? |
| |
| end if; |
| end Has_New_Non_Standard_Rep; |
| |
| ---------------------- |
| -- Inline_Init_Proc -- |
| ---------------------- |
| |
| function Inline_Init_Proc (Typ : Entity_Id) return Boolean is |
| begin |
| -- The initialization proc of protected records is not worth inlining. |
| -- In addition, when compiled for another unit for inlining purposes, |
| -- it may make reference to entities that have not been elaborated yet. |
| -- The initialization proc of records that need finalization contains |
| -- a nested clean-up procedure that makes it impractical to inline as |
| -- well, except for simple controlled types themselves. And similar |
| -- considerations apply to task types. |
| |
| if Is_Concurrent_Type (Typ) then |
| return False; |
| |
| elsif Needs_Finalization (Typ) and then not Is_Controlled (Typ) then |
| return False; |
| |
| elsif Has_Task (Typ) then |
| return False; |
| |
| else |
| return True; |
| end if; |
| end Inline_Init_Proc; |
| |
| ---------------- |
| -- In_Runtime -- |
| ---------------- |
| |
| function In_Runtime (E : Entity_Id) return Boolean is |
| S1 : Entity_Id; |
| |
| begin |
| S1 := Scope (E); |
| while Scope (S1) /= Standard_Standard loop |
| S1 := Scope (S1); |
| end loop; |
| |
| return Is_RTU (S1, System) or else Is_RTU (S1, Ada); |
| end In_Runtime; |
| |
| package body Initialization_Control is |
| |
| ------------------------ |
| -- Requires_Late_Init -- |
| ------------------------ |
| |
| function Requires_Late_Init |
| (Decl : Node_Id; |
| Rec_Type : Entity_Id) return Boolean |
| is |
| References_Current_Instance : Boolean := False; |
| Has_Access_Discriminant : Boolean := False; |
| Has_Internal_Call : Boolean := False; |
| |
| function Find_Access_Discriminant |
| (N : Node_Id) return Traverse_Result; |
| -- Look for a name denoting an access discriminant |
| |
| function Find_Current_Instance |
| (N : Node_Id) return Traverse_Result; |
| -- Look for a reference to the current instance of the type |
| |
| function Find_Internal_Call |
| (N : Node_Id) return Traverse_Result; |
| -- Look for an internal protected function call |
| |
| ------------------------------ |
| -- Find_Access_Discriminant -- |
| ------------------------------ |
| |
| function Find_Access_Discriminant |
| (N : Node_Id) return Traverse_Result is |
| begin |
| if Is_Entity_Name (N) |
| and then Denotes_Discriminant (N) |
| and then Is_Access_Type (Etype (N)) |
| then |
| Has_Access_Discriminant := True; |
| return Abandon; |
| else |
| return OK; |
| end if; |
| end Find_Access_Discriminant; |
| |
| --------------------------- |
| -- Find_Current_Instance -- |
| --------------------------- |
| |
| function Find_Current_Instance |
| (N : Node_Id) return Traverse_Result is |
| begin |
| if Is_Entity_Name (N) |
| and then Present (Entity (N)) |
| and then Is_Current_Instance (N) |
| then |
| References_Current_Instance := True; |
| return Abandon; |
| else |
| return OK; |
| end if; |
| end Find_Current_Instance; |
| |
| ------------------------ |
| -- Find_Internal_Call -- |
| ------------------------ |
| |
| function Find_Internal_Call (N : Node_Id) return Traverse_Result is |
| |
| function Call_Scope (N : Node_Id) return Entity_Id; |
| -- Return the scope enclosing a given call node N |
| |
| ---------------- |
| -- Call_Scope -- |
| ---------------- |
| |
| function Call_Scope (N : Node_Id) return Entity_Id is |
| Nam : constant Node_Id := Name (N); |
| begin |
| if Nkind (Nam) = N_Selected_Component then |
| return Scope (Entity (Prefix (Nam))); |
| else |
| return Scope (Entity (Nam)); |
| end if; |
| end Call_Scope; |
| |
| begin |
| if Nkind (N) = N_Function_Call |
| and then Call_Scope (N) |
| = Corresponding_Concurrent_Type (Rec_Type) |
| then |
| Has_Internal_Call := True; |
| return Abandon; |
| else |
| return OK; |
| end if; |
| end Find_Internal_Call; |
| |
| procedure Search_Access_Discriminant is new |
| Traverse_Proc (Find_Access_Discriminant); |
| |
| procedure Search_Current_Instance is new |
| Traverse_Proc (Find_Current_Instance); |
| |
| procedure Search_Internal_Call is new |
| Traverse_Proc (Find_Internal_Call); |
| |
| -- Start of processing for Requires_Late_Init |
| |
| begin |
| -- A component of an object is said to require late initialization |
| -- if: |
| |
| -- it has an access discriminant value constrained by a per-object |
| -- expression; |
| |
| if Has_Access_Constraint (Defining_Identifier (Decl)) |
| and then No (Expression (Decl)) |
| then |
| return True; |
| |
| elsif Present (Expression (Decl)) then |
| |
| -- it has an initialization expression that includes a name |
| -- denoting an access discriminant; |
| |
| Search_Access_Discriminant (Expression (Decl)); |
| |
| if Has_Access_Discriminant then |
| return True; |
| end if; |
| |
| -- or it has an initialization expression that includes a |
| -- reference to the current instance of the type either by |
| -- name... |
| |
| Search_Current_Instance (Expression (Decl)); |
| |
| if References_Current_Instance then |
| return True; |
| end if; |
| |
| -- ...or implicitly as the target object of a call. |
| |
| if Is_Protected_Record_Type (Rec_Type) then |
| Search_Internal_Call (Expression (Decl)); |
| |
| if Has_Internal_Call then |
| return True; |
| end if; |
| end if; |
| end if; |
| |
| return False; |
| end Requires_Late_Init; |
| |
| ----------------------------- |
| -- Has_Late_Init_Component -- |
| ----------------------------- |
| |
| function Has_Late_Init_Component |
| (Tagged_Rec_Type : Entity_Id) return Boolean |
| is |
| Comp_Id : Entity_Id := |
| First_Component (Implementation_Base_Type (Tagged_Rec_Type)); |
| begin |
| while Present (Comp_Id) loop |
| if Requires_Late_Init (Decl => Parent (Comp_Id), |
| Rec_Type => Tagged_Rec_Type) |
| then |
| return True; -- found a component that requires late init |
| |
| elsif Chars (Comp_Id) = Name_uParent |
| and then Has_Late_Init_Component (Etype (Comp_Id)) |
| then |
| return True; -- an ancestor type has a late init component |
| end if; |
| |
| Next_Component (Comp_Id); |
| end loop; |
| |
| return False; |
| end Has_Late_Init_Component; |
| |
| ------------------------ |
| -- Tag_Init_Condition -- |
| ------------------------ |
| |
| function Tag_Init_Condition |
| (Loc : Source_Ptr; |
| Init_Control_Formal : Entity_Id) return Node_Id is |
| begin |
| return Make_Op_Eq (Loc, |
| New_Occurrence_Of (Init_Control_Formal, Loc), |
| Make_Mode_Literal (Loc, Full_Init)); |
| end Tag_Init_Condition; |
| |
| -------------------------- |
| -- Early_Init_Condition -- |
| -------------------------- |
| |
| function Early_Init_Condition |
| (Loc : Source_Ptr; |
| Init_Control_Formal : Entity_Id) return Node_Id is |
| begin |
| return Make_Op_Ne (Loc, |
| New_Occurrence_Of (Init_Control_Formal, Loc), |
| Make_Mode_Literal (Loc, Late_Init_Only)); |
| end Early_Init_Condition; |
| |
| ------------------------- |
| -- Late_Init_Condition -- |
| ------------------------- |
| |
| function Late_Init_Condition |
| (Loc : Source_Ptr; |
| Init_Control_Formal : Entity_Id) return Node_Id is |
| begin |
| return Make_Op_Ne (Loc, |
| New_Occurrence_Of (Init_Control_Formal, Loc), |
| Make_Mode_Literal (Loc, Early_Init_Only)); |
| end Late_Init_Condition; |
| |
| end Initialization_Control; |
| |
| ---------------------------- |
| -- Initialization_Warning -- |
| ---------------------------- |
| |
| procedure Initialization_Warning (E : Entity_Id) is |
| Warning_Needed : Boolean; |
| |
| begin |
| Warning_Needed := False; |
| |
| if Ekind (Current_Scope) = E_Package |
| and then Static_Elaboration_Desired (Current_Scope) |
| then |
| if Is_Type (E) then |
| if Is_Record_Type (E) then |
| if Has_Discriminants (E) |
| or else Is_Limited_Type (E) |
| or else Has_Non_Standard_Rep (E) |
| then |
| Warning_Needed := True; |
| |
| else |
| -- Verify that at least one component has an initialization |
| -- expression. No need for a warning on a type if all its |
| -- components have no initialization. |
| |
| declare |
| Comp : Entity_Id; |
| |
| begin |
| Comp := First_Component (E); |
| while Present (Comp) loop |
| pragma Assert |
| (Nkind (Parent (Comp)) = N_Component_Declaration); |
| |
| if Present (Expression (Parent (Comp))) then |
| Warning_Needed := True; |
| exit; |
| end if; |
| |
| Next_Component (Comp); |
| end loop; |
| end; |
| end if; |
| |
| if Warning_Needed then |
| Error_Msg_N |
| ("objects of the type cannot be initialized statically " |
| & "by default??", Parent (E)); |
| end if; |
| end if; |
| |
| else |
| Error_Msg_N ("object cannot be initialized statically??", E); |
| end if; |
| end if; |
| end Initialization_Warning; |
| |
| ------------------ |
| -- Init_Formals -- |
| ------------------ |
| |
| function Init_Formals (Typ : Entity_Id; Proc_Id : Entity_Id) return List_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Unc_Arr : constant Boolean := |
| Is_Array_Type (Typ) and then not Is_Constrained (Typ); |
| With_Prot : constant Boolean := |
| Has_Protected (Typ) |
| or else (Is_Record_Type (Typ) |
| and then Is_Protected_Record_Type (Typ)); |
| With_Task : constant Boolean := |
| not Global_No_Tasking |
| and then |
| (Has_Task (Typ) |
| or else (Is_Record_Type (Typ) |
| and then Is_Task_Record_Type (Typ))); |
| Formals : List_Id; |
| |
| begin |
| -- The first parameter is always _Init : [in] out Typ. Note that we need |
| -- it to be in/out in the case of an unconstrained array, because of the |
| -- need to have the bounds, and in the case of protected or task record |
| -- value, because there are default record fields 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 => Unc_Arr or else With_Prot or else With_Task, |
| Out_Present => True, |
| Parameter_Type => New_Occurrence_Of (Typ, Loc))); |
| |
| -- For task record value, or type that contains tasks, add two more |
| -- formals, _Master : Master_Id and _Chain : in out Activation_Chain |
| -- We also add these parameters for the task record type case. |
| |
| if With_Task then |
| Append_To (Formals, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uMaster), |
| Parameter_Type => |
| New_Occurrence_Of (Standard_Integer, Loc))); |
| |
| Set_Has_Master_Entity (Proc_Id); |
| |
| -- Add _Chain (not done for sequential elaboration policy, see |
| -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). |
| |
| if Partition_Elaboration_Policy /= 'S' then |
| Append_To (Formals, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uChain), |
| In_Present => True, |
| Out_Present => True, |
| Parameter_Type => |
| New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))); |
| end if; |
| |
| Append_To (Formals, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uTask_Name), |
| In_Present => True, |
| Parameter_Type => New_Occurrence_Of (Standard_String, Loc))); |
| end if; |
| |
| -- Due to certain edge cases such as arrays with null-excluding |
| -- components being built with the secondary stack it becomes necessary |
| -- to add a formal to the Init_Proc which controls whether we raise |
| -- Constraint_Errors on generated calls for internal object |
| -- declarations. |
| |
| if Needs_Conditional_Null_Excluding_Check (Typ) then |
| Append_To (Formals, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, |
| New_External_Name (Chars |
| (Component_Type (Typ)), "_skip_null_excluding_check")), |
| Expression => New_Occurrence_Of (Standard_False, Loc), |
| In_Present => True, |
| Parameter_Type => |
| New_Occurrence_Of (Standard_Boolean, Loc))); |
| end if; |
| |
| return Formals; |
| |
| exception |
| when RE_Not_Available => |
| return Empty_List; |
| end Init_Formals; |
| |
| ------------------------- |
| -- Init_Secondary_Tags -- |
| ------------------------- |
| |
| procedure Init_Secondary_Tags |
| (Typ : Entity_Id; |
| Target : Node_Id; |
| Init_Tags_List : List_Id; |
| Stmts_List : List_Id; |
| Fixed_Comps : Boolean := True; |
| Variable_Comps : Boolean := True) |
| is |
| Loc : constant Source_Ptr := Sloc (Target); |
| |
| -- Inherit the C++ tag of the secondary dispatch table of Typ associated |
| -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. |
| |
| procedure Initialize_Tag |
| (Typ : Entity_Id; |
| Iface : Entity_Id; |
| Tag_Comp : Entity_Id; |
| Iface_Tag : Node_Id); |
| -- Initialize the tag of the secondary dispatch table of Typ associated |
| -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. |
| -- Compiling under the CPP full ABI compatibility mode, if the ancestor |
| -- of Typ CPP tagged type we generate code to inherit the contents of |
| -- the dispatch table directly from the ancestor. |
| |
| -------------------- |
| -- Initialize_Tag -- |
| -------------------- |
| |
| procedure Initialize_Tag |
| (Typ : Entity_Id; |
| Iface : Entity_Id; |
| Tag_Comp : Entity_Id; |
| Iface_Tag : Node_Id) |
| is |
| Comp_Typ : Entity_Id; |
| Offset_To_Top_Comp : Entity_Id := Empty; |
| |
| begin |
| -- Initialize pointer to secondary DT associated with the interface |
| |
| if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then |
| Append_To (Init_Tags_List, |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => New_Copy_Tree (Target), |
| Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)), |
| Expression => |
| New_Occurrence_Of (Iface_Tag, Loc))); |
| end if; |
| |
| Comp_Typ := Scope (Tag_Comp); |
| |
| -- Initialize the entries of the table of interfaces. We generate a |
| -- different call when the parent of the type has variable size |
| -- components. |
| |
| if Comp_Typ /= Etype (Comp_Typ) |
| and then Is_Variable_Size_Record (Etype (Comp_Typ)) |
| and then Chars (Tag_Comp) /= Name_uTag |
| then |
| pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp))); |
| |
| -- Issue error if Set_Dynamic_Offset_To_Top is not available in a |
| -- configurable run-time environment. |
| |
| if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then |
| Error_Msg_CRT |
| ("variable size record with interface types", Typ); |
| return; |
| end if; |
| |
| -- Generate: |
| -- Set_Dynamic_Offset_To_Top |
| -- (This => Init, |
| -- Prim_T => Typ'Tag, |
| -- Interface_T => Iface'Tag, |
| -- Offset_Value => n, |
| -- Offset_Func => Fn'Unrestricted_Access) |
| |
| Append_To (Stmts_List, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Set_Dynamic_Offset_To_Top), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Copy_Tree (Target), |
| Attribute_Name => Name_Address), |
| |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Occurrence_Of |
| (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)), |
| |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Occurrence_Of |
| (Node (First_Elmt (Access_Disp_Table (Iface))), |
| Loc)), |
| |
| Unchecked_Convert_To |
| (RTE (RE_Storage_Offset), |
| Make_Op_Minus (Loc, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => New_Copy_Tree (Target), |
| Selector_Name => |
| New_Occurrence_Of (Tag_Comp, Loc)), |
| Attribute_Name => Name_Position))), |
| |
| Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of |
| (DT_Offset_To_Top_Func (Tag_Comp), Loc), |
| Attribute_Name => Name_Unrestricted_Access))))); |
| |
| -- In this case the next component stores the value of the offset |
| -- to the top. |
| |
| Offset_To_Top_Comp := Next_Entity (Tag_Comp); |
| pragma Assert (Present (Offset_To_Top_Comp)); |
| |
| Append_To (Init_Tags_List, |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => New_Copy_Tree (Target), |
| Selector_Name => |
| New_Occurrence_Of (Offset_To_Top_Comp, Loc)), |
| |
| Expression => |
| Make_Op_Minus (Loc, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => New_Copy_Tree (Target), |
| Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)), |
| Attribute_Name => Name_Position)))); |
| |
| -- Normal case: No discriminants in the parent type |
| |
| else |
| -- Don't need to set any value if the offset-to-top field is |
| -- statically set or if this interface shares the primary |
| -- dispatch table. |
| |
| if not Building_Static_Secondary_DT (Typ) |
| and then not Is_Ancestor (Iface, Typ, Use_Full_View => True) |
| then |
| Append_To (Stmts_List, |
| Build_Set_Static_Offset_To_Top (Loc, |
| Iface_Tag => New_Occurrence_Of (Iface_Tag, Loc), |
| Offset_Value => |
| Unchecked_Convert_To (RTE (RE_Storage_Offset), |
| Make_Op_Minus (Loc, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => New_Copy_Tree (Target), |
| Selector_Name => |
| New_Occurrence_Of (Tag_Comp, Loc)), |
| Attribute_Name => Name_Position))))); |
| end if; |
| |
| -- Generate: |
| -- Register_Interface_Offset |
| -- (Prim_T => Typ'Tag, |
| -- Interface_T => Iface'Tag, |
| -- Is_Constant => True, |
| -- Offset_Value => n, |
| -- Offset_Func => null); |
| |
| if not Building_Static_Secondary_DT (Typ) |
| and then RTE_Available (RE_Register_Interface_Offset) |
| then |
| Append_To (Stmts_List, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Register_Interface_Offset), Loc), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Occurrence_Of |
| (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)), |
| |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Occurrence_Of |
| (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)), |
| |
| New_Occurrence_Of (Standard_True, Loc), |
| |
| Unchecked_Convert_To (RTE (RE_Storage_Offset), |
| Make_Op_Minus (Loc, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => New_Copy_Tree (Target), |
| Selector_Name => |
| New_Occurrence_Of (Tag_Comp, Loc)), |
| Attribute_Name => Name_Position))), |
| |
| Make_Null (Loc)))); |
| end if; |
| end if; |
| end Initialize_Tag; |
| |
| -- Local variables |
| |
| Full_Typ : Entity_Id; |
| Ifaces_List : Elist_Id; |
| Ifaces_Comp_List : Elist_Id; |
| Ifaces_Tag_List : Elist_Id; |
| Iface_Elmt : Elmt_Id; |
| Iface_Comp_Elmt : Elmt_Id; |
| Iface_Tag_Elmt : Elmt_Id; |
| Tag_Comp : Node_Id; |
| In_Variable_Pos : Boolean; |
| |
| -- Start of processing for Init_Secondary_Tags |
| |
| begin |
| -- Handle private types |
| |
| if Present (Full_View (Typ)) then |
| Full_Typ := Full_View (Typ); |
| else |
| Full_Typ := Typ; |
| end if; |
| |
| Collect_Interfaces_Info |
| (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List); |
| |
| Iface_Elmt := First_Elmt (Ifaces_List); |
| Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); |
| Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List); |
| while Present (Iface_Elmt) loop |
| Tag_Comp := Node (Iface_Comp_Elmt); |
| |
| -- Check if parent of record type has variable size components |
| |
| In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp)) |
| and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp))); |
| |
| -- If we are compiling under the CPP full ABI compatibility mode and |
| -- the ancestor is a CPP_Pragma tagged type then we generate code to |
| -- initialize the secondary tag components from tags that reference |
| -- secondary tables filled with copy of parent slots. |
| |
| if Is_CPP_Class (Root_Type (Full_Typ)) then |
| |
| -- Reject interface components located at variable offset in |
| -- C++ derivations. This is currently unsupported. |
| |
| if not Fixed_Comps and then In_Variable_Pos then |
| |
| -- Locate the first dynamic component of the record. Done to |
| -- improve the text of the warning. |
| |
| declare |
| Comp : Entity_Id; |
| Comp_Typ : Entity_Id; |
| |
| begin |
| Comp := First_Entity (Typ); |
| while Present (Comp) loop |
| Comp_Typ := Etype (Comp); |
| |
| if Ekind (Comp) /= E_Discriminant |
| and then not Is_Tag (Comp) |
| then |
| exit when |
| (Is_Record_Type (Comp_Typ) |
| and then |
| Is_Variable_Size_Record (Base_Type (Comp_Typ))) |
| or else |
| (Is_Array_Type (Comp_Typ) |
| and then Is_Variable_Size_Array (Comp_Typ)); |
| end if; |
| |
| Next_Entity (Comp); |
| end loop; |
| |
| pragma Assert (Present (Comp)); |
| |
| -- Move this check to sem??? |
| Error_Msg_Node_2 := Comp; |
| Error_Msg_NE |
| ("parent type & with dynamic component & cannot be parent" |
| & " of 'C'P'P derivation if new interfaces are present", |
| Typ, Scope (Original_Record_Component (Comp))); |
| |
| Error_Msg_Sloc := |
| Sloc (Scope (Original_Record_Component (Comp))); |
| Error_Msg_NE |
| ("type derived from 'C'P'P type & defined #", |
| Typ, Scope (Original_Record_Component (Comp))); |
| |
| -- Avoid duplicated warnings |
| |
| exit; |
| end; |
| |
| -- Initialize secondary tags |
| |
| else |
| Initialize_Tag |
| (Typ => Full_Typ, |
| Iface => Node (Iface_Elmt), |
| Tag_Comp => Tag_Comp, |
| Iface_Tag => Node (Iface_Tag_Elmt)); |
| end if; |
| |
| -- Otherwise generate code to initialize the tag |
| |
| else |
| if (In_Variable_Pos and then Variable_Comps) |
| or else (not In_Variable_Pos and then Fixed_Comps) |
| then |
| Initialize_Tag |
| (Typ => Full_Typ, |
| Iface => Node (Iface_Elmt), |
| Tag_Comp => Tag_Comp, |
| Iface_Tag => Node (Iface_Tag_Elmt)); |
| end if; |
| end if; |
| |
| Next_Elmt (Iface_Elmt); |
| Next_Elmt (Iface_Comp_Elmt); |
| Next_Elmt (Iface_Tag_Elmt); |
| end loop; |
| end Init_Secondary_Tags; |
| |
| ---------------------------- |
| -- Is_Null_Statement_List -- |
| ---------------------------- |
| |
| function Is_Null_Statement_List (Stmts : List_Id) return Boolean is |
| Stmt : Node_Id; |
| |
| begin |
| -- We must skip SCIL nodes because they may have been added to the list |
| -- by Insert_Actions. |
| |
| Stmt := First_Non_SCIL_Node (Stmts); |
| while Present (Stmt) loop |
| if Nkind (Stmt) = N_Case_Statement then |
| declare |
| Alt : Node_Id; |
| begin |
| Alt := First (Alternatives (Stmt)); |
| while Present (Alt) loop |
| if not Is_Null_Statement_List (Statements (Alt)) then |
| return False; |
| end if; |
| |
| Next (Alt); |
| end loop; |
| end; |
| |
| elsif Nkind (Stmt) /= N_Null_Statement then |
| return False; |
| end if; |
| |
| Stmt := Next_Non_SCIL_Node (Stmt); |
| end loop; |
| |
| return True; |
| end Is_Null_Statement_List; |
| |
| ---------------------------------------- |
| -- Make_Controlling_Function_Wrappers -- |
| ---------------------------------------- |
| |
| procedure Make_Controlling_Function_Wrappers |
| (Tag_Typ : Entity_Id; |
| Decl_List : out List_Id; |
| Body_List : out List_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Tag_Typ); |
| |
| function Make_Wrapper_Specification (Subp : Entity_Id) return Node_Id; |
| -- Returns a function specification with the same profile as Subp |
| |
| -------------------------------- |
| -- Make_Wrapper_Specification -- |
| -------------------------------- |
| |
| function Make_Wrapper_Specification (Subp : Entity_Id) return Node_Id is |
| begin |
| return |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => |
| Make_Defining_Identifier (Loc, |
| Chars => Chars (Subp)), |
| Parameter_Specifications => |
| Copy_Parameter_List (Subp), |
| Result_Definition => |
| New_Occurrence_Of (Etype (Subp), Loc)); |
| end Make_Wrapper_Specification; |
| |
| Prim_Elmt : Elmt_Id; |
| Subp : Entity_Id; |
| Actual_List : List_Id; |
| Formal : Entity_Id; |
| Par_Formal : Entity_Id; |
| Ext_Aggr : Node_Id; |
| Formal_Node : Node_Id; |
| Func_Body : Node_Id; |
| Func_Decl : Node_Id; |
| Func_Id : Entity_Id; |
| |
| -- Start of processing for Make_Controlling_Function_Wrappers |
| |
| begin |
| Decl_List := New_List; |
| Body_List := New_List; |
| |
| Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); |
| while Present (Prim_Elmt) loop |
| Subp := Node (Prim_Elmt); |
| |
| -- If a primitive function with a controlling result of the type has |
| -- not been overridden by the user, then we must create a wrapper |
| -- function here that effectively overrides it and invokes the |
| -- (non-abstract) parent function. This can only occur for a null |
| -- extension. Note that functions with anonymous controlling access |
| -- results don't qualify and must be overridden. We also exclude |
| -- Input attributes, since each type will have its own version of |
| -- Input constructed by the expander. The test for Comes_From_Source |
| -- is needed to distinguish inherited operations from renamings |
| -- (which also have Alias set). We exclude internal entities with |
| -- Interface_Alias to avoid generating duplicated wrappers since |
| -- the primitive which covers the interface is also available in |
| -- the list of primitive operations. |
| |
| -- The function may be abstract, or require_Overriding may be set |
| -- for it, because tests for null extensions may already have reset |
| -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not |
| -- set, functions that need wrappers are recognized by having an |
| -- alias that returns the parent type. |
| |
| if Comes_From_Source (Subp) |
| or else No (Alias (Subp)) |
| or else Present (Interface_Alias (Subp)) |
| or else Ekind (Subp) /= E_Function |
| or else not Has_Controlling_Result (Subp) |
| or else Is_Access_Type (Etype (Subp)) |
| or else Is_Abstract_Subprogram (Alias (Subp)) |
| or else Is_TSS (Subp, TSS_Stream_Input) |
| then |
| goto Next_Prim; |
| |
| elsif Is_Abstract_Subprogram (Subp) |
| or else Requires_Overriding (Subp) |
| or else |
| (Is_Null_Extension (Etype (Subp)) |
| and then Etype (Alias (Subp)) /= Etype (Subp)) |
| then |
| -- If there is a non-overloadable homonym in the current |
| -- scope, the implicit declaration remains invisible. |
| -- We check the current entity with the same name, or its |
| -- homonym in case the derivation takes place after the |
| -- hiding object declaration. |
| |
| if Present (Current_Entity (Subp)) then |
| declare |
| Curr : constant Entity_Id := Current_Entity (Subp); |
| Prev : constant Entity_Id := Homonym (Curr); |
| begin |
| if (Comes_From_Source (Curr) |
| and then Scope (Curr) = Current_Scope |
| and then not Is_Overloadable (Curr)) |
| or else |
| (Present (Prev) |
| and then Comes_From_Source (Prev) |
| and then Scope (Prev) = Current_Scope |
| and then not Is_Overloadable (Prev)) |
| then |
| goto Next_Prim; |
| end if; |
| end; |
| end if; |
| |
| Func_Decl := |
| Make_Subprogram_Declaration (Loc, |
| Specification => Make_Wrapper_Specification (Subp)); |
| |
| 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 (Parameter_Specifications (Specification (Func_Decl))); |
| |
| if Present (Formal) then |
| Actual_List := New_List; |
| |
| while Present (Formal) loop |
| if Is_Controlling_Formal (Formal) then |
| Append_To (Actual_List, |
| Make_Type_Conversion (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (Etype (Par_Formal), Loc), |
| Expression => |
| New_Occurrence_Of |
| (Defining_Identifier (Formal_Node), Loc))); |
| else |
| Append_To |
| (Actual_List, |
| New_Occurrence_Of |
| (Defining_Identifier (Formal_Node), Loc)); |
| end if; |
| |
| Next_Formal (Formal); |
| Next_Formal (Par_Formal); |
| Next (Formal_Node); |
| end loop; |
| else |
| Actual_List := No_List; |
| end if; |
| |
| Ext_Aggr := |
| Make_Extension_Aggregate (Loc, |
| Ancestor_Part => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (Alias (Subp), Loc), |
| Parameter_Associations => Actual_List), |
| Null_Record_Present => True); |
| |
| -- GNATprove will use expression of an expression function as an |
| -- implicit postcondition. GNAT will not benefit from expression |
| -- function (and would struggle if we add an expression function |
| -- to freezing actions). |
| |
| if GNATprove_Mode then |
| Func_Body := |
| Make_Expression_Function (Loc, |
| Specification => |
| Make_Wrapper_Specification (Subp), |
| Expression => Ext_Aggr); |
| else |
| Func_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Wrapper_Specification (Subp), |
| Declarations => Empty_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => Ext_Aggr)))); |
| end if; |
| |
| Append_To (Body_List, Func_Body); |
| |
| -- Replace the inherited function with the wrapper function in the |
| -- primitive operations list. We add the minimum decoration needed |
| -- to override interface primitives. |
| |
| Func_Id := Defining_Unit_Name (Specification (Func_Decl)); |
| |
| Mutate_Ekind (Func_Id, E_Function); |
| Set_Is_Wrapper (Func_Id); |
| |
| -- Corresponding_Spec will be set again to the same value during |
| -- analysis, but we need this information earlier. |
| -- Expand_N_Freeze_Entity needs to know whether a subprogram body |
| -- is a wrapper's body in order to get check suppression right. |
| |
| Set_Corresponding_Spec (Func_Body, Func_Id); |
| |
| Override_Dispatching_Operation (Tag_Typ, Subp, New_Op => Func_Id); |
| end if; |
| |
| <<Next_Prim>> |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| end Make_Controlling_Function_Wrappers; |
| |
| ------------------ |
| -- Make_Eq_Body -- |
| ------------------ |
| |
| function Make_Eq_Body |
| (Typ : Entity_Id; |
| Eq_Name : Name_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Parent (Typ)); |
| Decl : Node_Id; |
| Def : constant Node_Id := Parent (Typ); |
| Stmts : constant List_Id := New_List; |
| Variant_Case : Boolean := Has_Discriminants (Typ); |
| Comps : Node_Id := Empty; |
| Typ_Def : Node_Id := Type_Definition (Def); |
| |
| begin |
| Decl := |
| Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Typ, |
| Name => Eq_Name, |
| Profile => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_X), |
| Parameter_Type => New_Occurrence_Of (Typ, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_Y), |
| Parameter_Type => New_Occurrence_Of (Typ, Loc))), |
| |
| Ret_Type => Standard_Boolean, |
| For_Body => True); |
| |
| if Variant_Case then |
| if Nkind (Typ_Def) = N_Derived_Type_Definition then |
| Typ_Def := Record_Extension_Part (Typ_Def); |
| end if; |
| |
| if Present (Typ_Def) then |
| Comps := Component_List (Typ_Def); |
| end if; |
| |
| Variant_Case := |
| Present (Comps) and then Present (Variant_Part (Comps)); |
| end if; |
| |
| if Variant_Case then |
| Append_To (Stmts, |
| Make_Eq_If (Typ, Discriminant_Specifications (Def))); |
| Append_List_To (Stmts, Make_Eq_Case (Typ, Comps)); |
| Append_To (Stmts, |
| Make_Simple_Return_Statement (Loc, |
| Expression => New_Occurrence_Of (Standard_True, Loc))); |
| |
| else |
| Append_To (Stmts, |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Expand_Record_Equality |
| (Typ, |
| Typ => Typ, |
| Lhs => Make_Identifier (Loc, Name_X), |
| Rhs => Make_Identifier (Loc, Name_Y)))); |
| end if; |
| |
| Set_Handled_Statement_Sequence |
| (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts)); |
| return Decl; |
| end Make_Eq_Body; |
| |
| ------------------ |
| -- Make_Eq_Case -- |
| ------------------ |
| |
| -- <Make_Eq_If shared components> |
| |
| -- case X.D1 is |
| -- when V1 => <Make_Eq_Case> on subcomponents |
| -- ... |
| -- when Vn => <Make_Eq_Case> on subcomponents |
| -- end case; |
| |
| function Make_Eq_Case |
| (E : Entity_Id; |
| CL : Node_Id; |
| Discrs : Elist_Id := New_Elmt_List) return List_Id |
| is |
| Loc : constant Source_Ptr := Sloc (E); |
| Result : constant List_Id := New_List; |
| Variant : Node_Id; |
| Alt_List : List_Id; |
| |
| function Corresponding_Formal (C : Node_Id) return Entity_Id; |
| -- Given the discriminant that controls a given variant of an unchecked |
| -- union, find the formal of the equality function that carries the |
| -- inferred value of the discriminant. |
| |
| function External_Name (E : Entity_Id) return Name_Id; |
| -- The value of a given discriminant is conveyed in the corresponding |
| -- formal parameter of the equality routine. The name of this formal |
| -- parameter carries a one-character suffix which is removed here. |
| |
| -------------------------- |
| -- Corresponding_Formal -- |
| -------------------------- |
| |
| function Corresponding_Formal (C : Node_Id) return Entity_Id is |
| Discr : constant Entity_Id := Entity (Name (Variant_Part (C))); |
| Elm : Elmt_Id; |
| |
| begin |
| Elm := First_Elmt (Discrs); |
| while Present (Elm) loop |
| if Chars (Discr) = External_Name (Node (Elm)) then |
| return Node (Elm); |
| end if; |
| |
| Next_Elmt (Elm); |
| end loop; |
| |
| -- A formal of the proper name must be found |
| |
| raise Program_Error; |
| end Corresponding_Formal; |
| |
| ------------------- |
| -- External_Name -- |
| ------------------- |
| |
| function External_Name (E : Entity_Id) return Name_Id is |
| begin |
| Get_Name_String (Chars (E)); |
| Name_Len := Name_Len - 1; |
| return Name_Find; |
| end External_Name; |
| |
| -- Start of processing for Make_Eq_Case |
| |
| begin |
| Append_To (Result, Make_Eq_If (E, Component_Items (CL))); |
| |
| if No (Variant_Part (CL)) then |
| return Result; |
| end if; |
| |
| Variant := First_Non_Pragma (Variants (Variant_Part (CL))); |
| |
| if No (Variant) then |
| return Result; |
| end if; |
| |
| Alt_List := New_List; |
| while Present (Variant) loop |
| Append_To (Alt_List, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)), |
| Statements => |
| Make_Eq_Case (E, Component_List (Variant), Discrs))); |
| Next_Non_Pragma (Variant); |
| end loop; |
| |
| -- If we have an Unchecked_Union, use one of the parameters of the |
| -- enclosing equality routine that captures the discriminant, to use |
| -- as the expression in the generated case statement. |
| |
| if Is_Unchecked_Union (E) then |
| Append_To (Result, |
| Make_Case_Statement (Loc, |
| Expression => |
| New_Occurrence_Of (Corresponding_Formal (CL), Loc), |
| Alternatives => Alt_List)); |
| |
| else |
| Append_To (Result, |
| Make_Case_Statement (Loc, |
| Expression => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_X), |
| Selector_Name => New_Copy (Name (Variant_Part (CL)))), |
| Alternatives => Alt_List)); |
| end if; |
| |
| return Result; |
| end Make_Eq_Case; |
| |
| ---------------- |
| -- Make_Eq_If -- |
| ---------------- |
| |
| -- Generates: |
| |
| -- if |
| -- X.C1 /= Y.C1 |
| -- or else |
| -- X.C2 /= Y.C2 |
| -- ... |
| -- then |
| -- return False; |
| -- end if; |
| |
| -- or a null statement if the list L is empty |
| |
| -- Equality may be user-defined for a given component type, in which case |
| -- a function call is constructed instead of an operator node. This is an |
| -- Ada 2012 change in the composability of equality for untagged composite |
| -- types. |
| |
| function Make_Eq_If |
| (E : Entity_Id; |
| L : List_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (E); |
| |
| C : Node_Id; |
| Cond : Node_Id; |
| Field_Name : Name_Id; |
| Next_Test : Node_Id; |
| Typ : Entity_Id; |
| |
| begin |
| if No (L) then |
| return Make_Null_Statement (Loc); |
| |
| else |
| Cond := Empty; |
| |
| C := First_Non_Pragma (L); |
| while Present (C) loop |
| Typ := Etype (Defining_Identifier (C)); |
| Field_Name := Chars (Defining_Identifier (C)); |
| |
| -- The tags must not be compared: they are not part of the value. |
| -- Ditto for parent interfaces because their equality operator is |
| -- abstract. |
| |
| -- Note also that in the following, we use Make_Identifier for |
| -- the component names. Use of New_Occurrence_Of to identify the |
| -- components would be incorrect because the wrong entities for |
| -- discriminants could be picked up in the private type case. |
| |
| if Field_Name = Name_uParent |
| and then Is_Interface (Typ) |
| then |
| null; |
| |
| elsif Field_Name /= Name_uTag then |
| declare |
| Lhs : constant Node_Id := |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_X), |
| Selector_Name => Make_Identifier (Loc, Field_Name)); |
| |
| Rhs : constant Node_Id := |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_Y), |
| Selector_Name => Make_Identifier (Loc, Field_Name)); |
| Eq_Call : Node_Id; |
| |
| begin |
| -- Build equality code with a user-defined operator, if |
| -- available, and with the predefined "=" otherwise. For |
| -- compatibility with older Ada versions, we also use the |
| -- predefined operation if the component-type equality is |
| -- abstract, rather than raising Program_Error. |
| |
| if Ada_Version < Ada_2012 then |
| Next_Test := Make_Op_Ne (Loc, Lhs, Rhs); |
| |
| else |
| Eq_Call := Build_Eq_Call (Typ, Loc, Lhs, Rhs); |
| |
| if No (Eq_Call) then |
| Next_Test := Make_Op_Ne (Loc, Lhs, Rhs); |
| |
| -- If a component has a defined abstract equality, its |
| -- application raises Program_Error on that component |
| -- and therefore on the current variant. |
| |
| elsif Nkind (Eq_Call) = N_Raise_Program_Error then |
| Set_Etype (Eq_Call, Standard_Boolean); |
| Next_Test := Make_Op_Not (Loc, Eq_Call); |
| |
| else |
| Next_Test := Make_Op_Not (Loc, Eq_Call); |
| end if; |
| end if; |
| end; |
| |
| Evolve_Or_Else (Cond, Next_Test); |
| end if; |
| |
| Next_Non_Pragma (C); |
| end loop; |
| |
| if No (Cond) then |
| return Make_Null_Statement (Loc); |
| |
| else |
| return |
| Make_Implicit_If_Statement (E, |
| Condition => Cond, |
| Then_Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => New_Occurrence_Of (Standard_False, Loc)))); |
| end if; |
| end if; |
| end Make_Eq_If; |
| |
| ------------------- |
| -- Make_Neq_Body -- |
| ------------------- |
| |
| function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is |
| |
| function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean; |
| -- Returns true if Prim is a renaming of an unresolved predefined |
| -- inequality operation. |
| |
| -------------------------------- |
| -- Is_Predefined_Neq_Renaming -- |
| -------------------------------- |
| |
| function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is |
| begin |
| return Chars (Prim) /= Name_Op_Ne |
| and then Present (Alias (Prim)) |
| and then Comes_From_Source (Prim) |
| and then Is_Intrinsic_Subprogram (Alias (Prim)) |
| and then Chars (Alias (Prim)) = Name_Op_Ne; |
| end Is_Predefined_Neq_Renaming; |
| |
| -- Local variables |
| |
| Loc : constant Source_Ptr := Sloc (Parent (Tag_Typ)); |
| Decl : Node_Id; |
| Eq_Prim : Entity_Id; |
| Left_Op : Entity_Id; |
| Renaming_Prim : Entity_Id; |
| Right_Op : Entity_Id; |
| Target : Entity_Id; |
| |
| -- Start of processing for Make_Neq_Body |
| |
| begin |
| -- For a call on a renaming of a dispatching subprogram that is |
| -- overridden, if the overriding occurred before the renaming, then |
| -- the body executed is that of the overriding declaration, even if the |
| -- overriding declaration is not visible at the place of the renaming; |
| -- otherwise, the inherited or predefined subprogram is called, see |
| -- (RM 8.5.4(8)). |
| |
| -- Stage 1: Search for a renaming of the inequality primitive and also |
| -- search for an overriding of the equality primitive located before the |
| -- renaming declaration. |
| |
| declare |
| Elmt : Elmt_Id; |
| Prim : Node_Id; |
| |
| begin |
| Eq_Prim := Empty; |
| Renaming_Prim := Empty; |
| |
| Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); |
| while Present (Elmt) loop |
| Prim := Node (Elmt); |
| |
| if Is_User_Defined_Equality (Prim) and then No (Alias (Prim)) then |
| if No (Renaming_Prim) then |
| pragma Assert (No (Eq_Prim)); |
| Eq_Prim := Prim; |
| end if; |
| |
| elsif Is_Predefined_Neq_Renaming (Prim) then |
| Renaming_Prim := Prim; |
| end if; |
| |
| Next_Elmt (Elmt); |
| end loop; |
| end; |
| |
| -- No further action needed if no renaming was found |
| |
| if No (Renaming_Prim) then |
| return Empty; |
| end if; |
| |
| -- Stage 2: Replace the renaming declaration by a subprogram declaration |
| -- (required to add its body) |
| |
| Decl := Parent (Parent (Renaming_Prim)); |
| Rewrite (Decl, |
| Make_Subprogram_Declaration (Loc, |
| Specification => Specification (Decl))); |
| Set_Analyzed (Decl); |
| |
| -- Remove the decoration of intrinsic renaming subprogram |
| |
| Set_Is_Intrinsic_Subprogram (Renaming_Prim, False); |
| Set_Convention (Renaming_Prim, Convention_Ada); |
| Set_Alias (Renaming_Prim, Empty); |
| Set_Has_Completion (Renaming_Prim, False); |
| |
| -- Stage 3: Build the corresponding body |
| |
| Left_Op := First_Formal (Renaming_Prim); |
| Right_Op := Next_Formal (Left_Op); |
| |
| Decl := |
| Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Tag_Typ, |
| Name => Chars (Renaming_Prim), |
| Profile => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Chars (Left_Op)), |
| Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Chars (Right_Op)), |
| Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), |
| |
| Ret_Type => Standard_Boolean, |
| For_Body => True); |
| |
| -- If the overriding of the equality primitive occurred before the |
| -- renaming, then generate: |
| |
| -- function <Neq_Name> (X : Y : Typ) return Boolean is |
| -- begin |
| -- return not Oeq (X, Y); |
| -- end; |
| |
| if Present (Eq_Prim) then |
| Target := Eq_Prim; |
| |
| -- Otherwise build a nested subprogram which performs the predefined |
| -- evaluation of the equality operator. That is, generate: |
| |
| -- function <Neq_Name> (X : Y : Typ) return Boolean is |
| -- function Oeq (X : Y) return Boolean is |
| -- begin |
| -- <<body of default implementation>> |
| -- end; |
| -- begin |
| -- return not Oeq (X, Y); |
| -- end; |
| |
| else |
| declare |
| Local_Subp : Node_Id; |
| begin |
| Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq); |
| Set_Declarations (Decl, New_List (Local_Subp)); |
| Target := Defining_Entity (Local_Subp); |
| end; |
| end if; |
| |
| Set_Handled_Statement_Sequence |
| (Decl, |
| Make_Handled_Sequence_Of_Statements (Loc, New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Op_Not (Loc, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (Target, Loc), |
| Parameter_Associations => New_List ( |
| Make_Identifier (Loc, Chars (Left_Op)), |
| Make_Identifier (Loc, Chars (Right_Op))))))))); |
| |
| return Decl; |
| end Make_Neq_Body; |
| |
| ------------------------------- |
| -- Make_Null_Procedure_Specs -- |
| ------------------------------- |
| |
| function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is |
| Decl_List : constant List_Id := New_List; |
| Loc : constant Source_Ptr := Sloc (Tag_Typ); |
| Formal : Entity_Id; |
| New_Param_Spec : Node_Id; |
| New_Spec : Node_Id; |
| Parent_Subp : Entity_Id; |
| Prim_Elmt : Elmt_Id; |
| Subp : Entity_Id; |
| |
| begin |
| Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); |
| while Present (Prim_Elmt) loop |
| Subp := Node (Prim_Elmt); |
| |
| -- If a null procedure inherited from an interface has not been |
| -- overridden, then we build a null procedure declaration to |
| -- override the inherited procedure. |
| |
| Parent_Subp := Alias (Subp); |
| |
| if Present (Parent_Subp) |
| and then Is_Null_Interface_Primitive (Parent_Subp) |
| then |
| -- The null procedure spec is copied from the inherited procedure, |
| -- except for the IS NULL (which must be added) and the overriding |
| -- indicators (which must be removed, if present). |
| |
| New_Spec := |
| Copy_Subprogram_Spec (Subprogram_Specification (Subp), Loc); |
| |
| Set_Null_Present (New_Spec, True); |
| Set_Must_Override (New_Spec, False); |
| Set_Must_Not_Override (New_Spec, False); |
| |
| Formal := First_Formal (Subp); |
| New_Param_Spec := First (Parameter_Specifications (New_Spec)); |
| |
| while Present (Formal) loop |
| |
| -- For controlling arguments we must change their parameter |
| -- type to reference the tagged type (instead of the interface |
| -- type). |
| |
| if Is_Controlling_Formal (Formal) then |
| if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier |
| then |
| Set_Parameter_Type (New_Param_Spec, |
| New_Occurrence_Of (Tag_Typ, Loc)); |
| |
| else pragma Assert |
| (Nkind (Parameter_Type (Parent (Formal))) = |
| N_Access_Definition); |
| Set_Subtype_Mark (Parameter_Type (New_Param_Spec), |
| New_Occurrence_Of (Tag_Typ, Loc)); |
| end if; |
| end if; |
| |
| Next_Formal (Formal); |
| Next (New_Param_Spec); |
| end loop; |
| |
| Append_To (Decl_List, |
| Make_Subprogram_Declaration (Loc, |
| Specification => New_Spec)); |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| |
| return Decl_List; |
| end Make_Null_Procedure_Specs; |
| |
| --------------------------------------- |
| -- Make_Predefined_Primitive_Eq_Spec -- |
| --------------------------------------- |
| |
| procedure Make_Predefined_Primitive_Eq_Spec |
| (Tag_Typ : Entity_Id; |
| Predef_List : List_Id; |
| Renamed_Eq : out Entity_Id) |
| is |
| function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean; |
| -- Returns true if Prim is a renaming of an unresolved predefined |
| -- equality operation. |
| |
| ------------------------------- |
| -- Is_Predefined_Eq_Renaming -- |
| ------------------------------- |
| |
| function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is |
| begin |
| return Chars (Prim) /= Name_Op_Eq |
| and then Present (Alias (Prim)) |
| and then Comes_From_Source (Prim) |
| and then Is_Intrinsic_Subprogram (Alias (Prim)) |
| and then Chars (Alias (Prim)) = Name_Op_Eq; |
| end Is_Predefined_Eq_Renaming; |
| |
| -- Local variables |
| |
| Loc : constant Source_Ptr := Sloc (Tag_Typ); |
| |
| Eq_Name : Name_Id := Name_Op_Eq; |
| Eq_Needed : Boolean := True; |
| Eq_Spec : Node_Id; |
| Prim : Elmt_Id; |
| |
| Has_Predef_Eq_Renaming : Boolean := False; |
| -- Set to True if Tag_Typ has a primitive that renames the predefined |
| -- equality operator. Used to implement (RM 8-5-4(8)). |
| |
| -- Start of processing for Make_Predefined_Primitive_Specs |
| |
| begin |
| Renamed_Eq := Empty; |
| |
| Prim := First_Elmt (Primitive_Operations (Tag_Typ)); |
| while Present (Prim) loop |
| |
| -- If a primitive is encountered that renames the predefined equality |
| -- operator before reaching any explicit equality primitive, then we |
| -- still need to create a predefined equality function, because calls |
| -- to it can occur via the renaming. A new name is created for the |
| -- equality to avoid conflicting with any user-defined equality. |
| -- (Note that this doesn't account for renamings of equality nested |
| -- within subpackages???) |
| |
| if Is_Predefined_Eq_Renaming (Node (Prim)) then |
| Has_Predef_Eq_Renaming := True; |
| Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); |
| |
| -- User-defined equality |
| |
| elsif Is_User_Defined_Equality (Node (Prim)) then |
| if No (Alias (Node (Prim))) |
| or else Nkind (Unit_Declaration_Node (Node (Prim))) = |
| N_Subprogram_Renaming_Declaration |
| then |
| Eq_Needed := False; |
| exit; |
| |
| -- If the parent is not an interface type and has an abstract |
| -- equality function explicitly defined in the sources, then the |
| -- inherited equality is abstract as well, and no body can be |
| -- created for it. |
| |
| elsif not Is_Interface (Etype (Tag_Typ)) |
| and then Present (Alias (Node (Prim))) |
| and then Comes_From_Source (Alias (Node (Prim))) |
| and then Is_Abstract_Subprogram (Alias (Node (Prim))) |
| then |
| Eq_Needed := False; |
| exit; |
| |
| -- If the type has an equality function corresponding with a |
| -- primitive defined in an interface type, the inherited equality |
| -- is abstract as well, and no body can be created for it. |
| |
| elsif Present (Alias (Node (Prim))) |
| and then Comes_From_Source (Ultimate_Alias (Node (Prim))) |
| and then |
| Is_Interface |
| (Find_Dispatching_Type (Ultimate_Alias (Node (Prim)))) |
| then |
| Eq_Needed := False; |
| exit; |
| end if; |
| end if; |
| |
| Next_Elmt (Prim); |
| end loop; |
| |
| -- If a renaming of predefined equality was found but there was no |
| -- user-defined equality (so Eq_Needed is still true), then set the name |
| -- back to Name_Op_Eq. But in the case where a user-defined equality was |
| -- located after such a renaming, then the predefined equality function |
| -- is still needed, so Eq_Needed must be set back to True. |
| |
| if Eq_Name /= Name_Op_Eq then |
| if Eq_Needed then |
| Eq_Name := Name_Op_Eq; |
| else |
| Eq_Needed := True; |
| end if; |
| end if; |
| |
| if Eq_Needed then |
| Eq_Spec := Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Tag_Typ, |
| Name => Eq_Name, |
| Profile => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_X), |
| Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_Y), |
| Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), |
| Ret_Type => Standard_Boolean); |
| Append_To (Predef_List, Eq_Spec); |
| |
| if Has_Predef_Eq_Renaming then |
| Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec)); |
| |
| Prim := First_Elmt (Primitive_Operations (Tag_Typ)); |
| while Present (Prim) loop |
| |
| -- Any renamings of equality that appeared before an overriding |
| -- equality must be updated to refer to the entity for the |
| -- predefined equality, otherwise calls via the renaming would |
| -- get incorrectly resolved to call the user-defined equality |
| -- function. |
| |
| if Is_Predefined_Eq_Renaming (Node (Prim)) then |
| Set_Alias (Node (Prim), Renamed_Eq); |
| |
| -- Exit upon encountering a user-defined equality |
| |
| elsif Chars (Node (Prim)) = Name_Op_Eq |
| and then No (Alias (Node (Prim))) |
| then |
| exit; |
| end if; |
| |
| Next_Elmt (Prim); |
| end loop; |
| end if; |
| end if; |
| end Make_Predefined_Primitive_Eq_Spec; |
| |
| ------------------------------------- |
| -- Make_Predefined_Primitive_Specs -- |
| ------------------------------------- |
| |
| procedure Make_Predefined_Primitive_Specs |
| (Tag_Typ : Entity_Id; |
| Predef_List : out List_Id; |
| Renamed_Eq : out Entity_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Tag_Typ); |
| Res : constant List_Id := New_List; |
| |
| use Exp_Put_Image; |
| |
| begin |
| Renamed_Eq := Empty; |
| |
| -- Spec of _Size |
| |
| Append_To (Res, Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Tag_Typ, |
| Name => Name_uSize, |
| Profile => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), |
| Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), |
| |
| Ret_Type => Standard_Long_Long_Integer)); |
| |
| -- Spec of Put_Image |
| |
| if (not No_Run_Time_Mode) |
| and then RTE_Available (RE_Root_Buffer_Type) |
| then |
| -- No_Run_Time_Mode implies that the declaration of Tag_Typ |
| -- (like any tagged type) will be rejected. Given this, avoid |
| -- cascading errors associated with the Tag_Typ's TSS_Put_Image |
| -- procedure. |
| |
| Append_To (Res, Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Tag_Typ, |
| Name => Make_TSS_Name (Tag_Typ, TSS_Put_Image), |
| Profile => Build_Put_Image_Profile (Loc, Tag_Typ))); |
| end if; |
| |
| -- Specs for dispatching stream attributes |
| |
| declare |
| Stream_Op_TSS_Names : |
| constant array (Positive range <>) of TSS_Name_Type := |
| (TSS_Stream_Read, |
| TSS_Stream_Write, |
| TSS_Stream_Input, |
| TSS_Stream_Output); |
| |
| begin |
| for Op in Stream_Op_TSS_Names'Range loop |
| if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then |
| Append_To (Res, |
| Predef_Stream_Attr_Spec (Loc, Tag_Typ, |
| Stream_Op_TSS_Names (Op))); |
| end if; |
| end loop; |
| end; |
| |
| -- Spec of "=" is expanded if the type is not limited and if a user |
| -- defined "=" was not already declared for the non-full view of a |
| -- private extension. |
| |
| if not Is_Limited_Type (Tag_Typ) then |
| Make_Predefined_Primitive_Eq_Spec (Tag_Typ, Res, Renamed_Eq); |
| |
| -- Spec for dispatching assignment |
| |
| Append_To (Res, Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Tag_Typ, |
| Name => Name_uAssign, |
| Profile => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), |
| Out_Present => True, |
| Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), |
| Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))))); |
| end if; |
| |
| -- Ada 2005: Generate declarations for the following primitive |
| -- operations for limited interfaces and synchronized types that |
| -- implement a limited interface. |
| |
| -- Disp_Asynchronous_Select |
| -- Disp_Conditional_Select |
| -- Disp_Get_Prim_Op_Kind |
| -- Disp_Get_Task_Id |
| -- Disp_Requeue |
| -- Disp_Timed_Select |
| |
| -- Disable the generation of these bodies if Ravenscar or ZFP is active |
| |
| if Ada_Version >= Ada_2005 |
| and then not Restriction_Active (No_Select_Statements) |
| and then RTE_Available (RE_Select_Specific_Data) |
| then |
| -- These primitives are defined abstract in interface types |
| |
| if Is_Interface (Tag_Typ) |
| and then Is_Limited_Record (Tag_Typ) |
| then |
| Append_To (Res, |
| Make_Abstract_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); |
| |
| Append_To (Res, |
| Make_Abstract_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Conditional_Select_Spec (Tag_Typ))); |
| |
| Append_To (Res, |
| Make_Abstract_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); |
| |
| Append_To (Res, |
| Make_Abstract_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Get_Task_Id_Spec (Tag_Typ))); |
| |
| Append_To (Res, |
| Make_Abstract_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Requeue_Spec (Tag_Typ))); |
| |
| Append_To (Res, |
| Make_Abstract_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Timed_Select_Spec (Tag_Typ))); |
| |
| -- If ancestor is an interface type, declare non-abstract primitives |
| -- to override the abstract primitives of the interface type. |
| |
| -- In VM targets we define these primitives in all root tagged types |
| -- that are not interface types. Done because in VM targets we don't |
| -- have secondary dispatch tables and any derivation of Tag_Typ may |
| -- cover limited interfaces (which always have these primitives since |
| -- they may be ancestors of synchronized interface types). |
| |
| elsif (not Is_Interface (Tag_Typ) |
| and then Is_Interface (Etype (Tag_Typ)) |
| and then Is_Limited_Record (Etype (Tag_Typ))) |
| or else |
| (Is_Concurrent_Record_Type (Tag_Typ) |
| and then Has_Interfaces (Tag_Typ)) |
| or else |
| (not Tagged_Type_Expansion |
| and then not Is_Interface (Tag_Typ) |
| and then Tag_Typ = Root_Type (Tag_Typ)) |
| then |
| Append_To (Res, |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); |
| |
| Append_To (Res, |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Conditional_Select_Spec (Tag_Typ))); |
| |
| Append_To (Res, |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); |
| |
| Append_To (Res, |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Get_Task_Id_Spec (Tag_Typ))); |
| |
| Append_To (Res, |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Requeue_Spec (Tag_Typ))); |
| |
| Append_To (Res, |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Disp_Timed_Select_Spec (Tag_Typ))); |
| end if; |
| end if; |
| |
| -- All tagged types receive their own Deep_Adjust and Deep_Finalize |
| -- regardless of whether they are controlled or may contain controlled |
| -- components. |
| |
| -- Do not generate the routines if finalization is disabled |
| |
| if Restriction_Active (No_Finalization) then |
| null; |
| |
| else |
| if not Is_Limited_Type (Tag_Typ) then |
| Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust)); |
| end if; |
| |
| Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize)); |
| end if; |
| |
| Predef_List := Res; |
| end Make_Predefined_Primitive_Specs; |
| |
| ------------------------- |
| -- Make_Tag_Assignment -- |
| ------------------------- |
| |
| function Make_Tag_Assignment (N : Node_Id) return Node_Id is |
| Loc : constant Source_Ptr := Sloc (N); |
| Def_If : constant Entity_Id := Defining_Identifier (N); |
| Expr : constant Node_Id := Expression (N); |
| Typ : constant Entity_Id := Etype (Def_If); |
| Full_Typ : constant Entity_Id := Underlying_Type (Typ); |
| |
| New_Ref : Node_Id; |
| |
| begin |
| -- This expansion activity is called during analysis |
| |
| if Is_Tagged_Type (Typ) |
| and then not Is_Class_Wide_Type (Typ) |
| and then not Is_CPP_Class (Typ) |
| and then Tagged_Type_Expansion |
| and then Nkind (Expr) /= N_Aggregate |
| and then (Nkind (Expr) /= N_Qualified_Expression |
| or else Nkind (Expression (Expr)) /= N_Aggregate) |
| then |
| New_Ref := |
| Make_Selected_Component (Loc, |
| Prefix => New_Occurrence_Of (Def_If, Loc), |
| Selector_Name => |
| New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc)); |
| |
| Set_Assignment_OK (New_Ref); |
| |
| return |
| Make_Assignment_Statement (Loc, |
| Name => New_Ref, |
| Expression => |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Occurrence_Of |
| (Node (First_Elmt (Access_Disp_Table (Full_Typ))), Loc))); |
| else |
| return Empty; |
| end if; |
| end Make_Tag_Assignment; |
| |
| ---------------------- |
| -- Predef_Deep_Spec -- |
| ---------------------- |
| |
| function Predef_Deep_Spec |
| (Loc : Source_Ptr; |
| Tag_Typ : Entity_Id; |
| Name : TSS_Name_Type; |
| For_Body : Boolean := False) return Node_Id |
| is |
| Formals : List_Id; |
| |
| begin |
| -- V : in out Tag_Typ |
| |
| Formals := New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), |
| In_Present => True, |
| Out_Present => True, |
| Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))); |
| |
| -- F : Boolean := True |
| |
| if Name = TSS_Deep_Adjust |
| or else Name = TSS_Deep_Finalize |
| then |
| Append_To (Formals, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_F), |
| Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), |
| Expression => New_Occurrence_Of (Standard_True, Loc))); |
| end if; |
| |
| return |
| Predef_Spec_Or_Body (Loc, |
| Name => Make_TSS_Name (Tag_Typ, Name), |
| Tag_Typ => Tag_Typ, |
| Profile => Formals, |
| For_Body => For_Body); |
| |
| exception |
| when RE_Not_Available => |
| return Empty; |
| end Predef_Deep_Spec; |
| |
| ------------------------- |
| -- Predef_Spec_Or_Body -- |
| ------------------------- |
| |
| function Predef_Spec_Or_Body |
| (Loc : Source_Ptr; |
| Tag_Typ : Entity_Id; |
| Name : Name_Id; |
| Profile : List_Id; |
| Ret_Type : Entity_Id := Empty; |
| For_Body : Boolean := False) return Node_Id |
| is |
| Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name); |
| Spec : Node_Id; |
| |
| begin |
| Set_Is_Public (Id, Is_Public (Tag_Typ)); |
| |
| -- The internal flag is set to mark these declarations because they have |
| -- specific properties. First, they are primitives even if they are not |
| -- defined in the type scope (the freezing point is not necessarily in |
| -- the same scope). Second, the predefined equality can be overridden by |
| -- a user-defined equality, no body will be generated in this case. |
| |
| Set_Is_Internal (Id); |
| |
| if not Debug_Generated_Code then |
| Set_Debug_Info_Off (Id); |
| end if; |
| |
| if No (Ret_Type) then |
| Spec := |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Id, |
| Parameter_Specifications => Profile); |
| else |
| Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Id, |
| Parameter_Specifications => Profile, |
| Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); |
| end if; |
| |
| -- Declare an abstract subprogram for primitive subprograms of an |
| -- interface type (except for "="). |
| |
| if Is_Interface (Tag_Typ) then |
| if Name /= Name_Op_Eq then |
| return Make_Abstract_Subprogram_Declaration (Loc, Spec); |
| |
| -- The equality function (if any) for an interface type is defined |
| -- to be nonabstract, so we create an expression function for it that |
| -- always returns False. Note that the function can never actually be |
| -- invoked because interface types are abstract, so there aren't any |
| -- objects of such types (and their equality operation will always |
| -- dispatch). |
| |
| else |
| return Make_Expression_Function |
| (Loc, Spec, New_Occurrence_Of (Standard_False, 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. |
| |
| elsif For_Body then |
| return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty); |
| |
| -- For the case of an Input attribute predefined for an abstract type, |
| -- generate an abstract specification. This will never be called, but we |
| -- need the slot allocated in the dispatching table so that attributes |
| -- typ'Class'Input and typ'Class'Output will work properly. |
| |
| elsif Is_TSS (Name, TSS_Stream_Input) |
| and then Is_Abstract_Type (Tag_Typ) |
| then |
| return Make_Abstract_Subprogram_Declaration (Loc, Spec); |
| |
| -- Normal spec case, where we return a subprogram declaration |
| |
| else |
| return Make_Subprogram_Declaration (Loc, Spec); |
| end if; |
| end Predef_Spec_Or_Body; |
| |
| ----------------------------- |
| -- Predef_Stream_Attr_Spec -- |
| ----------------------------- |
| |
| function Predef_Stream_Attr_Spec |
| (Loc : Source_Ptr; |
| Tag_Typ : Entity_Id; |
| Name : TSS_Name_Type) 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 => False); |
| end Predef_Stream_Attr_Spec; |
| |
| ---------------------------------- |
| -- Predefined_Primitive_Eq_Body -- |
| ---------------------------------- |
| |
| procedure Predefined_Primitive_Eq_Body |
| (Tag_Typ : Entity_Id; |
| Predef_List : List_Id; |
| Renamed_Eq : Entity_Id) |
| is |
| Decl : Node_Id; |
| Eq_Needed : Boolean; |
| Eq_Name : Name_Id; |
| Prim : Elmt_Id; |
| |
| begin |
| -- See if we have a predefined "=" operator |
| |
| if Present (Renamed_Eq) then |
| Eq_Needed := True; |
| Eq_Name := Chars (Renamed_Eq); |
| |
| -- If the parent is an interface type then it has defined all the |
| -- predefined primitives abstract and we need to check if the type |
| -- has some user defined "=" function which matches the profile of |
| -- the Ada predefined equality operator to avoid generating it. |
| |
| elsif Is_Interface (Etype (Tag_Typ)) then |
| Eq_Needed := True; |
| Eq_Name := Name_Op_Eq; |
| |
| Prim := First_Elmt (Primitive_Operations (Tag_Typ)); |
| while Present (Prim) loop |
| if Is_User_Defined_Equality (Node (Prim)) |
| and then not Is_Internal (Node (Prim)) |
| then |
| Eq_Needed := False; |
| Eq_Name := No_Name; |
| exit; |
| end if; |
| |
| Next_Elmt (Prim); |
| end loop; |
| |
| else |
| Eq_Needed := False; |
| Eq_Name := No_Name; |
| |
| Prim := First_Elmt (Primitive_Operations (Tag_Typ)); |
| while Present (Prim) loop |
| if Is_User_Defined_Equality (Node (Prim)) |
| and then Is_Internal (Node (Prim)) |
| then |
| Eq_Needed := True; |
| Eq_Name := Name_Op_Eq; |
| exit; |
| end if; |
| |
| Next_Elmt (Prim); |
| end loop; |
| end if; |
| |
| -- If equality is needed, we will have its name |
| |
| pragma Assert (Eq_Needed = Present (Eq_Name)); |
| |
| -- Body for equality |
| |
| if Eq_Needed then |
| Decl := Make_Eq_Body (Tag_Typ, Eq_Name); |
| Append_To (Predef_List, Decl); |
| end if; |
| |
| -- Body for inequality (if required) |
| |
| Decl := Make_Neq_Body (Tag_Typ); |
| |
| if Present (Decl) then |
| Append_To (Predef_List, Decl); |
| end if; |
| end Predefined_Primitive_Eq_Body; |
| |
| --------------------------------- |
| -- Predefined_Primitive_Bodies -- |
| --------------------------------- |
| |
| function Predefined_Primitive_Bodies |
| (Tag_Typ : Entity_Id; |
| Renamed_Eq : Entity_Id) return List_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Tag_Typ); |
| Res : constant List_Id := New_List; |
| Adj_Call : Node_Id; |
| Decl : Node_Id; |
| Fin_Call : Node_Id; |
| Ent : Entity_Id; |
| |
| pragma Warnings (Off, Ent); |
| |
| use Exp_Put_Image; |
| |
| begin |
| pragma Assert (not Is_Interface (Tag_Typ)); |
| |
| -- Body of _Size |
| |
| Decl := Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Tag_Typ, |
| Name => Name_uSize, |
| Profile => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), |
| Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), |
| |
| Ret_Type => Standard_Long_Long_Integer, |
| For_Body => True); |
| |
| Set_Handled_Statement_Sequence (Decl, |
| Make_Handled_Sequence_Of_Statements (Loc, New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Name_X), |
| Attribute_Name => Name_Size))))); |
| |
| Append_To (Res, Decl); |
| |
| -- Body of Put_Image |
| |
| if No (TSS (Tag_Typ, TSS_Put_Image)) |
| and then (not No_Run_Time_Mode) |
| and then RTE_Available (RE_Root_Buffer_Type) |
| then |
| Build_Record_Put_Image_Procedure (Loc, Tag_Typ, Decl, Ent); |
| Append_To (Res, Decl); |
| end if; |
| |
| -- Bodies for Dispatching stream IO routines. We need these only for |
| -- non-limited types (in the limited case there is no dispatching). |
| -- We also skip them if dispatching or finalization are not available |
| -- or if stream operations are prohibited by restriction No_Streams or |
| -- from use of pragma/aspect No_Tagged_Streams. |
| |
| if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read) |
| and then No (TSS (Tag_Typ, TSS_Stream_Read)) |
| then |
| Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent); |
| Append_To (Res, Decl); |
| end if; |
| |
| if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write) |
| and then No (TSS (Tag_Typ, TSS_Stream_Write)) |
| then |
| Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent); |
| Append_To (Res, Decl); |
| end if; |
| |
| -- Skip body of _Input for the abstract case, since the corresponding |
| -- spec is abstract (see Predef_Spec_Or_Body). |
| |
| if not Is_Abstract_Type (Tag_Typ) |
| and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input) |
| and then No (TSS (Tag_Typ, TSS_Stream_Input)) |
| then |
| Build_Record_Or_Elementary_Input_Function |
| (Loc, Tag_Typ, Decl, Ent); |
| Append_To (Res, Decl); |
| end if; |
| |
| if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output) |
| and then No (TSS (Tag_Typ, TSS_Stream_Output)) |
| then |
| Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent); |
| Append_To (Res, Decl); |
| end if; |
| |
| -- Ada 2005: Generate bodies for the following primitive operations for |
| -- limited interfaces and synchronized types that implement a limited |
| -- interface. |
| |
| -- disp_asynchronous_select |
| -- disp_conditional_select |
| -- disp_get_prim_op_kind |
| -- disp_get_task_id |
| -- disp_timed_select |
| |
| -- The interface versions will have null bodies |
| |
| -- Disable the generation of these bodies if Ravenscar or ZFP is active |
| |
| -- In VM targets we define these primitives in all root tagged types |
| -- that are not interface types. Done because in VM targets we don't |
| -- have secondary dispatch tables and any derivation of Tag_Typ may |
| -- cover limited interfaces (which always have these primitives since |
| -- they may be ancestors of synchronized interface types). |
| |
| if Ada_Version >= Ada_2005 |
| and then |
| ((Is_Interface (Etype (Tag_Typ)) |
| and then Is_Limited_Record (Etype (Tag_Typ))) |
| or else |
| (Is_Concurrent_Record_Type (Tag_Typ) |
| and then Has_Interfaces (Tag_Typ)) |
| or else |
| (not Tagged_Type_Expansion |
| and then Tag_Typ = Root_Type (Tag_Typ))) |
| and then not Restriction_Active (No_Select_Statements) |
| and then RTE_Available (RE_Select_Specific_Data) |
| then |
| Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); |
| Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); |
| Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ)); |
| Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ)); |
| Append_To (Res, Make_Disp_Requeue_Body (Tag_Typ)); |
| Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ)); |
| end if; |
| |
| if not Is_Limited_Type (Tag_Typ) then |
| -- Body for equality and inequality |
| |
| Predefined_Primitive_Eq_Body (Tag_Typ, Res, Renamed_Eq); |
| |
| -- Body for dispatching assignment |
| |
| Decl := |
| Predef_Spec_Or_Body (Loc, |
| Tag_Typ => Tag_Typ, |
| Name => Name_uAssign, |
| Profile => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), |
| Out_Present => True, |
| Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), |
| Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), |
| For_Body => True); |
| |
| Set_Handled_Statement_Sequence (Decl, |
| Make_Handled_Sequence_Of_Statements (Loc, New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => Make_Identifier (Loc, Name_X), |
| Expression => Make_Identifier (Loc, Name_Y))))); |
| |
| Append_To (Res, Decl); |
| end if; |
| |
| -- Generate empty bodies of routines Deep_Adjust and Deep_Finalize for |
| -- tagged types which do not contain controlled components. |
| |
| -- Do not generate the routines if finalization is disabled |
| |
| if Restriction_Active (No_Finalization) then |
| null; |
| |
| elsif not Has_Controlled_Component (Tag_Typ) then |
| if not Is_Limited_Type (Tag_Typ) then |
| Adj_Call := Empty; |
| Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True); |
| |
| if Is_Controlled (Tag_Typ) then |
| Adj_Call := |
| Make_Adjust_Call ( |
| Obj_Ref => Make_Identifier (Loc, Name_V), |
| Typ => Tag_Typ); |
| end if; |
| |
| if No (Adj_Call) then |
| Adj_Call := Make_Null_Statement (Loc); |
| end if; |
| |
| Set_Handled_Statement_Sequence (Decl, |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Adj_Call))); |
| |
| Append_To (Res, Decl); |
| end if; |
| |
| Fin_Call := Empty; |
| Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True); |
| |
| if Is_Controlled (Tag_Typ) then |
| Fin_Call := |
| Make_Final_Call |
| (Obj_Ref => Make_Identifier (Loc, Name_V), |
| Typ => Tag_Typ); |
| end if; |
| |
| if No (Fin_Call) then |
| Fin_Call := Make_Null_Statement (Loc); |
| end if; |
| |
| Set_Handled_Statement_Sequence (Decl, |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Fin_Call))); |
| |
| Append_To (Res, Decl); |
| end if; |
| |
| return Res; |
| end Predefined_Primitive_Bodies; |
| |
| --------------------------------- |
| -- Predefined_Primitive_Freeze -- |
| --------------------------------- |
| |
| function Predefined_Primitive_Freeze |
| (Tag_Typ : Entity_Id) return List_Id |
| is |
| Res : constant List_Id := New_List; |
| Prim : Elmt_Id; |
| Frnodes : List_Id; |
| |
| begin |
| Prim := First_Elmt (Primitive_Operations (Tag_Typ)); |
| while Present (Prim) loop |
| if Is_Predefined_Dispatching_Operation (Node (Prim)) then |
| Frnodes := Freeze_Entity (Node (Prim), Tag_Typ); |
| |
| if Present (Frnodes) then |
| Append_List_To (Res, Frnodes); |
| end if; |
| end if; |
| |
| Next_Elmt (Prim); |
| end loop; |
| |
| return Res; |
| end Predefined_Primitive_Freeze; |
| |
| ------------------------- |
| -- Stream_Operation_OK -- |
| ------------------------- |
| |
| function Stream_Operation_OK |
| (Typ : Entity_Id; |
| Operation : TSS_Name_Type) return Boolean |
| is |
| Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False; |
| |
| begin |
| -- Special case of a limited type extension: a default implementation |
| -- of the stream attributes Read or Write exists if that attribute |
| -- has been specified or is available for an ancestor type; a default |
| -- implementation of the attribute Output (resp. Input) exists if the |
| -- attribute has been specified or Write (resp. Read) is available for |
| -- an ancestor type. The last condition only applies under Ada 2005. |
| |
| if Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ) then |
| if Operation = TSS_Stream_Read then |
| Has_Predefined_Or_Specified_Stream_Attribute := |
| Has_Specified_Stream_Read (Typ); |
| |
| elsif Operation = TSS_Stream_Write then |
| Has_Predefined_Or_Specified_Stream_Attribute := |
| Has_Specified_Stream_Write (Typ); |
| |
| elsif Operation = TSS_Stream_Input then |
| Has_Predefined_Or_Specified_Stream_Attribute := |
| Has_Specified_Stream_Input (Typ) |
| or else |
| (Ada_Version >= Ada_2005 |
| and then Stream_Operation_OK (Typ, TSS_Stream_Read)); |
| |
| elsif Operation = TSS_Stream_Output then |
| Has_Predefined_Or_Specified_Stream_Attribute := |
| Has_Specified_Stream_Output (Typ) |
| or else |
| (Ada_Version >= Ada_2005 |
| and then Stream_Operation_OK (Typ, TSS_Stream_Write)); |
| end if; |
| |
| -- Case of inherited TSS_Stream_Read or TSS_Stream_Write |
| |
| if not Has_Predefined_Or_Specified_Stream_Attribute |
| and then Is_Derived_Type (Typ) |
| and then (Operation = TSS_Stream_Read |
| or else Operation = TSS_Stream_Write) |
| then |
| Has_Predefined_Or_Specified_Stream_Attribute := |
| Present |
| (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation)); |
| end if; |
| end if; |
| |
| -- If the type is not limited, or else is limited but the attribute is |
| -- explicitly specified or is predefined for the type, then return True, |
| -- unless other conditions prevail, such as restrictions prohibiting |
| -- streams or dispatching operations. We also return True for limited |
| -- interfaces, because they may be extended by nonlimited types and |
| -- permit inheritance in this case (addresses cases where an abstract |
| -- extension doesn't get 'Input declared, as per comments below, but |
| -- 'Class'Input must still be allowed). Note that attempts to apply |
| -- stream attributes to a limited interface or its class-wide type |
| -- (or limited extensions thereof) will still get properly rejected |
| -- by Check_Stream_Attribute. |
| |
| -- We exclude the Input operation from being a predefined subprogram in |
| -- the case where the associated type is an abstract extension, because |
| -- the attribute is not callable in that case, per 13.13.2(49/2). Also, |
| -- we don't want an abstract version created because types derived from |
| -- the abstract type may not even have Input available (for example if |
| -- derived from a private view of the abstract type that doesn't have |
| -- a visible Input). |
| |
| -- Do not generate stream routines for type Finalization_Master because |
| -- a master may never appear in types and therefore cannot be read or |
| -- written. |
| |
| return |
| (not Is_Limited_Type (Typ) |
| or else Is_Interface (Typ) |
| or else Has_Predefined_Or_Specified_Stream_Attribute) |
| and then |
| (Operation /= TSS_Stream_Input |
| or else not Is_Abstract_Type (Typ) |
| or else not Is_Derived_Type (Typ)) |
| and then not Has_Unknown_Discriminants (Typ) |
| and then not Is_Concurrent_Interface (Typ) |
| and then not Restriction_Active (No_Streams) |
| and then not Restriction_Active (No_Dispatch) |
| and then No (No_Tagged_Streams_Pragma (Typ)) |
| and then not No_Run_Time_Mode |
| and then RTE_Available (RE_Tag) |
| and then No (Type_Without_Stream_Operation (Typ)) |
| and then RTE_Available (RE_Root_Stream_Type) |
| and then not Is_RTE (Typ, RE_Finalization_Master); |
| end Stream_Operation_OK; |
| |
| end Exp_Ch3; |