1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Exp_Aggr; use Exp_Aggr;
32 with Exp_Atag; use Exp_Atag;
33 with Exp_Ch4; use Exp_Ch4;
34 with Exp_Ch6; use Exp_Ch6;
35 with Exp_Ch7; use Exp_Ch7;
36 with Exp_Ch9; use Exp_Ch9;
37 with Exp_Ch11; use Exp_Ch11;
38 with Exp_Disp; use Exp_Disp;
39 with Exp_Dist; use Exp_Dist;
40 with Exp_Smem; use Exp_Smem;
41 with Exp_Strm; use Exp_Strm;
42 with Exp_Tss; use Exp_Tss;
43 with Exp_Util; use Exp_Util;
44 with Freeze; use Freeze;
45 with Hostparm; use Hostparm;
46 with Nlists; use Nlists;
47 with Nmake; use Nmake;
49 with Restrict; use Restrict;
50 with Rident; use Rident;
51 with Rtsfind; use Rtsfind;
53 with Sem_Attr; use Sem_Attr;
54 with Sem_Cat; use Sem_Cat;
55 with Sem_Ch3; use Sem_Ch3;
56 with Sem_Ch8; use Sem_Ch8;
57 with Sem_Disp; use Sem_Disp;
58 with Sem_Eval; use Sem_Eval;
59 with Sem_Mech; use Sem_Mech;
60 with Sem_Res; use Sem_Res;
61 with Sem_Util; use Sem_Util;
62 with Sinfo; use Sinfo;
63 with Stand; use Stand;
64 with Snames; use Snames;
65 with Tbuild; use Tbuild;
66 with Ttypes; use Ttypes;
67 with Validsw; use Validsw;
69 package body Exp_Ch3 is
71 -----------------------
72 -- Local Subprograms --
73 -----------------------
75 procedure Adjust_Discriminants (Rtype : Entity_Id);
76 -- This is used when freezing a record type. It attempts to construct
77 -- more restrictive subtypes for discriminants so that the max size of
78 -- the record can be calculated more accurately. See the body of this
79 -- procedure for details.
81 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id);
82 -- Build initialization procedure for given array type. Nod is a node
83 -- used for attachment of any actions required in its construction.
84 -- It also supplies the source location used for the procedure.
86 function Build_Discriminant_Formals
88 Use_Dl : Boolean) return List_Id;
89 -- This function uses the discriminants of a type to build a list of
90 -- formal parameters, used in the following function. If the flag Use_Dl
91 -- is set, the list is built using the already defined discriminals
92 -- of the type. Otherwise new identifiers are created, with the source
93 -- names of the discriminants.
95 function Build_Master_Renaming
97 T : Entity_Id) return Entity_Id;
98 -- If the designated type of an access type is a task type or contains
99 -- tasks, we make sure that a _Master variable is declared in the current
100 -- scope, and then declare a renaming for it:
102 -- atypeM : Master_Id renames _Master;
104 -- where atyp is the name of the access type. This declaration is used when
105 -- an allocator for the access type is expanded. The node is the full
106 -- declaration of the designated type that contains tasks. The renaming
107 -- declaration is inserted before N, and after the Master declaration.
109 procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id);
110 -- Build record initialization procedure. N is the type declaration
111 -- node, and Pe is the corresponding entity for the record type.
113 procedure Build_Slice_Assignment (Typ : Entity_Id);
114 -- Build assignment procedure for one-dimensional arrays of controlled
115 -- types. Other array and slice assignments are expanded in-line, but
116 -- the code expansion for controlled components (when control actions
117 -- are active) can lead to very large blocks that GCC3 handles poorly.
119 procedure Build_Variant_Record_Equality (Typ : Entity_Id);
120 -- Create An Equality function for the non-tagged variant record 'Typ'
121 -- and attach it to the TSS list
123 procedure Check_Stream_Attributes (Typ : Entity_Id);
124 -- Check that if a limited extension has a parent with user-defined
125 -- stream attributes, and does not itself have user-definer
126 -- stream-attributes, then any limited component of the extension also
127 -- has the corresponding user-defined stream attributes.
129 procedure Clean_Task_Names
131 Proc_Id : Entity_Id);
132 -- If an initialization procedure includes calls to generate names
133 -- for task subcomponents, indicate that secondary stack cleanup is
134 -- needed after an initialization. Typ is the component type, and Proc_Id
135 -- the initialization procedure for the enclosing composite type.
137 procedure Expand_Tagged_Root (T : Entity_Id);
138 -- Add a field _Tag at the beginning of the record. This field carries
139 -- the value of the access to the Dispatch table. This procedure is only
140 -- called on root type, the _Tag field being inherited by the descendants.
142 procedure Expand_Record_Controller (T : Entity_Id);
143 -- T must be a record type that Has_Controlled_Component. Add a field
144 -- _controller of type Record_Controller or Limited_Record_Controller
147 procedure Freeze_Array_Type (N : Node_Id);
148 -- Freeze an array type. Deals with building the initialization procedure,
149 -- creating the packed array type for a packed array and also with the
150 -- creation of the controlling procedures for the controlled case. The
151 -- argument N is the N_Freeze_Entity node for the type.
153 procedure Freeze_Enumeration_Type (N : Node_Id);
154 -- Freeze enumeration type with non-standard representation. Builds the
155 -- array and function needed to convert between enumeration pos and
156 -- enumeration representation values. N is the N_Freeze_Entity node
159 procedure Freeze_Record_Type (N : Node_Id);
160 -- Freeze record type. Builds all necessary discriminant checking
161 -- and other ancillary functions, and builds dispatch tables where
162 -- needed. The argument N is the N_Freeze_Entity node. This processing
163 -- applies only to E_Record_Type entities, not to class wide types,
164 -- record subtypes, or private types.
166 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id);
167 -- Treat user-defined stream operations as renaming_as_body if the
168 -- subprogram they rename is not frozen when the type is frozen.
170 function Init_Formals (Typ : Entity_Id) return List_Id;
171 -- This function builds the list of formals for an initialization routine.
172 -- The first formal is always _Init with the given type. For task value
173 -- record types and types containing tasks, three additional formals are
176 -- _Master : Master_Id
177 -- _Chain : in out Activation_Chain
178 -- _Task_Name : String
180 -- The caller must append additional entries for discriminants if required.
182 function In_Runtime (E : Entity_Id) return Boolean;
183 -- Check if E is defined in the RTL (in a child of Ada or System). Used
184 -- to avoid to bring in the overhead of _Input, _Output for tagged types.
186 function Make_Eq_Case
189 Discr : Entity_Id := Empty) return List_Id;
190 -- Building block for variant record equality. Defined to share the
191 -- code between the tagged and non-tagged case. Given a Component_List
192 -- node CL, it generates an 'if' followed by a 'case' statement that
193 -- compares all components of local temporaries named X and Y (that
194 -- are declared as formals at some upper level). E provides the Sloc to be
195 -- used for the generated code. Discr is used as the case statement switch
196 -- in the case of Unchecked_Union equality.
200 L : List_Id) return Node_Id;
201 -- Building block for variant record equality. Defined to share the
202 -- code between the tagged and non-tagged case. Given the list of
203 -- components (or discriminants) L, it generates a return statement
204 -- that compares all components of local temporaries named X and Y
205 -- (that are declared as formals at some upper level). E provides the Sloc
206 -- to be used for the generated code.
208 procedure Make_Predefined_Primitive_Specs
209 (Tag_Typ : Entity_Id;
210 Predef_List : out List_Id;
211 Renamed_Eq : out Node_Id);
212 -- Create a list with the specs of the predefined primitive operations.
213 -- The following entries are present for all tagged types, and provide
214 -- the results of the corresponding attribute applied to the object.
215 -- Dispatching is required in general, since the result of the attribute
216 -- will vary with the actual object subtype.
218 -- _alignment provides result of 'Alignment attribute
219 -- _size provides result of 'Size attribute
220 -- typSR provides result of 'Read attribute
221 -- typSW provides result of 'Write attribute
222 -- typSI provides result of 'Input attribute
223 -- typSO provides result of 'Output attribute
225 -- The following entries are additionally present for non-limited
226 -- tagged types, and implement additional dispatching operations
227 -- for predefined operations:
229 -- _equality implements "=" operator
230 -- _assign implements assignment operation
231 -- typDF implements deep finalization
232 -- typDA implements deep adust
234 -- The latter two are empty procedures unless the type contains some
235 -- controlled components that require finalization actions (the deep
236 -- in the name refers to the fact that the action applies to components).
238 -- The list is returned in Predef_List. The Parameter Renamed_Eq
239 -- either returns the value Empty, or else the defining unit name
240 -- for the predefined equality function in the case where the type
241 -- has a primitive operation that is a renaming of predefined equality
242 -- (but only if there is also an overriding user-defined equality
243 -- function). The returned Renamed_Eq will be passed to the
244 -- corresponding parameter of Predefined_Primitive_Bodies.
246 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean;
247 -- returns True if there are representation clauses for type T that
248 -- are not inherited. If the result is false, the init_proc and the
249 -- discriminant_checking functions of the parent can be reused by
252 procedure Make_Controlling_Function_Wrappers
253 (Tag_Typ : Entity_Id;
254 Decl_List : out List_Id;
255 Body_List : out List_Id);
256 -- Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions
257 -- associated with inherited functions with controlling results which
258 -- are not overridden. The body of each wrapper function consists solely
259 -- of a return statement whose expression is an extension aggregate
260 -- invoking the inherited subprogram's parent subprogram and extended
261 -- with a null association list.
263 procedure Make_Null_Procedure_Specs
264 (Tag_Typ : Entity_Id;
265 Decl_List : out List_Id);
266 -- Ada 2005 (AI-251): Makes specs for null procedures associated with any
267 -- null procedures inherited from an interface type that have not been
268 -- overridden. Only one null procedure will be created for a given set of
269 -- inherited null procedures with homographic profiles.
271 function Predef_Spec_Or_Body
276 Ret_Type : Entity_Id := Empty;
277 For_Body : Boolean := False) return Node_Id;
278 -- This function generates the appropriate expansion for a predefined
279 -- primitive operation specified by its name, parameter profile and
280 -- return type (Empty means this is a procedure). If For_Body is false,
281 -- then the returned node is a subprogram declaration. If For_Body is
282 -- true, then the returned node is a empty subprogram body containing
283 -- no declarations and no statements.
285 function Predef_Stream_Attr_Spec
288 Name : TSS_Name_Type;
289 For_Body : Boolean := False) return Node_Id;
290 -- Specialized version of Predef_Spec_Or_Body that apply to read, write,
291 -- input and output attribute whose specs are constructed in Exp_Strm.
293 function Predef_Deep_Spec
296 Name : TSS_Name_Type;
297 For_Body : Boolean := False) return Node_Id;
298 -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
299 -- and _deep_finalize
301 function Predefined_Primitive_Bodies
302 (Tag_Typ : Entity_Id;
303 Renamed_Eq : Node_Id) return List_Id;
304 -- Create the bodies of the predefined primitives that are described in
305 -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
306 -- the defining unit name of the type's predefined equality as returned
307 -- by Make_Predefined_Primitive_Specs.
309 function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id;
310 -- Freeze entities of all predefined primitive operations. This is needed
311 -- because the bodies of these operations do not normally do any freezeing.
313 function Stream_Operation_OK
315 Operation : TSS_Name_Type) return Boolean;
316 -- Check whether the named stream operation must be emitted for a given
317 -- type. The rules for inheritance of stream attributes by type extensions
318 -- are enforced by this function. Furthermore, various restrictions prevent
319 -- the generation of these operations, as a useful optimization or for
320 -- certification purposes.
322 --------------------------
323 -- Adjust_Discriminants --
324 --------------------------
326 -- This procedure attempts to define subtypes for discriminants that
327 -- are more restrictive than those declared. Such a replacement is
328 -- possible if we can demonstrate that values outside the restricted
329 -- range would cause constraint errors in any case. The advantage of
330 -- restricting the discriminant types in this way is tha the maximum
331 -- size of the variant record can be calculated more conservatively.
333 -- An example of a situation in which we can perform this type of
334 -- restriction is the following:
336 -- subtype B is range 1 .. 10;
337 -- type Q is array (B range <>) of Integer;
339 -- type V (N : Natural) is record
343 -- In this situation, we can restrict the upper bound of N to 10, since
344 -- any larger value would cause a constraint error in any case.
346 -- There are many situations in which such restriction is possible, but
347 -- for now, we just look for cases like the above, where the component
348 -- in question is a one dimensional array whose upper bound is one of
349 -- the record discriminants. Also the component must not be part of
350 -- any variant part, since then the component does not always exist.
352 procedure Adjust_Discriminants (Rtype : Entity_Id) is
353 Loc : constant Source_Ptr := Sloc (Rtype);
370 Comp := First_Component (Rtype);
371 while Present (Comp) loop
373 -- If our parent is a variant, quit, we do not look at components
374 -- that are in variant parts, because they may not always exist.
376 P := Parent (Comp); -- component declaration
377 P := Parent (P); -- component list
379 exit when Nkind (Parent (P)) = N_Variant;
381 -- We are looking for a one dimensional array type
383 Ctyp := Etype (Comp);
385 if not Is_Array_Type (Ctyp)
386 or else Number_Dimensions (Ctyp) > 1
391 -- The lower bound must be constant, and the upper bound is a
392 -- discriminant (which is a discriminant of the current record).
394 Ityp := Etype (First_Index (Ctyp));
395 Lo := Type_Low_Bound (Ityp);
396 Hi := Type_High_Bound (Ityp);
398 if not Compile_Time_Known_Value (Lo)
399 or else Nkind (Hi) /= N_Identifier
400 or else No (Entity (Hi))
401 or else Ekind (Entity (Hi)) /= E_Discriminant
406 -- We have an array with appropriate bounds
408 Loval := Expr_Value (Lo);
409 Discr := Entity (Hi);
410 Dtyp := Etype (Discr);
412 -- See if the discriminant has a known upper bound
414 Dhi := Type_High_Bound (Dtyp);
416 if not Compile_Time_Known_Value (Dhi) then
420 Dhiv := Expr_Value (Dhi);
422 -- See if base type of component array has known upper bound
424 Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp))));
426 if not Compile_Time_Known_Value (Ahi) then
430 Ahiv := Expr_Value (Ahi);
432 -- The condition for doing the restriction is that the high bound
433 -- of the discriminant is greater than the low bound of the array,
434 -- and is also greater than the high bound of the base type index.
436 if Dhiv > Loval and then Dhiv > Ahiv then
438 -- We can reset the upper bound of the discriminant type to
439 -- whichever is larger, the low bound of the component, or
440 -- the high bound of the base type array index.
442 -- We build a subtype that is declared as
444 -- subtype Tnn is discr_type range discr_type'First .. max;
446 -- And insert this declaration into the tree. The type of the
447 -- discriminant is then reset to this more restricted subtype.
449 Tnn := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
451 Insert_Action (Declaration_Node (Rtype),
452 Make_Subtype_Declaration (Loc,
453 Defining_Identifier => Tnn,
454 Subtype_Indication =>
455 Make_Subtype_Indication (Loc,
456 Subtype_Mark => New_Occurrence_Of (Dtyp, Loc),
458 Make_Range_Constraint (Loc,
462 Make_Attribute_Reference (Loc,
463 Attribute_Name => Name_First,
464 Prefix => New_Occurrence_Of (Dtyp, Loc)),
466 Make_Integer_Literal (Loc,
467 Intval => UI_Max (Loval, Ahiv)))))));
469 Set_Etype (Discr, Tnn);
473 Next_Component (Comp);
475 end Adjust_Discriminants;
477 ---------------------------
478 -- Build_Array_Init_Proc --
479 ---------------------------
481 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is
482 Loc : constant Source_Ptr := Sloc (Nod);
483 Comp_Type : constant Entity_Id := Component_Type (A_Type);
484 Index_List : List_Id;
486 Body_Stmts : List_Id;
488 function Init_Component return List_Id;
489 -- Create one statement to initialize one array component, designated
490 -- by a full set of indices.
492 function Init_One_Dimension (N : Int) return List_Id;
493 -- Create loop to initialize one dimension of the array. The single
494 -- statement in the loop body initializes the inner dimensions if any,
495 -- or else the single component. Note that this procedure is called
496 -- recursively, with N being the dimension to be initialized. A call
497 -- with N greater than the number of dimensions simply generates the
498 -- component initialization, terminating the recursion.
504 function Init_Component return List_Id is
509 Make_Indexed_Component (Loc,
510 Prefix => Make_Identifier (Loc, Name_uInit),
511 Expressions => Index_List);
513 if Needs_Simple_Initialization (Comp_Type) then
514 Set_Assignment_OK (Comp);
516 Make_Assignment_Statement (Loc,
520 (Comp_Type, Loc, Component_Size (A_Type))));
523 Clean_Task_Names (Comp_Type, Proc_Id);
525 Build_Initialization_Call
526 (Loc, Comp, Comp_Type,
527 In_Init_Proc => True,
528 Enclos_Type => A_Type);
532 ------------------------
533 -- Init_One_Dimension --
534 ------------------------
536 function Init_One_Dimension (N : Int) return List_Id is
540 -- If the component does not need initializing, then there is nothing
541 -- to do here, so we return a null body. This occurs when generating
542 -- the dummy Init_Proc needed for Initialize_Scalars processing.
544 if not Has_Non_Null_Base_Init_Proc (Comp_Type)
545 and then not Needs_Simple_Initialization (Comp_Type)
546 and then not Has_Task (Comp_Type)
548 return New_List (Make_Null_Statement (Loc));
550 -- If all dimensions dealt with, we simply initialize the component
552 elsif N > Number_Dimensions (A_Type) then
553 return Init_Component;
555 -- Here we generate the required loop
559 Make_Defining_Identifier (Loc, New_External_Name ('J', N));
561 Append (New_Reference_To (Index, Loc), Index_List);
564 Make_Implicit_Loop_Statement (Nod,
567 Make_Iteration_Scheme (Loc,
568 Loop_Parameter_Specification =>
569 Make_Loop_Parameter_Specification (Loc,
570 Defining_Identifier => Index,
571 Discrete_Subtype_Definition =>
572 Make_Attribute_Reference (Loc,
573 Prefix => Make_Identifier (Loc, Name_uInit),
574 Attribute_Name => Name_Range,
575 Expressions => New_List (
576 Make_Integer_Literal (Loc, N))))),
577 Statements => Init_One_Dimension (N + 1)));
579 end Init_One_Dimension;
581 -- Start of processing for Build_Array_Init_Proc
584 if Suppress_Init_Proc (A_Type) then
588 Index_List := New_List;
590 -- We need an initialization procedure if any of the following is true:
592 -- 1. The component type has an initialization procedure
593 -- 2. The component type needs simple initialization
594 -- 3. Tasks are present
595 -- 4. The type is marked as a publc entity
597 -- The reason for the public entity test is to deal properly with the
598 -- Initialize_Scalars pragma. This pragma can be set in the client and
599 -- not in the declaring package, this means the client will make a call
600 -- to the initialization procedure (because one of conditions 1-3 must
601 -- apply in this case), and we must generate a procedure (even if it is
602 -- null) to satisfy the call in this case.
604 -- Exception: do not build an array init_proc for a type whose root
605 -- type is Standard.String or Standard.Wide_[Wide_]String, since there
606 -- is no place to put the code, and in any case we handle initialization
607 -- of such types (in the Initialize_Scalars case, that's the only time
608 -- the issue arises) in a special manner anyway which does not need an
611 if Has_Non_Null_Base_Init_Proc (Comp_Type)
612 or else Needs_Simple_Initialization (Comp_Type)
613 or else Has_Task (Comp_Type)
614 or else (not Restriction_Active (No_Initialize_Scalars)
615 and then Is_Public (A_Type)
616 and then Root_Type (A_Type) /= Standard_String
617 and then Root_Type (A_Type) /= Standard_Wide_String
618 and then Root_Type (A_Type) /= Standard_Wide_Wide_String)
621 Make_Defining_Identifier (Loc, Make_Init_Proc_Name (A_Type));
623 Body_Stmts := Init_One_Dimension (1);
626 Make_Subprogram_Body (Loc,
628 Make_Procedure_Specification (Loc,
629 Defining_Unit_Name => Proc_Id,
630 Parameter_Specifications => Init_Formals (A_Type)),
631 Declarations => New_List,
632 Handled_Statement_Sequence =>
633 Make_Handled_Sequence_Of_Statements (Loc,
634 Statements => Body_Stmts)));
636 Set_Ekind (Proc_Id, E_Procedure);
637 Set_Is_Public (Proc_Id, Is_Public (A_Type));
638 Set_Is_Internal (Proc_Id);
639 Set_Has_Completion (Proc_Id);
641 if not Debug_Generated_Code then
642 Set_Debug_Info_Off (Proc_Id);
645 -- Set inlined unless controlled stuff or tasks around, in which
646 -- case we do not want to inline, because nested stuff may cause
647 -- difficulties in interunit inlining, and furthermore there is
648 -- in any case no point in inlining such complex init procs.
650 if not Has_Task (Proc_Id)
651 and then not Controlled_Type (Proc_Id)
653 Set_Is_Inlined (Proc_Id);
656 -- Associate Init_Proc with type, and determine if the procedure
657 -- is null (happens because of the Initialize_Scalars pragma case,
658 -- where we have to generate a null procedure in case it is called
659 -- by a client with Initialize_Scalars set). Such procedures have
660 -- to be generated, but do not have to be called, so we mark them
661 -- as null to suppress the call.
663 Set_Init_Proc (A_Type, Proc_Id);
665 if List_Length (Body_Stmts) = 1
666 and then Nkind (First (Body_Stmts)) = N_Null_Statement
668 Set_Is_Null_Init_Proc (Proc_Id);
671 end Build_Array_Init_Proc;
673 -----------------------------
674 -- Build_Class_Wide_Master --
675 -----------------------------
677 procedure Build_Class_Wide_Master (T : Entity_Id) is
678 Loc : constant Source_Ptr := Sloc (T);
685 -- Nothing to do if there is no task hierarchy
687 if Restriction_Active (No_Task_Hierarchy) then
691 -- Find declaration that created the access type: either a
692 -- type declaration, or an object declaration with an
693 -- access definition, in which case the type is anonymous.
696 P := Associated_Node_For_Itype (T);
701 -- Nothing to do if we already built a master entity for this scope
703 if not Has_Master_Entity (Scope (T)) then
705 -- first build the master entity
706 -- _Master : constant Master_Id := Current_Master.all;
707 -- and insert it just before the current declaration
710 Make_Object_Declaration (Loc,
711 Defining_Identifier =>
712 Make_Defining_Identifier (Loc, Name_uMaster),
713 Constant_Present => True,
714 Object_Definition => New_Reference_To (Standard_Integer, Loc),
716 Make_Explicit_Dereference (Loc,
717 New_Reference_To (RTE (RE_Current_Master), Loc)));
719 Insert_Before (P, Decl);
721 Set_Has_Master_Entity (Scope (T));
723 -- Now mark the containing scope as a task master
726 while Nkind (Par) /= N_Compilation_Unit loop
729 -- If we fall off the top, we are at the outer level, and the
730 -- environment task is our effective master, so nothing to mark.
732 if Nkind (Par) = N_Task_Body
733 or else Nkind (Par) = N_Block_Statement
734 or else Nkind (Par) = N_Subprogram_Body
736 Set_Is_Task_Master (Par, True);
742 -- Now define the renaming of the master_id
745 Make_Defining_Identifier (Loc,
746 New_External_Name (Chars (T), 'M'));
749 Make_Object_Renaming_Declaration (Loc,
750 Defining_Identifier => M_Id,
751 Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
752 Name => Make_Identifier (Loc, Name_uMaster));
753 Insert_Before (P, Decl);
756 Set_Master_Id (T, M_Id);
759 when RE_Not_Available =>
761 end Build_Class_Wide_Master;
763 --------------------------------
764 -- Build_Discr_Checking_Funcs --
765 --------------------------------
767 procedure Build_Discr_Checking_Funcs (N : Node_Id) is
770 Enclosing_Func_Id : Entity_Id;
775 function Build_Case_Statement
776 (Case_Id : Entity_Id;
777 Variant : Node_Id) return Node_Id;
778 -- Build a case statement containing only two alternatives. The
779 -- first alternative corresponds exactly to the discrete choices
780 -- given on the variant with contains the components that we are
781 -- generating the checks for. If the discriminant is one of these
782 -- return False. The second alternative is an OTHERS choice that
783 -- will return True indicating the discriminant did not match.
785 function Build_Dcheck_Function
786 (Case_Id : Entity_Id;
787 Variant : Node_Id) return Entity_Id;
788 -- Build the discriminant checking function for a given variant
790 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id);
791 -- Builds the discriminant checking function for each variant of the
792 -- given variant part of the record type.
794 --------------------------
795 -- Build_Case_Statement --
796 --------------------------
798 function Build_Case_Statement
799 (Case_Id : Entity_Id;
800 Variant : Node_Id) return Node_Id
802 Alt_List : constant List_Id := New_List;
803 Actuals_List : List_Id;
805 Case_Alt_Node : Node_Id;
807 Choice_List : List_Id;
809 Return_Node : Node_Id;
812 Case_Node := New_Node (N_Case_Statement, Loc);
814 -- Replace the discriminant which controls the variant, with the
815 -- name of the formal of the checking function.
817 Set_Expression (Case_Node,
818 Make_Identifier (Loc, Chars (Case_Id)));
820 Choice := First (Discrete_Choices (Variant));
822 if Nkind (Choice) = N_Others_Choice then
823 Choice_List := New_Copy_List (Others_Discrete_Choices (Choice));
825 Choice_List := New_Copy_List (Discrete_Choices (Variant));
828 if not Is_Empty_List (Choice_List) then
829 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
830 Set_Discrete_Choices (Case_Alt_Node, Choice_List);
832 -- In case this is a nested variant, we need to return the result
833 -- of the discriminant checking function for the immediately
834 -- enclosing variant.
836 if Present (Enclosing_Func_Id) then
837 Actuals_List := New_List;
839 D := First_Discriminant (Rec_Id);
840 while Present (D) loop
841 Append (Make_Identifier (Loc, Chars (D)), Actuals_List);
842 Next_Discriminant (D);
846 Make_Return_Statement (Loc,
848 Make_Function_Call (Loc,
850 New_Reference_To (Enclosing_Func_Id, Loc),
851 Parameter_Associations =>
856 Make_Return_Statement (Loc,
858 New_Reference_To (Standard_False, Loc));
861 Set_Statements (Case_Alt_Node, New_List (Return_Node));
862 Append (Case_Alt_Node, Alt_List);
865 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc);
866 Choice_List := New_List (New_Node (N_Others_Choice, Loc));
867 Set_Discrete_Choices (Case_Alt_Node, Choice_List);
870 Make_Return_Statement (Loc,
872 New_Reference_To (Standard_True, Loc));
874 Set_Statements (Case_Alt_Node, New_List (Return_Node));
875 Append (Case_Alt_Node, Alt_List);
877 Set_Alternatives (Case_Node, Alt_List);
879 end Build_Case_Statement;
881 ---------------------------
882 -- Build_Dcheck_Function --
883 ---------------------------
885 function Build_Dcheck_Function
886 (Case_Id : Entity_Id;
887 Variant : Node_Id) return Entity_Id
891 Parameter_List : List_Id;
895 Body_Node := New_Node (N_Subprogram_Body, Loc);
896 Sequence := Sequence + 1;
899 Make_Defining_Identifier (Loc,
900 Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence));
902 Spec_Node := New_Node (N_Function_Specification, Loc);
903 Set_Defining_Unit_Name (Spec_Node, Func_Id);
905 Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
907 Set_Parameter_Specifications (Spec_Node, Parameter_List);
908 Set_Result_Definition (Spec_Node,
909 New_Reference_To (Standard_Boolean, Loc));
910 Set_Specification (Body_Node, Spec_Node);
911 Set_Declarations (Body_Node, New_List);
913 Set_Handled_Statement_Sequence (Body_Node,
914 Make_Handled_Sequence_Of_Statements (Loc,
915 Statements => New_List (
916 Build_Case_Statement (Case_Id, Variant))));
918 Set_Ekind (Func_Id, E_Function);
919 Set_Mechanism (Func_Id, Default_Mechanism);
920 Set_Is_Inlined (Func_Id, True);
921 Set_Is_Pure (Func_Id, True);
922 Set_Is_Public (Func_Id, Is_Public (Rec_Id));
923 Set_Is_Internal (Func_Id, True);
925 if not Debug_Generated_Code then
926 Set_Debug_Info_Off (Func_Id);
931 Append_Freeze_Action (Rec_Id, Body_Node);
932 Set_Dcheck_Function (Variant, Func_Id);
934 end Build_Dcheck_Function;
936 ----------------------------
937 -- Build_Dcheck_Functions --
938 ----------------------------
940 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is
941 Component_List_Node : Node_Id;
943 Discr_Name : Entity_Id;
946 Saved_Enclosing_Func_Id : Entity_Id;
949 -- Build the discriminant checking function for each variant, label
950 -- all components of that variant with the function's name.
952 Discr_Name := Entity (Name (Variant_Part_Node));
953 Variant := First_Non_Pragma (Variants (Variant_Part_Node));
955 while Present (Variant) loop
956 Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
957 Component_List_Node := Component_List (Variant);
959 if not Null_Present (Component_List_Node) then
961 First_Non_Pragma (Component_Items (Component_List_Node));
963 while Present (Decl) loop
964 Set_Discriminant_Checking_Func
965 (Defining_Identifier (Decl), Func_Id);
967 Next_Non_Pragma (Decl);
970 if Present (Variant_Part (Component_List_Node)) then
971 Saved_Enclosing_Func_Id := Enclosing_Func_Id;
972 Enclosing_Func_Id := Func_Id;
973 Build_Dcheck_Functions (Variant_Part (Component_List_Node));
974 Enclosing_Func_Id := Saved_Enclosing_Func_Id;
978 Next_Non_Pragma (Variant);
980 end Build_Dcheck_Functions;
982 -- Start of processing for Build_Discr_Checking_Funcs
985 -- Only build if not done already
987 if not Discr_Check_Funcs_Built (N) then
988 Type_Def := Type_Definition (N);
990 if Nkind (Type_Def) = N_Record_Definition then
991 if No (Component_List (Type_Def)) then -- null record.
994 V := Variant_Part (Component_List (Type_Def));
997 else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition);
998 if No (Component_List (Record_Extension_Part (Type_Def))) then
1002 (Component_List (Record_Extension_Part (Type_Def)));
1006 Rec_Id := Defining_Identifier (N);
1008 if Present (V) and then not Is_Unchecked_Union (Rec_Id) then
1010 Enclosing_Func_Id := Empty;
1011 Build_Dcheck_Functions (V);
1014 Set_Discr_Check_Funcs_Built (N);
1016 end Build_Discr_Checking_Funcs;
1018 --------------------------------
1019 -- Build_Discriminant_Formals --
1020 --------------------------------
1022 function Build_Discriminant_Formals
1023 (Rec_Id : Entity_Id;
1024 Use_Dl : Boolean) return List_Id
1026 Loc : Source_Ptr := Sloc (Rec_Id);
1027 Parameter_List : constant List_Id := New_List;
1030 Param_Spec_Node : Node_Id;
1033 if Has_Discriminants (Rec_Id) then
1034 D := First_Discriminant (Rec_Id);
1035 while Present (D) loop
1039 Formal := Discriminal (D);
1041 Formal := Make_Defining_Identifier (Loc, Chars (D));
1045 Make_Parameter_Specification (Loc,
1046 Defining_Identifier => Formal,
1048 New_Reference_To (Etype (D), Loc));
1049 Append (Param_Spec_Node, Parameter_List);
1050 Next_Discriminant (D);
1054 return Parameter_List;
1055 end Build_Discriminant_Formals;
1057 -------------------------------
1058 -- Build_Initialization_Call --
1059 -------------------------------
1061 -- References to a discriminant inside the record type declaration
1062 -- can appear either in the subtype_indication to constrain a
1063 -- record or an array, or as part of a larger expression given for
1064 -- the initial value of a component. In both of these cases N appears
1065 -- in the record initialization procedure and needs to be replaced by
1066 -- the formal parameter of the initialization procedure which
1067 -- corresponds to that discriminant.
1069 -- In the example below, references to discriminants D1 and D2 in proc_1
1070 -- are replaced by references to formals with the same name
1073 -- A similar replacement is done for calls to any record
1074 -- initialization procedure for any components that are themselves
1075 -- of a record type.
1077 -- type R (D1, D2 : Integer) is record
1078 -- X : Integer := F * D1;
1079 -- Y : Integer := F * D2;
1082 -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
1086 -- Out_2.X := F * D1;
1087 -- Out_2.Y := F * D2;
1090 function Build_Initialization_Call
1094 In_Init_Proc : Boolean := False;
1095 Enclos_Type : Entity_Id := Empty;
1096 Discr_Map : Elist_Id := New_Elmt_List;
1097 With_Default_Init : Boolean := False) return List_Id
1099 First_Arg : Node_Id;
1105 Proc : constant Entity_Id := Base_Init_Proc (Typ);
1106 Init_Type : constant Entity_Id := Etype (First_Formal (Proc));
1107 Full_Init_Type : constant Entity_Id := Underlying_Type (Init_Type);
1108 Res : constant List_Id := New_List;
1109 Full_Type : Entity_Id := Typ;
1110 Controller_Typ : Entity_Id;
1113 -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars
1114 -- is active (in which case we make the call anyway, since in the
1115 -- actual compiled client it may be non null).
1117 if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then
1121 -- Go to full view if private type. In the case of successive
1122 -- private derivations, this can require more than one step.
1124 while Is_Private_Type (Full_Type)
1125 and then Present (Full_View (Full_Type))
1127 Full_Type := Full_View (Full_Type);
1130 -- If Typ is derived, the procedure is the initialization procedure for
1131 -- the root type. Wrap the argument in an conversion to make it type
1132 -- honest. Actually it isn't quite type honest, because there can be
1133 -- conflicts of views in the private type case. That is why we set
1134 -- Conversion_OK in the conversion node.
1136 if (Is_Record_Type (Typ)
1137 or else Is_Array_Type (Typ)
1138 or else Is_Private_Type (Typ))
1139 and then Init_Type /= Base_Type (Typ)
1141 First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref);
1142 Set_Etype (First_Arg, Init_Type);
1145 First_Arg := Id_Ref;
1148 Args := New_List (Convert_Concurrent (First_Arg, Typ));
1150 -- In the tasks case, add _Master as the value of the _Master parameter
1151 -- and _Chain as the value of the _Chain parameter. At the outer level,
1152 -- these will be variables holding the corresponding values obtained
1153 -- from GNARL. At inner levels, they will be the parameters passed down
1154 -- through the outer routines.
1156 if Has_Task (Full_Type) then
1157 if Restriction_Active (No_Task_Hierarchy) then
1159 -- See comments in System.Tasking.Initialization.Init_RTS
1160 -- for the value 3 (should be rtsfindable constant ???)
1162 Append_To (Args, Make_Integer_Literal (Loc, 3));
1165 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
1168 Append_To (Args, Make_Identifier (Loc, Name_uChain));
1170 -- Ada 2005 (AI-287): In case of default initialized components
1171 -- with tasks, we generate a null string actual parameter.
1172 -- This is just a workaround that must be improved later???
1174 if With_Default_Init then
1176 Make_String_Literal (Loc,
1181 Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc);
1182 Decl := Last (Decls);
1185 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
1186 Append_List (Decls, Res);
1194 -- Add discriminant values if discriminants are present
1196 if Has_Discriminants (Full_Init_Type) then
1197 Discr := First_Discriminant (Full_Init_Type);
1199 while Present (Discr) loop
1201 -- If this is a discriminated concurrent type, the init_proc
1202 -- for the corresponding record is being called. Use that
1203 -- type directly to find the discriminant value, to handle
1204 -- properly intervening renamed discriminants.
1207 T : Entity_Id := Full_Type;
1210 if Is_Protected_Type (T) then
1211 T := Corresponding_Record_Type (T);
1213 elsif Is_Private_Type (T)
1214 and then Present (Underlying_Full_View (T))
1215 and then Is_Protected_Type (Underlying_Full_View (T))
1217 T := Corresponding_Record_Type (Underlying_Full_View (T));
1221 Get_Discriminant_Value (
1224 Discriminant_Constraint (Full_Type));
1227 if In_Init_Proc then
1229 -- Replace any possible references to the discriminant in the
1230 -- call to the record initialization procedure with references
1231 -- to the appropriate formal parameter.
1233 if Nkind (Arg) = N_Identifier
1234 and then Ekind (Entity (Arg)) = E_Discriminant
1236 Arg := New_Reference_To (Discriminal (Entity (Arg)), Loc);
1238 -- Case of access discriminants. We replace the reference
1239 -- to the type by a reference to the actual object
1241 elsif Nkind (Arg) = N_Attribute_Reference
1242 and then Is_Access_Type (Etype (Arg))
1243 and then Is_Entity_Name (Prefix (Arg))
1244 and then Is_Type (Entity (Prefix (Arg)))
1247 Make_Attribute_Reference (Loc,
1248 Prefix => New_Copy (Prefix (Id_Ref)),
1249 Attribute_Name => Name_Unrestricted_Access);
1251 -- Otherwise make a copy of the default expression. Note
1252 -- that we use the current Sloc for this, because we do not
1253 -- want the call to appear to be at the declaration point.
1254 -- Within the expression, replace discriminants with their
1259 New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc);
1263 if Is_Constrained (Full_Type) then
1264 Arg := Duplicate_Subexpr_No_Checks (Arg);
1266 -- The constraints come from the discriminant default
1267 -- exps, they must be reevaluated, so we use New_Copy_Tree
1268 -- but we ensure the proper Sloc (for any embedded calls).
1270 Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
1274 -- Ada 2005 (AI-287) In case of default initialized components,
1275 -- we need to generate the corresponding selected component node
1276 -- to access the discriminant value. In other cases this is not
1277 -- required because we are inside the init proc and we use the
1278 -- corresponding formal.
1280 if With_Default_Init
1281 and then Nkind (Id_Ref) = N_Selected_Component
1282 and then Nkind (Arg) = N_Identifier
1285 Make_Selected_Component (Loc,
1286 Prefix => New_Copy_Tree (Prefix (Id_Ref)),
1287 Selector_Name => Arg));
1289 Append_To (Args, Arg);
1292 Next_Discriminant (Discr);
1296 -- If this is a call to initialize the parent component of a derived
1297 -- tagged type, indicate that the tag should not be set in the parent.
1299 if Is_Tagged_Type (Full_Init_Type)
1300 and then not Is_CPP_Class (Full_Init_Type)
1301 and then Nkind (Id_Ref) = N_Selected_Component
1302 and then Chars (Selector_Name (Id_Ref)) = Name_uParent
1304 Append_To (Args, New_Occurrence_Of (Standard_False, Loc));
1308 Make_Procedure_Call_Statement (Loc,
1309 Name => New_Occurrence_Of (Proc, Loc),
1310 Parameter_Associations => Args));
1312 if Controlled_Type (Typ)
1313 and then Nkind (Id_Ref) = N_Selected_Component
1315 if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
1316 Append_List_To (Res,
1318 Ref => New_Copy_Tree (First_Arg),
1321 Find_Final_List (Typ, New_Copy_Tree (First_Arg)),
1322 With_Attach => Make_Integer_Literal (Loc, 1)));
1324 -- If the enclosing type is an extension with new controlled
1325 -- components, it has his own record controller. If the parent
1326 -- also had a record controller, attach it to the new one.
1327 -- Build_Init_Statements relies on the fact that in this specific
1328 -- case the last statement of the result is the attach call to
1329 -- the controller. If this is changed, it must be synchronized.
1331 elsif Present (Enclos_Type)
1332 and then Has_New_Controlled_Component (Enclos_Type)
1333 and then Has_Controlled_Component (Typ)
1335 if Is_Inherently_Limited_Type (Typ) then
1336 Controller_Typ := RTE (RE_Limited_Record_Controller);
1338 Controller_Typ := RTE (RE_Record_Controller);
1341 Append_List_To (Res,
1344 Make_Selected_Component (Loc,
1345 Prefix => New_Copy_Tree (First_Arg),
1346 Selector_Name => Make_Identifier (Loc, Name_uController)),
1347 Typ => Controller_Typ,
1348 Flist_Ref => Find_Final_List (Typ, New_Copy_Tree (First_Arg)),
1349 With_Attach => Make_Integer_Literal (Loc, 1)));
1356 when RE_Not_Available =>
1358 end Build_Initialization_Call;
1360 ---------------------------
1361 -- Build_Master_Renaming --
1362 ---------------------------
1364 function Build_Master_Renaming
1366 T : Entity_Id) return Entity_Id
1368 Loc : constant Source_Ptr := Sloc (N);
1373 -- Nothing to do if there is no task hierarchy
1375 if Restriction_Active (No_Task_Hierarchy) then
1380 Make_Defining_Identifier (Loc,
1381 New_External_Name (Chars (T), 'M'));
1384 Make_Object_Renaming_Declaration (Loc,
1385 Defining_Identifier => M_Id,
1386 Subtype_Mark => New_Reference_To (RTE (RE_Master_Id), Loc),
1387 Name => Make_Identifier (Loc, Name_uMaster));
1388 Insert_Before (N, Decl);
1393 when RE_Not_Available =>
1395 end Build_Master_Renaming;
1397 ---------------------------
1398 -- Build_Master_Renaming --
1399 ---------------------------
1401 procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is
1405 -- Nothing to do if there is no task hierarchy
1407 if Restriction_Active (No_Task_Hierarchy) then
1411 M_Id := Build_Master_Renaming (N, T);
1412 Set_Master_Id (T, M_Id);
1415 when RE_Not_Available =>
1417 end Build_Master_Renaming;
1419 ----------------------------
1420 -- Build_Record_Init_Proc --
1421 ----------------------------
1423 procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is
1424 Loc : Source_Ptr := Sloc (N);
1425 Discr_Map : constant Elist_Id := New_Elmt_List;
1426 Proc_Id : Entity_Id;
1427 Rec_Type : Entity_Id;
1428 Set_Tag : Entity_Id := Empty;
1430 function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id;
1431 -- Build a assignment statement node which assigns to record
1432 -- component its default expression if defined. The left hand side
1433 -- of the assignment is marked Assignment_OK so that initialization
1434 -- of limited private records works correctly, Return also the
1435 -- adjustment call for controlled objects
1437 procedure Build_Discriminant_Assignments (Statement_List : List_Id);
1438 -- If the record has discriminants, adds assignment statements to
1439 -- statement list to initialize the discriminant values from the
1440 -- arguments of the initialization procedure.
1442 function Build_Init_Statements (Comp_List : Node_Id) return List_Id;
1443 -- Build a list representing a sequence of statements which initialize
1444 -- components of the given component list. This may involve building
1445 -- case statements for the variant parts.
1447 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id;
1448 -- Given a non-tagged type-derivation that declares discriminants,
1451 -- type R (R1, R2 : Integer) is record ... end record;
1453 -- type D (D1 : Integer) is new R (1, D1);
1455 -- we make the _init_proc of D be
1457 -- procedure _init_proc(X : D; D1 : Integer) is
1459 -- _init_proc( R(X), 1, D1);
1462 -- This function builds the call statement in this _init_proc.
1464 procedure Build_Init_Procedure;
1465 -- Build the tree corresponding to the procedure specification and body
1466 -- of the initialization procedure (by calling all the preceding
1467 -- auxiliary routines), and install it as the _init TSS.
1469 procedure Build_Offset_To_Top_Functions;
1470 -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec
1471 -- and body of the Offset_To_Top function that is generated when the
1472 -- parent of a type with discriminants has secondary dispatch tables.
1474 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id);
1475 -- Add range checks to components of disciminated records. S is a
1476 -- subtype indication of a record component. Check_List is a list
1477 -- to which the check actions are appended.
1479 function Component_Needs_Simple_Initialization
1480 (T : Entity_Id) return Boolean;
1481 -- Determines if a component needs simple initialization, given its type
1482 -- T. This is the same as Needs_Simple_Initialization except for the
1483 -- following difference: the types Tag, Interface_Tag, and Vtable_Ptr
1484 -- which are access types which would normally require simple
1485 -- initialization to null, do not require initialization as components,
1486 -- since they are explicitly initialized by other means.
1488 procedure Constrain_Array
1490 Check_List : List_Id);
1491 -- Called from Build_Record_Checks.
1492 -- Apply a list of index constraints to an unconstrained array type.
1493 -- The first parameter is the entity for the resulting subtype.
1494 -- Check_List is a list to which the check actions are appended.
1496 procedure Constrain_Index
1499 Check_List : List_Id);
1500 -- Called from Build_Record_Checks.
1501 -- Process an index constraint in a constrained array declaration.
1502 -- The constraint can be a subtype name, or a range with or without
1503 -- an explicit subtype mark. The index is the corresponding index of the
1504 -- unconstrained array. S is the range expression. Check_List is a list
1505 -- to which the check actions are appended.
1507 function Parent_Subtype_Renaming_Discrims return Boolean;
1508 -- Returns True for base types N that rename discriminants, else False
1510 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean;
1511 -- Determines whether a record initialization procedure needs to be
1512 -- generated for the given record type.
1514 ----------------------
1515 -- Build_Assignment --
1516 ----------------------
1518 function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is
1521 Typ : constant Entity_Id := Underlying_Type (Etype (Id));
1522 Kind : Node_Kind := Nkind (N);
1528 Make_Selected_Component (Loc,
1529 Prefix => Make_Identifier (Loc, Name_uInit),
1530 Selector_Name => New_Occurrence_Of (Id, Loc));
1531 Set_Assignment_OK (Lhs);
1533 -- Case of an access attribute applied to the current instance.
1534 -- Replace the reference to the type by a reference to the actual
1535 -- object. (Note that this handles the case of the top level of
1536 -- the expression being given by such an attribute, but does not
1537 -- cover uses nested within an initial value expression. Nested
1538 -- uses are unlikely to occur in practice, but are theoretically
1539 -- possible. It is not clear how to handle them without fully
1540 -- traversing the expression. ???
1542 if Kind = N_Attribute_Reference
1543 and then (Attribute_Name (N) = Name_Unchecked_Access
1545 Attribute_Name (N) = Name_Unrestricted_Access)
1546 and then Is_Entity_Name (Prefix (N))
1547 and then Is_Type (Entity (Prefix (N)))
1548 and then Entity (Prefix (N)) = Rec_Type
1551 Make_Attribute_Reference (Loc,
1552 Prefix => Make_Identifier (Loc, Name_uInit),
1553 Attribute_Name => Name_Unrestricted_Access);
1556 -- Ada 2005 (AI-231): Add the run-time check if required
1558 if Ada_Version >= Ada_05
1559 and then Can_Never_Be_Null (Etype (Id)) -- Lhs
1561 if Nkind (Exp) = N_Null then
1563 Make_Raise_Constraint_Error (Sloc (Exp),
1564 Reason => CE_Null_Not_Allowed));
1566 elsif Present (Etype (Exp))
1567 and then not Can_Never_Be_Null (Etype (Exp))
1569 Install_Null_Excluding_Check (Exp);
1573 -- Take a copy of Exp to ensure that later copies of this
1574 -- component_declaration in derived types see the original tree,
1575 -- not a node rewritten during expansion of the init_proc.
1577 Exp := New_Copy_Tree (Exp);
1580 Make_Assignment_Statement (Loc,
1582 Expression => Exp));
1584 Set_No_Ctrl_Actions (First (Res));
1586 -- Adjust the tag if tagged (because of possible view conversions).
1587 -- Suppress the tag adjustment when Java_VM because JVM tags are
1588 -- represented implicitly in objects.
1590 if Is_Tagged_Type (Typ) and then not Java_VM then
1592 Make_Assignment_Statement (Loc,
1594 Make_Selected_Component (Loc,
1595 Prefix => New_Copy_Tree (Lhs),
1597 New_Reference_To (First_Tag_Component (Typ), Loc)),
1600 Unchecked_Convert_To (RTE (RE_Tag),
1602 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))));
1605 -- Adjust the component if controlled except if it is an
1606 -- aggregate that will be expanded inline
1608 if Kind = N_Qualified_Expression then
1609 Kind := Nkind (Expression (N));
1612 if Controlled_Type (Typ)
1613 and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate)
1615 Append_List_To (Res,
1617 Ref => New_Copy_Tree (Lhs),
1620 Find_Final_List (Etype (Id), New_Copy_Tree (Lhs)),
1621 With_Attach => Make_Integer_Literal (Loc, 1)));
1627 when RE_Not_Available =>
1629 end Build_Assignment;
1631 ------------------------------------
1632 -- Build_Discriminant_Assignments --
1633 ------------------------------------
1635 procedure Build_Discriminant_Assignments (Statement_List : List_Id) is
1637 Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type);
1640 if Has_Discriminants (Rec_Type)
1641 and then not Is_Unchecked_Union (Rec_Type)
1643 D := First_Discriminant (Rec_Type);
1645 while Present (D) loop
1646 -- Don't generate the assignment for discriminants in derived
1647 -- tagged types if the discriminant is a renaming of some
1648 -- ancestor discriminant. This initialization will be done
1649 -- when initializing the _parent field of the derived record.
1651 if Is_Tagged and then
1652 Present (Corresponding_Discriminant (D))
1658 Append_List_To (Statement_List,
1659 Build_Assignment (D,
1660 New_Reference_To (Discriminal (D), Loc)));
1663 Next_Discriminant (D);
1666 end Build_Discriminant_Assignments;
1668 --------------------------
1669 -- Build_Init_Call_Thru --
1670 --------------------------
1672 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is
1673 Parent_Proc : constant Entity_Id :=
1674 Base_Init_Proc (Etype (Rec_Type));
1676 Parent_Type : constant Entity_Id :=
1677 Etype (First_Formal (Parent_Proc));
1679 Uparent_Type : constant Entity_Id :=
1680 Underlying_Type (Parent_Type);
1682 First_Discr_Param : Node_Id;
1684 Parent_Discr : Entity_Id;
1685 First_Arg : Node_Id;
1691 -- First argument (_Init) is the object to be initialized.
1692 -- ??? not sure where to get a reasonable Loc for First_Arg
1695 OK_Convert_To (Parent_Type,
1696 New_Reference_To (Defining_Identifier (First (Parameters)), Loc));
1698 Set_Etype (First_Arg, Parent_Type);
1700 Args := New_List (Convert_Concurrent (First_Arg, Rec_Type));
1702 -- In the tasks case,
1703 -- add _Master as the value of the _Master parameter
1704 -- add _Chain as the value of the _Chain parameter.
1705 -- add _Task_Name as the value of the _Task_Name parameter.
1706 -- At the outer level, these will be variables holding the
1707 -- corresponding values obtained from GNARL or the expander.
1709 -- At inner levels, they will be the parameters passed down through
1710 -- the outer routines.
1712 First_Discr_Param := Next (First (Parameters));
1714 if Has_Task (Rec_Type) then
1715 if Restriction_Active (No_Task_Hierarchy) then
1717 -- See comments in System.Tasking.Initialization.Init_RTS
1720 Append_To (Args, Make_Integer_Literal (Loc, 3));
1722 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
1725 Append_To (Args, Make_Identifier (Loc, Name_uChain));
1726 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
1727 First_Discr_Param := Next (Next (Next (First_Discr_Param)));
1730 -- Append discriminant values
1732 if Has_Discriminants (Uparent_Type) then
1733 pragma Assert (not Is_Tagged_Type (Uparent_Type));
1735 Parent_Discr := First_Discriminant (Uparent_Type);
1736 while Present (Parent_Discr) loop
1738 -- Get the initial value for this discriminant
1739 -- ??? needs to be cleaned up to use parent_Discr_Constr
1743 Discr_Value : Elmt_Id :=
1745 (Stored_Constraint (Rec_Type));
1747 Discr : Entity_Id :=
1748 First_Stored_Discriminant (Uparent_Type);
1750 while Original_Record_Component (Parent_Discr) /= Discr loop
1751 Next_Stored_Discriminant (Discr);
1752 Next_Elmt (Discr_Value);
1755 Arg := Node (Discr_Value);
1758 -- Append it to the list
1760 if Nkind (Arg) = N_Identifier
1761 and then Ekind (Entity (Arg)) = E_Discriminant
1764 New_Reference_To (Discriminal (Entity (Arg)), Loc));
1766 -- Case of access discriminants. We replace the reference
1767 -- to the type by a reference to the actual object.
1769 -- Is above comment right??? Use of New_Copy below seems mighty
1773 Append_To (Args, New_Copy (Arg));
1776 Next_Discriminant (Parent_Discr);
1782 Make_Procedure_Call_Statement (Loc,
1783 Name => New_Occurrence_Of (Parent_Proc, Loc),
1784 Parameter_Associations => Args));
1787 end Build_Init_Call_Thru;
1789 -----------------------------------
1790 -- Build_Offset_To_Top_Functions --
1791 -----------------------------------
1793 procedure Build_Offset_To_Top_Functions is
1795 Body_Node : Node_Id;
1796 Func_Id : Entity_Id;
1797 Spec_Node : Node_Id;
1800 procedure Build_Offset_To_Top_Internal (Typ : Entity_Id);
1801 -- Internal subprogram used to recursively traverse all the ancestors
1803 ----------------------------------
1804 -- Build_Offset_To_Top_Internal --
1805 ----------------------------------
1807 procedure Build_Offset_To_Top_Internal (Typ : Entity_Id) is
1809 -- Climb to the ancestor (if any) handling synchronized interface
1810 -- derivations and private types
1812 if Is_Concurrent_Record_Type (Typ) then
1814 Iface_List : constant List_Id :=
1815 Abstract_Interface_List (Typ);
1817 if Is_Non_Empty_List (Iface_List) then
1818 Build_Offset_To_Top_Internal (Etype (First (Iface_List)));
1822 elsif Present (Full_View (Etype (Typ))) then
1823 if Full_View (Etype (Typ)) /= Typ then
1824 Build_Offset_To_Top_Internal (Full_View (Etype (Typ)));
1827 elsif Etype (Typ) /= Typ then
1828 Build_Offset_To_Top_Internal (Etype (Typ));
1831 if Present (Abstract_Interfaces (Typ))
1832 and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
1834 E := First_Entity (Typ);
1835 while Present (E) loop
1837 and then Chars (E) /= Name_uTag
1839 if Typ = Rec_Type then
1840 Body_Node := New_Node (N_Subprogram_Body, Loc);
1842 Func_Id := Make_Defining_Identifier (Loc,
1843 New_Internal_Name ('F'));
1845 Set_DT_Offset_To_Top_Func (E, Func_Id);
1847 Spec_Node := New_Node (N_Function_Specification, Loc);
1848 Set_Defining_Unit_Name (Spec_Node, Func_Id);
1849 Set_Parameter_Specifications (Spec_Node, New_List (
1850 Make_Parameter_Specification (Loc,
1851 Defining_Identifier =>
1852 Make_Defining_Identifier (Loc, Name_uO),
1854 Parameter_Type => New_Reference_To (Typ, Loc))));
1855 Set_Result_Definition (Spec_Node,
1856 New_Reference_To (RTE (RE_Storage_Offset), Loc));
1858 Set_Specification (Body_Node, Spec_Node);
1859 Set_Declarations (Body_Node, New_List);
1860 Set_Handled_Statement_Sequence (Body_Node,
1861 Make_Handled_Sequence_Of_Statements (Loc,
1862 Statements => New_List (
1863 Make_Return_Statement (Loc,
1865 Make_Attribute_Reference (Loc,
1867 Make_Selected_Component (Loc,
1868 Prefix => Make_Identifier (Loc,
1870 Selector_Name => New_Reference_To
1872 Attribute_Name => Name_Position)))));
1874 Set_Ekind (Func_Id, E_Function);
1875 Set_Mechanism (Func_Id, Default_Mechanism);
1876 Set_Is_Internal (Func_Id, True);
1878 if not Debug_Generated_Code then
1879 Set_Debug_Info_Off (Func_Id);
1882 Analyze (Body_Node);
1884 Append_Freeze_Action (Rec_Type, Body_Node);
1893 end Build_Offset_To_Top_Internal;
1895 -- Start of processing for Build_Offset_To_Top_Functions
1898 if Is_Concurrent_Record_Type (Rec_Type)
1899 and then Is_Empty_List (Abstract_Interface_List (Rec_Type))
1903 elsif Etype (Rec_Type) = Rec_Type
1904 or else not Has_Discriminants (Etype (Rec_Type))
1905 or else No (Abstract_Interfaces (Rec_Type))
1906 or else Is_Empty_Elmt_List (Abstract_Interfaces (Rec_Type))
1911 -- Skip the first _Tag, which is the main tag of the
1912 -- tagged type. Following tags correspond with abstract
1915 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Rec_Type)));
1917 -- Handle private types
1919 if Present (Full_View (Rec_Type)) then
1920 Build_Offset_To_Top_Internal (Full_View (Rec_Type));
1922 Build_Offset_To_Top_Internal (Rec_Type);
1924 end Build_Offset_To_Top_Functions;
1926 --------------------------
1927 -- Build_Init_Procedure --
1928 --------------------------
1930 procedure Build_Init_Procedure is
1931 Body_Node : Node_Id;
1932 Handled_Stmt_Node : Node_Id;
1933 Parameters : List_Id;
1934 Proc_Spec_Node : Node_Id;
1935 Body_Stmts : List_Id;
1936 Record_Extension_Node : Node_Id;
1940 Body_Stmts := New_List;
1941 Body_Node := New_Node (N_Subprogram_Body, Loc);
1944 Make_Defining_Identifier (Loc,
1945 Chars => Make_Init_Proc_Name (Rec_Type));
1946 Set_Ekind (Proc_Id, E_Procedure);
1948 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
1949 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
1951 Parameters := Init_Formals (Rec_Type);
1952 Append_List_To (Parameters,
1953 Build_Discriminant_Formals (Rec_Type, True));
1955 -- For tagged types, we add a flag to indicate whether the routine
1956 -- is called to initialize a parent component in the init_proc of
1957 -- a type extension. If the flag is false, we do not set the tag
1958 -- because it has been set already in the extension.
1960 if Is_Tagged_Type (Rec_Type)
1961 and then not Is_CPP_Class (Rec_Type)
1964 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1966 Append_To (Parameters,
1967 Make_Parameter_Specification (Loc,
1968 Defining_Identifier => Set_Tag,
1969 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
1970 Expression => New_Occurrence_Of (Standard_True, Loc)));
1973 Set_Parameter_Specifications (Proc_Spec_Node, Parameters);
1974 Set_Specification (Body_Node, Proc_Spec_Node);
1975 Set_Declarations (Body_Node, New_List);
1977 if Parent_Subtype_Renaming_Discrims then
1979 -- N is a Derived_Type_Definition that renames the parameters
1980 -- of the ancestor type. We initialize it by expanding our
1981 -- discriminants and call the ancestor _init_proc with a
1982 -- type-converted object
1984 Append_List_To (Body_Stmts,
1985 Build_Init_Call_Thru (Parameters));
1987 elsif Nkind (Type_Definition (N)) = N_Record_Definition then
1988 Build_Discriminant_Assignments (Body_Stmts);
1990 if not Null_Present (Type_Definition (N)) then
1991 Append_List_To (Body_Stmts,
1992 Build_Init_Statements (
1993 Component_List (Type_Definition (N))));
1997 -- N is a Derived_Type_Definition with a possible non-empty
1998 -- extension. The initialization of a type extension consists
1999 -- in the initialization of the components in the extension.
2001 Build_Discriminant_Assignments (Body_Stmts);
2003 Record_Extension_Node :=
2004 Record_Extension_Part (Type_Definition (N));
2006 if not Null_Present (Record_Extension_Node) then
2008 Stmts : constant List_Id :=
2009 Build_Init_Statements (
2010 Component_List (Record_Extension_Node));
2013 -- The parent field must be initialized first because
2014 -- the offset of the new discriminants may depend on it
2016 Prepend_To (Body_Stmts, Remove_Head (Stmts));
2017 Append_List_To (Body_Stmts, Stmts);
2022 -- Add here the assignment to instantiate the Tag
2024 -- The assignement corresponds to the code:
2026 -- _Init._Tag := Typ'Tag;
2028 -- Suppress the tag assignment when Java_VM because JVM tags are
2029 -- represented implicitly in objects. It is also suppressed in
2030 -- case of CPP_Class types because in this case the tag is
2031 -- initialized in the C++ side.
2033 if Is_Tagged_Type (Rec_Type)
2034 and then not Is_CPP_Class (Rec_Type)
2035 and then not Java_VM
2038 Make_Assignment_Statement (Loc,
2040 Make_Selected_Component (Loc,
2041 Prefix => Make_Identifier (Loc, Name_uInit),
2043 New_Reference_To (First_Tag_Component (Rec_Type), Loc)),
2047 (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc));
2049 -- The tag must be inserted before the assignments to other
2050 -- components, because the initial value of the component may
2051 -- depend ot the tag (eg. through a dispatching operation on
2052 -- an access to the current type). The tag assignment is not done
2053 -- when initializing the parent component of a type extension,
2054 -- because in that case the tag is set in the extension.
2055 -- Extensions of imported C++ classes add a final complication,
2056 -- because we cannot inhibit tag setting in the constructor for
2057 -- the parent. In that case we insert the tag initialization
2058 -- after the calls to initialize the parent.
2060 if not Is_CPP_Class (Etype (Rec_Type)) then
2062 Make_If_Statement (Loc,
2063 Condition => New_Occurrence_Of (Set_Tag, Loc),
2064 Then_Statements => New_List (Init_Tag));
2066 Prepend_To (Body_Stmts, Init_Tag);
2070 Nod : Node_Id := First (Body_Stmts);
2074 -- We assume the first init_proc call is for the parent
2076 while Present (Next (Nod))
2077 and then (Nkind (Nod) /= N_Procedure_Call_Statement
2078 or else not Is_Init_Proc (Name (Nod)))
2084 -- ancestor_constructor (_init.parent);
2086 -- inherit_prim_ops (_init._tag, new_dt, num_prims);
2087 -- _init._tag := new_dt;
2091 Build_Inherit_Prims (Loc,
2093 Make_Selected_Component (Loc,
2094 Prefix => Make_Identifier (Loc, Name_uInit),
2097 (First_Tag_Component (Rec_Type), Loc)),
2100 (Node (First_Elmt (Access_Disp_Table (Rec_Type))),
2104 (DT_Entry_Count (First_Tag_Component (Rec_Type))));
2107 Make_If_Statement (Loc,
2108 Condition => New_Occurrence_Of (Set_Tag, Loc),
2109 Then_Statements => New_List (New_N, Init_Tag));
2111 Insert_After (Nod, Init_Tag);
2113 -- We have inherited the whole contents of the DT table
2114 -- from the CPP side. Therefore all our previous initia-
2115 -- lization has been lost and we must refill entries
2116 -- associated with Ada primitives. This needs more work
2117 -- to avoid its execution each time an object is
2125 E := First_Elmt (Primitive_Operations (Rec_Type));
2126 while Present (E) loop
2129 if not Is_Imported (Prim)
2130 and then Convention (Prim) = Convention_CPP
2131 and then not Present (Abstract_Interface_Alias
2134 Insert_After (Init_Tag,
2135 Fill_DT_Entry (Loc, Prim));
2144 -- Ada 2005 (AI-251): Initialization of all the tags
2145 -- corresponding with abstract interfaces
2147 if Ada_Version >= Ada_05
2148 and then not Is_Interface (Rec_Type)
2152 Target => Make_Identifier (Loc, Name_uInit),
2153 Stmts_List => Body_Stmts);
2157 Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc);
2158 Set_Statements (Handled_Stmt_Node, Body_Stmts);
2159 Set_Exception_Handlers (Handled_Stmt_Node, No_List);
2160 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
2162 if not Debug_Generated_Code then
2163 Set_Debug_Info_Off (Proc_Id);
2166 -- Associate Init_Proc with type, and determine if the procedure
2167 -- is null (happens because of the Initialize_Scalars pragma case,
2168 -- where we have to generate a null procedure in case it is called
2169 -- by a client with Initialize_Scalars set). Such procedures have
2170 -- to be generated, but do not have to be called, so we mark them
2171 -- as null to suppress the call.
2173 Set_Init_Proc (Rec_Type, Proc_Id);
2175 if List_Length (Body_Stmts) = 1
2176 and then Nkind (First (Body_Stmts)) = N_Null_Statement
2178 Set_Is_Null_Init_Proc (Proc_Id);
2180 end Build_Init_Procedure;
2182 ---------------------------
2183 -- Build_Init_Statements --
2184 ---------------------------
2186 function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
2187 Check_List : constant List_Id := New_List;
2189 Statement_List : List_Id;
2192 Per_Object_Constraint_Components : Boolean;
2200 function Has_Access_Constraint (E : Entity_Id) return Boolean;
2201 -- Components with access discriminants that depend on the current
2202 -- instance must be initialized after all other components.
2204 ---------------------------
2205 -- Has_Access_Constraint --
2206 ---------------------------
2208 function Has_Access_Constraint (E : Entity_Id) return Boolean is
2210 T : constant Entity_Id := Etype (E);
2213 if Has_Per_Object_Constraint (E)
2214 and then Has_Discriminants (T)
2216 Disc := First_Discriminant (T);
2217 while Present (Disc) loop
2218 if Is_Access_Type (Etype (Disc)) then
2222 Next_Discriminant (Disc);
2229 end Has_Access_Constraint;
2231 -- Start of processing for Build_Init_Statements
2234 if Null_Present (Comp_List) then
2235 return New_List (Make_Null_Statement (Loc));
2238 Statement_List := New_List;
2240 -- Loop through components, skipping pragmas, in 2 steps. The first
2241 -- step deals with regular components. The second step deals with
2242 -- components have per object constraints, and no explicit initia-
2245 Per_Object_Constraint_Components := False;
2247 -- First step : regular components
2249 Decl := First_Non_Pragma (Component_Items (Comp_List));
2250 while Present (Decl) loop
2253 (Subtype_Indication (Component_Definition (Decl)), Check_List);
2255 Id := Defining_Identifier (Decl);
2258 if Has_Access_Constraint (Id)
2259 and then No (Expression (Decl))
2261 -- Skip processing for now and ask for a second pass
2263 Per_Object_Constraint_Components := True;
2266 -- Case of explicit initialization
2268 if Present (Expression (Decl)) then
2269 Stmts := Build_Assignment (Id, Expression (Decl));
2271 -- Case of composite component with its own Init_Proc
2273 elsif not Is_Interface (Typ)
2274 and then Has_Non_Null_Base_Init_Proc (Typ)
2277 Build_Initialization_Call
2279 Make_Selected_Component (Loc,
2280 Prefix => Make_Identifier (Loc, Name_uInit),
2281 Selector_Name => New_Occurrence_Of (Id, Loc)),
2283 In_Init_Proc => True,
2284 Enclos_Type => Rec_Type,
2285 Discr_Map => Discr_Map);
2287 Clean_Task_Names (Typ, Proc_Id);
2289 -- Case of component needing simple initialization
2291 elsif Component_Needs_Simple_Initialization (Typ) then
2294 (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id)));
2296 -- Nothing needed for this case
2302 if Present (Check_List) then
2303 Append_List_To (Statement_List, Check_List);
2306 if Present (Stmts) then
2308 -- Add the initialization of the record controller before
2309 -- the _Parent field is attached to it when the attachment
2310 -- can occur. It does not work to simply initialize the
2311 -- controller first: it must be initialized after the parent
2312 -- if the parent holds discriminants that can be used
2313 -- to compute the offset of the controller. We assume here
2314 -- that the last statement of the initialization call is the
2315 -- attachment of the parent (see Build_Initialization_Call)
2317 if Chars (Id) = Name_uController
2318 and then Rec_Type /= Etype (Rec_Type)
2319 and then Has_Controlled_Component (Etype (Rec_Type))
2320 and then Has_New_Controlled_Component (Rec_Type)
2322 Insert_List_Before (Last (Statement_List), Stmts);
2324 Append_List_To (Statement_List, Stmts);
2329 Next_Non_Pragma (Decl);
2332 if Per_Object_Constraint_Components then
2334 -- Second pass: components with per-object constraints
2336 Decl := First_Non_Pragma (Component_Items (Comp_List));
2338 while Present (Decl) loop
2340 Id := Defining_Identifier (Decl);
2343 if Has_Access_Constraint (Id)
2344 and then No (Expression (Decl))
2346 if Has_Non_Null_Base_Init_Proc (Typ) then
2347 Append_List_To (Statement_List,
2348 Build_Initialization_Call (Loc,
2349 Make_Selected_Component (Loc,
2350 Prefix => Make_Identifier (Loc, Name_uInit),
2351 Selector_Name => New_Occurrence_Of (Id, Loc)),
2353 In_Init_Proc => True,
2354 Enclos_Type => Rec_Type,
2355 Discr_Map => Discr_Map));
2357 Clean_Task_Names (Typ, Proc_Id);
2359 elsif Component_Needs_Simple_Initialization (Typ) then
2360 Append_List_To (Statement_List,
2362 (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id))));
2366 Next_Non_Pragma (Decl);
2370 -- Process the variant part
2372 if Present (Variant_Part (Comp_List)) then
2373 Alt_List := New_List;
2374 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
2376 while Present (Variant) loop
2377 Loc := Sloc (Variant);
2378 Append_To (Alt_List,
2379 Make_Case_Statement_Alternative (Loc,
2381 New_Copy_List (Discrete_Choices (Variant)),
2383 Build_Init_Statements (Component_List (Variant))));
2385 Next_Non_Pragma (Variant);
2388 -- The expression of the case statement which is a reference
2389 -- to one of the discriminants is replaced by the appropriate
2390 -- formal parameter of the initialization procedure.
2392 Append_To (Statement_List,
2393 Make_Case_Statement (Loc,
2395 New_Reference_To (Discriminal (
2396 Entity (Name (Variant_Part (Comp_List)))), Loc),
2397 Alternatives => Alt_List));
2400 -- For a task record type, add the task create call and calls
2401 -- to bind any interrupt (signal) entries.
2403 if Is_Task_Record_Type (Rec_Type) then
2405 -- In the case of the restricted run time the ATCB has already
2406 -- been preallocated.
2408 if Restricted_Profile then
2409 Append_To (Statement_List,
2410 Make_Assignment_Statement (Loc,
2411 Name => Make_Selected_Component (Loc,
2412 Prefix => Make_Identifier (Loc, Name_uInit),
2413 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2414 Expression => Make_Attribute_Reference (Loc,
2416 Make_Selected_Component (Loc,
2417 Prefix => Make_Identifier (Loc, Name_uInit),
2419 Make_Identifier (Loc, Name_uATCB)),
2420 Attribute_Name => Name_Unchecked_Access)));
2423 Append_To (Statement_List, Make_Task_Create_Call (Rec_Type));
2426 Task_Type : constant Entity_Id :=
2427 Corresponding_Concurrent_Type (Rec_Type);
2428 Task_Decl : constant Node_Id := Parent (Task_Type);
2429 Task_Def : constant Node_Id := Task_Definition (Task_Decl);
2434 if Present (Task_Def) then
2435 Vis_Decl := First (Visible_Declarations (Task_Def));
2436 while Present (Vis_Decl) loop
2437 Loc := Sloc (Vis_Decl);
2439 if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then
2440 if Get_Attribute_Id (Chars (Vis_Decl)) =
2443 Ent := Entity (Name (Vis_Decl));
2445 if Ekind (Ent) = E_Entry then
2446 Append_To (Statement_List,
2447 Make_Procedure_Call_Statement (Loc,
2448 Name => New_Reference_To (
2449 RTE (RE_Bind_Interrupt_To_Entry), Loc),
2450 Parameter_Associations => New_List (
2451 Make_Selected_Component (Loc,
2453 Make_Identifier (Loc, Name_uInit),
2455 Make_Identifier (Loc, Name_uTask_Id)),
2456 Entry_Index_Expression (
2457 Loc, Ent, Empty, Task_Type),
2458 Expression (Vis_Decl))));
2469 -- For a protected type, add statements generated by
2470 -- Make_Initialize_Protection.
2472 if Is_Protected_Record_Type (Rec_Type) then
2473 Append_List_To (Statement_List,
2474 Make_Initialize_Protection (Rec_Type));
2477 -- If no initializations when generated for component declarations
2478 -- corresponding to this Statement_List, append a null statement
2479 -- to the Statement_List to make it a valid Ada tree.
2481 if Is_Empty_List (Statement_List) then
2482 Append (New_Node (N_Null_Statement, Loc), Statement_List);
2485 return Statement_List;
2488 when RE_Not_Available =>
2490 end Build_Init_Statements;
2492 -------------------------
2493 -- Build_Record_Checks --
2494 -------------------------
2496 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is
2497 Subtype_Mark_Id : Entity_Id;
2500 if Nkind (S) = N_Subtype_Indication then
2501 Find_Type (Subtype_Mark (S));
2502 Subtype_Mark_Id := Entity (Subtype_Mark (S));
2504 -- Remaining processing depends on type
2506 case Ekind (Subtype_Mark_Id) is
2509 Constrain_Array (S, Check_List);
2515 end Build_Record_Checks;
2517 -------------------------------------------
2518 -- Component_Needs_Simple_Initialization --
2519 -------------------------------------------
2521 function Component_Needs_Simple_Initialization
2522 (T : Entity_Id) return Boolean
2526 Needs_Simple_Initialization (T)
2527 and then not Is_RTE (T, RE_Tag)
2529 -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
2531 and then not Is_RTE (T, RE_Interface_Tag);
2532 end Component_Needs_Simple_Initialization;
2534 ---------------------
2535 -- Constrain_Array --
2536 ---------------------
2538 procedure Constrain_Array
2540 Check_List : List_Id)
2542 C : constant Node_Id := Constraint (SI);
2543 Number_Of_Constraints : Nat := 0;
2548 T := Entity (Subtype_Mark (SI));
2550 if Ekind (T) in Access_Kind then
2551 T := Designated_Type (T);
2554 S := First (Constraints (C));
2556 while Present (S) loop
2557 Number_Of_Constraints := Number_Of_Constraints + 1;
2561 -- In either case, the index constraint must provide a discrete
2562 -- range for each index of the array type and the type of each
2563 -- discrete range must be the same as that of the corresponding
2564 -- index. (RM 3.6.1)
2566 S := First (Constraints (C));
2567 Index := First_Index (T);
2570 -- Apply constraints to each index type
2572 for J in 1 .. Number_Of_Constraints loop
2573 Constrain_Index (Index, S, Check_List);
2578 end Constrain_Array;
2580 ---------------------
2581 -- Constrain_Index --
2582 ---------------------
2584 procedure Constrain_Index
2587 Check_List : List_Id)
2589 T : constant Entity_Id := Etype (Index);
2592 if Nkind (S) = N_Range then
2593 Process_Range_Expr_In_Decl (S, T, Check_List);
2595 end Constrain_Index;
2597 --------------------------------------
2598 -- Parent_Subtype_Renaming_Discrims --
2599 --------------------------------------
2601 function Parent_Subtype_Renaming_Discrims return Boolean is
2606 if Base_Type (Pe) /= Pe then
2611 or else not Has_Discriminants (Pe)
2612 or else Is_Constrained (Pe)
2613 or else Is_Tagged_Type (Pe)
2618 -- If there are no explicit stored discriminants we have inherited
2619 -- the root type discriminants so far, so no renamings occurred.
2621 if First_Discriminant (Pe) = First_Stored_Discriminant (Pe) then
2625 -- Check if we have done some trivial renaming of the parent
2626 -- discriminants, i.e. someting like
2628 -- type DT (X1,X2: int) is new PT (X1,X2);
2630 De := First_Discriminant (Pe);
2631 Dp := First_Discriminant (Etype (Pe));
2633 while Present (De) loop
2634 pragma Assert (Present (Dp));
2636 if Corresponding_Discriminant (De) /= Dp then
2640 Next_Discriminant (De);
2641 Next_Discriminant (Dp);
2644 return Present (Dp);
2645 end Parent_Subtype_Renaming_Discrims;
2647 ------------------------
2648 -- Requires_Init_Proc --
2649 ------------------------
2651 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is
2652 Comp_Decl : Node_Id;
2657 -- Definitely do not need one if specifically suppressed
2659 if Suppress_Init_Proc (Rec_Id) then
2663 -- If it is a type derived from a type with unknown discriminants,
2664 -- we cannot build an initialization procedure for it.
2666 if Has_Unknown_Discriminants (Rec_Id) then
2670 -- Otherwise we need to generate an initialization procedure if
2671 -- Is_CPP_Class is False and at least one of the following applies:
2673 -- 1. Discriminants are present, since they need to be initialized
2674 -- with the appropriate discriminant constraint expressions.
2675 -- However, the discriminant of an unchecked union does not
2676 -- count, since the discriminant is not present.
2678 -- 2. The type is a tagged type, since the implicit Tag component
2679 -- needs to be initialized with a pointer to the dispatch table.
2681 -- 3. The type contains tasks
2683 -- 4. One or more components has an initial value
2685 -- 5. One or more components is for a type which itself requires
2686 -- an initialization procedure.
2688 -- 6. One or more components is a type that requires simple
2689 -- initialization (see Needs_Simple_Initialization), except
2690 -- that types Tag and Interface_Tag are excluded, since fields
2691 -- of these types are initialized by other means.
2693 -- 7. The type is the record type built for a task type (since at
2694 -- the very least, Create_Task must be called)
2696 -- 8. The type is the record type built for a protected type (since
2697 -- at least Initialize_Protection must be called)
2699 -- 9. The type is marked as a public entity. The reason we add this
2700 -- case (even if none of the above apply) is to properly handle
2701 -- Initialize_Scalars. If a package is compiled without an IS
2702 -- pragma, and the client is compiled with an IS pragma, then
2703 -- the client will think an initialization procedure is present
2704 -- and call it, when in fact no such procedure is required, but
2705 -- since the call is generated, there had better be a routine
2706 -- at the other end of the call, even if it does nothing!)
2708 -- Note: the reason we exclude the CPP_Class case is because in this
2709 -- case the initialization is performed in the C++ side.
2711 if Is_CPP_Class (Rec_Id) then
2714 elsif not Restriction_Active (No_Initialize_Scalars)
2715 and then Is_Public (Rec_Id)
2719 elsif (Has_Discriminants (Rec_Id)
2720 and then not Is_Unchecked_Union (Rec_Id))
2721 or else Is_Tagged_Type (Rec_Id)
2722 or else Is_Concurrent_Record_Type (Rec_Id)
2723 or else Has_Task (Rec_Id)
2728 Id := First_Component (Rec_Id);
2730 while Present (Id) loop
2731 Comp_Decl := Parent (Id);
2734 if Present (Expression (Comp_Decl))
2735 or else Has_Non_Null_Base_Init_Proc (Typ)
2736 or else Component_Needs_Simple_Initialization (Typ)
2741 Next_Component (Id);
2745 end Requires_Init_Proc;
2747 -- Start of processing for Build_Record_Init_Proc
2750 Rec_Type := Defining_Identifier (N);
2752 -- This may be full declaration of a private type, in which case
2753 -- the visible entity is a record, and the private entity has been
2754 -- exchanged with it in the private part of the current package.
2755 -- The initialization procedure is built for the record type, which
2756 -- is retrievable from the private entity.
2758 if Is_Incomplete_Or_Private_Type (Rec_Type) then
2759 Rec_Type := Underlying_Type (Rec_Type);
2762 -- If there are discriminants, build the discriminant map to replace
2763 -- discriminants by their discriminals in complex bound expressions.
2764 -- These only arise for the corresponding records of protected types.
2766 if Is_Concurrent_Record_Type (Rec_Type)
2767 and then Has_Discriminants (Rec_Type)
2772 Disc := First_Discriminant (Rec_Type);
2773 while Present (Disc) loop
2774 Append_Elmt (Disc, Discr_Map);
2775 Append_Elmt (Discriminal (Disc), Discr_Map);
2776 Next_Discriminant (Disc);
2781 -- Derived types that have no type extension can use the initialization
2782 -- procedure of their parent and do not need a procedure of their own.
2783 -- This is only correct if there are no representation clauses for the
2784 -- type or its parent, and if the parent has in fact been frozen so
2785 -- that its initialization procedure exists.
2787 if Is_Derived_Type (Rec_Type)
2788 and then not Is_Tagged_Type (Rec_Type)
2789 and then not Is_Unchecked_Union (Rec_Type)
2790 and then not Has_New_Non_Standard_Rep (Rec_Type)
2791 and then not Parent_Subtype_Renaming_Discrims
2792 and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type))
2794 Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type);
2796 -- Otherwise if we need an initialization procedure, then build one,
2797 -- mark it as public and inlinable and as having a completion.
2799 elsif Requires_Init_Proc (Rec_Type)
2800 or else Is_Unchecked_Union (Rec_Type)
2802 Build_Offset_To_Top_Functions;
2803 Build_Init_Procedure;
2804 Set_Is_Public (Proc_Id, Is_Public (Pe));
2806 -- The initialization of protected records is not worth inlining.
2807 -- In addition, when compiled for another unit for inlining purposes,
2808 -- it may make reference to entities that have not been elaborated
2809 -- yet. The initialization of controlled records contains a nested
2810 -- clean-up procedure that makes it impractical to inline as well,
2811 -- and leads to undefined symbols if inlined in a different unit.
2812 -- Similar considerations apply to task types.
2814 if not Is_Concurrent_Type (Rec_Type)
2815 and then not Has_Task (Rec_Type)
2816 and then not Controlled_Type (Rec_Type)
2818 Set_Is_Inlined (Proc_Id);
2821 Set_Is_Internal (Proc_Id);
2822 Set_Has_Completion (Proc_Id);
2824 if not Debug_Generated_Code then
2825 Set_Debug_Info_Off (Proc_Id);
2828 end Build_Record_Init_Proc;
2830 ----------------------------
2831 -- Build_Slice_Assignment --
2832 ----------------------------
2834 -- Generates the following subprogram:
2837 -- (Source, Target : Array_Type,
2838 -- Left_Lo, Left_Hi, Right_Lo, Right_Hi : Index;
2855 -- exit when Li1 < Left_Lo;
2857 -- exit when Li1 > Left_Hi;
2860 -- Target (Li1) := Source (Ri1);
2863 -- Li1 := Index'pred (Li1);
2864 -- Ri1 := Index'pred (Ri1);
2866 -- Li1 := Index'succ (Li1);
2867 -- Ri1 := Index'succ (Ri1);
2872 procedure Build_Slice_Assignment (Typ : Entity_Id) is
2873 Loc : constant Source_Ptr := Sloc (Typ);
2874 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
2876 -- Build formal parameters of procedure
2878 Larray : constant Entity_Id :=
2879 Make_Defining_Identifier
2880 (Loc, Chars => New_Internal_Name ('A'));
2881 Rarray : constant Entity_Id :=
2882 Make_Defining_Identifier
2883 (Loc, Chars => New_Internal_Name ('R'));
2884 Left_Lo : constant Entity_Id :=
2885 Make_Defining_Identifier
2886 (Loc, Chars => New_Internal_Name ('L'));
2887 Left_Hi : constant Entity_Id :=
2888 Make_Defining_Identifier
2889 (Loc, Chars => New_Internal_Name ('L'));
2890 Right_Lo : constant Entity_Id :=
2891 Make_Defining_Identifier
2892 (Loc, Chars => New_Internal_Name ('R'));
2893 Right_Hi : constant Entity_Id :=
2894 Make_Defining_Identifier
2895 (Loc, Chars => New_Internal_Name ('R'));
2896 Rev : constant Entity_Id :=
2897 Make_Defining_Identifier
2898 (Loc, Chars => New_Internal_Name ('D'));
2899 Proc_Name : constant Entity_Id :=
2900 Make_Defining_Identifier (Loc,
2901 Chars => Make_TSS_Name (Typ, TSS_Slice_Assign));
2903 Lnn : constant Entity_Id :=
2904 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
2905 Rnn : constant Entity_Id :=
2906 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2907 -- Subscripts for left and right sides
2914 -- Build declarations for indices
2919 Make_Object_Declaration (Loc,
2920 Defining_Identifier => Lnn,
2921 Object_Definition =>
2922 New_Occurrence_Of (Index, Loc)));
2925 Make_Object_Declaration (Loc,
2926 Defining_Identifier => Rnn,
2927 Object_Definition =>
2928 New_Occurrence_Of (Index, Loc)));
2932 -- Build initializations for indices
2935 F_Init : constant List_Id := New_List;
2936 B_Init : constant List_Id := New_List;
2940 Make_Assignment_Statement (Loc,
2941 Name => New_Occurrence_Of (Lnn, Loc),
2942 Expression => New_Occurrence_Of (Left_Lo, Loc)));
2945 Make_Assignment_Statement (Loc,
2946 Name => New_Occurrence_Of (Rnn, Loc),
2947 Expression => New_Occurrence_Of (Right_Lo, Loc)));
2950 Make_Assignment_Statement (Loc,
2951 Name => New_Occurrence_Of (Lnn, Loc),
2952 Expression => New_Occurrence_Of (Left_Hi, Loc)));
2955 Make_Assignment_Statement (Loc,
2956 Name => New_Occurrence_Of (Rnn, Loc),
2957 Expression => New_Occurrence_Of (Right_Hi, Loc)));
2960 Make_If_Statement (Loc,
2961 Condition => New_Occurrence_Of (Rev, Loc),
2962 Then_Statements => B_Init,
2963 Else_Statements => F_Init));
2966 -- Now construct the assignment statement
2969 Make_Loop_Statement (Loc,
2970 Statements => New_List (
2971 Make_Assignment_Statement (Loc,
2973 Make_Indexed_Component (Loc,
2974 Prefix => New_Occurrence_Of (Larray, Loc),
2975 Expressions => New_List (New_Occurrence_Of (Lnn, Loc))),
2977 Make_Indexed_Component (Loc,
2978 Prefix => New_Occurrence_Of (Rarray, Loc),
2979 Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
2980 End_Label => Empty);
2982 -- Build exit condition
2985 F_Ass : constant List_Id := New_List;
2986 B_Ass : constant List_Id := New_List;
2990 Make_Exit_Statement (Loc,
2993 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
2994 Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
2997 Make_Exit_Statement (Loc,
3000 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
3001 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
3003 Prepend_To (Statements (Loops),
3004 Make_If_Statement (Loc,
3005 Condition => New_Occurrence_Of (Rev, Loc),
3006 Then_Statements => B_Ass,
3007 Else_Statements => F_Ass));
3010 -- Build the increment/decrement statements
3013 F_Ass : constant List_Id := New_List;
3014 B_Ass : constant List_Id := New_List;
3018 Make_Assignment_Statement (Loc,
3019 Name => New_Occurrence_Of (Lnn, Loc),
3021 Make_Attribute_Reference (Loc,
3023 New_Occurrence_Of (Index, Loc),
3024 Attribute_Name => Name_Succ,
3025 Expressions => New_List (
3026 New_Occurrence_Of (Lnn, Loc)))));
3029 Make_Assignment_Statement (Loc,
3030 Name => New_Occurrence_Of (Rnn, Loc),
3032 Make_Attribute_Reference (Loc,
3034 New_Occurrence_Of (Index, Loc),
3035 Attribute_Name => Name_Succ,
3036 Expressions => New_List (
3037 New_Occurrence_Of (Rnn, Loc)))));
3040 Make_Assignment_Statement (Loc,
3041 Name => New_Occurrence_Of (Lnn, Loc),
3043 Make_Attribute_Reference (Loc,
3045 New_Occurrence_Of (Index, Loc),
3046 Attribute_Name => Name_Pred,
3047 Expressions => New_List (
3048 New_Occurrence_Of (Lnn, Loc)))));
3051 Make_Assignment_Statement (Loc,
3052 Name => New_Occurrence_Of (Rnn, Loc),
3054 Make_Attribute_Reference (Loc,
3056 New_Occurrence_Of (Index, Loc),
3057 Attribute_Name => Name_Pred,
3058 Expressions => New_List (
3059 New_Occurrence_Of (Rnn, Loc)))));
3061 Append_To (Statements (Loops),
3062 Make_If_Statement (Loc,
3063 Condition => New_Occurrence_Of (Rev, Loc),
3064 Then_Statements => B_Ass,
3065 Else_Statements => F_Ass));
3068 Append_To (Stats, Loops);
3072 Formals : List_Id := New_List;
3075 Formals := New_List (
3076 Make_Parameter_Specification (Loc,
3077 Defining_Identifier => Larray,
3078 Out_Present => True,
3080 New_Reference_To (Base_Type (Typ), Loc)),
3082 Make_Parameter_Specification (Loc,
3083 Defining_Identifier => Rarray,
3085 New_Reference_To (Base_Type (Typ), Loc)),
3087 Make_Parameter_Specification (Loc,
3088 Defining_Identifier => Left_Lo,
3090 New_Reference_To (Index, Loc)),
3092 Make_Parameter_Specification (Loc,
3093 Defining_Identifier => Left_Hi,
3095 New_Reference_To (Index, Loc)),
3097 Make_Parameter_Specification (Loc,
3098 Defining_Identifier => Right_Lo,
3100 New_Reference_To (Index, Loc)),
3102 Make_Parameter_Specification (Loc,
3103 Defining_Identifier => Right_Hi,
3105 New_Reference_To (Index, Loc)));
3108 Make_Parameter_Specification (Loc,
3109 Defining_Identifier => Rev,
3111 New_Reference_To (Standard_Boolean, Loc)));
3114 Make_Procedure_Specification (Loc,
3115 Defining_Unit_Name => Proc_Name,
3116 Parameter_Specifications => Formals);
3119 Make_Subprogram_Body (Loc,
3120 Specification => Spec,
3121 Declarations => Decls,
3122 Handled_Statement_Sequence =>
3123 Make_Handled_Sequence_Of_Statements (Loc,
3124 Statements => Stats)));
3127 Set_TSS (Typ, Proc_Name);
3128 Set_Is_Pure (Proc_Name);
3129 end Build_Slice_Assignment;
3131 ------------------------------------
3132 -- Build_Variant_Record_Equality --
3133 ------------------------------------
3137 -- function _Equality (X, Y : T) return Boolean is
3139 -- -- Compare discriminants
3141 -- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then
3145 -- -- Compare components
3147 -- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then
3151 -- -- Compare variant part
3155 -- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then
3160 -- if False or else X.Cn /= Y.Cn then
3167 procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
3168 Loc : constant Source_Ptr := Sloc (Typ);
3170 F : constant Entity_Id :=
3171 Make_Defining_Identifier (Loc,
3172 Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
3174 X : constant Entity_Id :=
3175 Make_Defining_Identifier (Loc,
3178 Y : constant Entity_Id :=
3179 Make_Defining_Identifier (Loc,
3182 Def : constant Node_Id := Parent (Typ);
3183 Comps : constant Node_Id := Component_List (Type_Definition (Def));
3184 Stmts : constant List_Id := New_List;
3185 Pspecs : constant List_Id := New_List;
3188 -- Derived Unchecked_Union types no longer inherit the equality function
3191 if Is_Derived_Type (Typ)
3192 and then not Is_Unchecked_Union (Typ)
3193 and then not Has_New_Non_Standard_Rep (Typ)
3196 Parent_Eq : constant Entity_Id :=
3197 TSS (Root_Type (Typ), TSS_Composite_Equality);
3200 if Present (Parent_Eq) then
3201 Copy_TSS (Parent_Eq, Typ);
3208 Make_Subprogram_Body (Loc,
3210 Make_Function_Specification (Loc,
3211 Defining_Unit_Name => F,
3212 Parameter_Specifications => Pspecs,
3213 Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
3214 Declarations => New_List,
3215 Handled_Statement_Sequence =>
3216 Make_Handled_Sequence_Of_Statements (Loc,
3217 Statements => Stmts)));
3220 Make_Parameter_Specification (Loc,
3221 Defining_Identifier => X,
3222 Parameter_Type => New_Reference_To (Typ, Loc)));
3225 Make_Parameter_Specification (Loc,
3226 Defining_Identifier => Y,
3227 Parameter_Type => New_Reference_To (Typ, Loc)));
3229 -- Unchecked_Unions require additional machinery to support equality.
3230 -- Two extra parameters (A and B) are added to the equality function
3231 -- parameter list in order to capture the inferred values of the
3232 -- discriminants in later calls.
3234 if Is_Unchecked_Union (Typ) then
3236 Discr_Type : constant Node_Id := Etype (First_Discriminant (Typ));
3238 A : constant Node_Id :=
3239 Make_Defining_Identifier (Loc,
3242 B : constant Node_Id :=
3243 Make_Defining_Identifier (Loc,
3247 -- Add A and B to the parameter list
3250 Make_Parameter_Specification (Loc,
3251 Defining_Identifier => A,
3252 Parameter_Type => New_Reference_To (Discr_Type, Loc)));
3255 Make_Parameter_Specification (Loc,
3256 Defining_Identifier => B,
3257 Parameter_Type => New_Reference_To (Discr_Type, Loc)));
3259 -- Generate the following header code to compare the inferred
3267 Make_If_Statement (Loc,
3270 Left_Opnd => New_Reference_To (A, Loc),
3271 Right_Opnd => New_Reference_To (B, Loc)),
3272 Then_Statements => New_List (
3273 Make_Return_Statement (Loc,
3274 Expression => New_Occurrence_Of (Standard_False, Loc)))));
3276 -- Generate component-by-component comparison. Note that we must
3277 -- propagate one of the inferred discriminant formals to act as
3278 -- the case statement switch.
3280 Append_List_To (Stmts,
3281 Make_Eq_Case (Typ, Comps, A));
3285 -- Normal case (not unchecked union)
3290 Discriminant_Specifications (Def)));
3292 Append_List_To (Stmts,
3293 Make_Eq_Case (Typ, Comps));
3297 Make_Return_Statement (Loc,
3298 Expression => New_Reference_To (Standard_True, Loc)));
3303 if not Debug_Generated_Code then
3304 Set_Debug_Info_Off (F);
3306 end Build_Variant_Record_Equality;
3308 -----------------------------
3309 -- Check_Stream_Attributes --
3310 -----------------------------
3312 procedure Check_Stream_Attributes (Typ : Entity_Id) is
3314 Par_Read : constant Boolean :=
3315 Stream_Attribute_Available (Typ, TSS_Stream_Read)
3316 and then not Has_Specified_Stream_Read (Typ);
3317 Par_Write : constant Boolean :=
3318 Stream_Attribute_Available (Typ, TSS_Stream_Write)
3319 and then not Has_Specified_Stream_Write (Typ);
3321 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type);
3322 -- Check that Comp has a user-specified Nam stream attribute
3328 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is
3330 if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then
3331 Error_Msg_Name_1 := Nam;
3333 ("|component& in limited extension must have% attribute", Comp);
3337 -- Start of processing for Check_Stream_Attributes
3340 if Par_Read or else Par_Write then
3341 Comp := First_Component (Typ);
3342 while Present (Comp) loop
3343 if Comes_From_Source (Comp)
3344 and then Original_Record_Component (Comp) = Comp
3345 and then Is_Limited_Type (Etype (Comp))
3348 Check_Attr (Name_Read, TSS_Stream_Read);
3352 Check_Attr (Name_Write, TSS_Stream_Write);
3356 Next_Component (Comp);
3359 end Check_Stream_Attributes;
3361 -----------------------------
3362 -- Expand_Record_Extension --
3363 -----------------------------
3365 -- Add a field _parent at the beginning of the record extension. This is
3366 -- used to implement inheritance. Here are some examples of expansion:
3368 -- 1. no discriminants
3369 -- type T2 is new T1 with null record;
3371 -- type T2 is new T1 with record
3375 -- 2. renamed discriminants
3376 -- type T2 (B, C : Int) is new T1 (A => B) with record
3377 -- _Parent : T1 (A => B);
3381 -- 3. inherited discriminants
3382 -- type T2 is new T1 with record -- discriminant A inherited
3383 -- _Parent : T1 (A);
3387 procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
3388 Indic : constant Node_Id := Subtype_Indication (Def);
3389 Loc : constant Source_Ptr := Sloc (Def);
3390 Rec_Ext_Part : Node_Id := Record_Extension_Part (Def);
3391 Par_Subtype : Entity_Id;
3392 Comp_List : Node_Id;
3393 Comp_Decl : Node_Id;
3396 List_Constr : constant List_Id := New_List;
3399 -- Expand_Record_Extension is called directly from the semantics, so
3400 -- we must check to see whether expansion is active before proceeding
3402 if not Expander_Active then
3406 -- This may be a derivation of an untagged private type whose full
3407 -- view is tagged, in which case the Derived_Type_Definition has no
3408 -- extension part. Build an empty one now.
3410 if No (Rec_Ext_Part) then
3412 Make_Record_Definition (Loc,
3414 Component_List => Empty,
3415 Null_Present => True);
3417 Set_Record_Extension_Part (Def, Rec_Ext_Part);
3418 Mark_Rewrite_Insertion (Rec_Ext_Part);
3421 Comp_List := Component_List (Rec_Ext_Part);
3423 Parent_N := Make_Defining_Identifier (Loc, Name_uParent);
3425 -- If the derived type inherits its discriminants the type of the
3426 -- _parent field must be constrained by the inherited discriminants
3428 if Has_Discriminants (T)
3429 and then Nkind (Indic) /= N_Subtype_Indication
3430 and then not Is_Constrained (Entity (Indic))
3432 D := First_Discriminant (T);
3433 while Present (D) loop
3434 Append_To (List_Constr, New_Occurrence_Of (D, Loc));
3435 Next_Discriminant (D);
3440 Make_Subtype_Indication (Loc,
3441 Subtype_Mark => New_Reference_To (Entity (Indic), Loc),
3443 Make_Index_Or_Discriminant_Constraint (Loc,
3444 Constraints => List_Constr)),
3447 -- Otherwise the original subtype_indication is just what is needed
3450 Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def);
3453 Set_Parent_Subtype (T, Par_Subtype);
3456 Make_Component_Declaration (Loc,
3457 Defining_Identifier => Parent_N,
3458 Component_Definition =>
3459 Make_Component_Definition (Loc,
3460 Aliased_Present => False,
3461 Subtype_Indication => New_Reference_To (Par_Subtype, Loc)));
3463 if Null_Present (Rec_Ext_Part) then
3464 Set_Component_List (Rec_Ext_Part,
3465 Make_Component_List (Loc,
3466 Component_Items => New_List (Comp_Decl),
3467 Variant_Part => Empty,
3468 Null_Present => False));
3469 Set_Null_Present (Rec_Ext_Part, False);
3471 elsif Null_Present (Comp_List)
3472 or else Is_Empty_List (Component_Items (Comp_List))
3474 Set_Component_Items (Comp_List, New_List (Comp_Decl));
3475 Set_Null_Present (Comp_List, False);
3478 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
3481 Analyze (Comp_Decl);
3482 end Expand_Record_Extension;
3484 ------------------------------------
3485 -- Expand_N_Full_Type_Declaration --
3486 ------------------------------------
3488 procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
3489 Def_Id : constant Entity_Id := Defining_Identifier (N);
3490 B_Id : constant Entity_Id := Base_Type (Def_Id);
3494 procedure Build_Master (Def_Id : Entity_Id);
3495 -- Create the master associated with Def_Id
3501 procedure Build_Master (Def_Id : Entity_Id) is
3503 -- Anonymous access types are created for the components of the
3504 -- record parameter for an entry declaration. No master is created
3507 if Has_Task (Designated_Type (Def_Id))
3508 and then Comes_From_Source (N)
3510 Build_Master_Entity (Def_Id);
3511 Build_Master_Renaming (Parent (Def_Id), Def_Id);
3513 -- Create a class-wide master because a Master_Id must be generated
3514 -- for access-to-limited-class-wide types whose root may be extended
3515 -- with task components, and for access-to-limited-interfaces because
3516 -- they can be used to reference tasks implementing such interface.
3518 elsif Is_Class_Wide_Type (Designated_Type (Def_Id))
3519 and then (Is_Limited_Type (Designated_Type (Def_Id))
3521 (Is_Interface (Designated_Type (Def_Id))
3523 Is_Limited_Interface (Designated_Type (Def_Id))))
3524 and then Tasking_Allowed
3526 -- Do not create a class-wide master for types whose convention is
3527 -- Java since these types cannot embed Ada tasks anyway. Note that
3528 -- the following test cannot catch the following case:
3530 -- package java.lang.Object is
3531 -- type Typ is tagged limited private;
3532 -- type Ref is access all Typ'Class;
3534 -- type Typ is tagged limited ...;
3535 -- pragma Convention (Typ, Java)
3538 -- Because the convention appears after we have done the
3539 -- processing for type Ref.
3541 and then Convention (Designated_Type (Def_Id)) /= Convention_Java
3543 Build_Class_Wide_Master (Def_Id);
3547 -- Start of processing for Expand_N_Full_Type_Declaration
3550 if Is_Access_Type (Def_Id) then
3551 Build_Master (Def_Id);
3553 if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
3554 Expand_Access_Protected_Subprogram_Type (N);
3557 elsif Ada_Version >= Ada_05
3558 and then Is_Array_Type (Def_Id)
3559 and then Is_Access_Type (Component_Type (Def_Id))
3560 and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type
3562 Build_Master (Component_Type (Def_Id));
3564 elsif Has_Task (Def_Id) then
3565 Expand_Previous_Access_Type (Def_Id);
3567 elsif Ada_Version >= Ada_05
3569 (Is_Record_Type (Def_Id)
3570 or else (Is_Array_Type (Def_Id)
3571 and then Is_Record_Type (Component_Type (Def_Id))))
3579 -- Look for the first anonymous access type component
3581 if Is_Array_Type (Def_Id) then
3582 Comp := First_Entity (Component_Type (Def_Id));
3584 Comp := First_Entity (Def_Id);
3587 while Present (Comp) loop
3588 Typ := Etype (Comp);
3590 exit when Is_Access_Type (Typ)
3591 and then Ekind (Typ) = E_Anonymous_Access_Type;
3596 -- If found we add a renaming reclaration of master_id and we
3597 -- associate it to each anonymous access type component. Do
3598 -- nothing if the access type already has a master. This will be
3599 -- the case if the array type is the packed array created for a
3600 -- user-defined array type T, where the master_id is created when
3601 -- expanding the declaration for T.
3604 and then not Restriction_Active (No_Task_Hierarchy)
3605 and then No (Master_Id (Typ))
3607 Build_Master_Entity (Def_Id);
3608 M_Id := Build_Master_Renaming (N, Def_Id);
3610 if Is_Array_Type (Def_Id) then
3611 Comp := First_Entity (Component_Type (Def_Id));
3613 Comp := First_Entity (Def_Id);
3616 while Present (Comp) loop
3617 Typ := Etype (Comp);
3619 if Is_Access_Type (Typ)
3620 and then Ekind (Typ) = E_Anonymous_Access_Type
3622 Set_Master_Id (Typ, M_Id);
3631 Par_Id := Etype (B_Id);
3633 -- The parent type is private then we need to inherit any TSS operations
3634 -- from the full view.
3636 if Ekind (Par_Id) in Private_Kind
3637 and then Present (Full_View (Par_Id))
3639 Par_Id := Base_Type (Full_View (Par_Id));
3642 if Nkind (Type_Definition (Original_Node (N))) =
3643 N_Derived_Type_Definition
3644 and then not Is_Tagged_Type (Def_Id)
3645 and then Present (Freeze_Node (Par_Id))
3646 and then Present (TSS_Elist (Freeze_Node (Par_Id)))
3648 Ensure_Freeze_Node (B_Id);
3649 FN := Freeze_Node (B_Id);
3651 if No (TSS_Elist (FN)) then
3652 Set_TSS_Elist (FN, New_Elmt_List);
3656 T_E : constant Elist_Id := TSS_Elist (FN);
3660 Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
3661 while Present (Elmt) loop
3662 if Chars (Node (Elmt)) /= Name_uInit then
3663 Append_Elmt (Node (Elmt), T_E);
3669 -- If the derived type itself is private with a full view, then
3670 -- associate the full view with the inherited TSS_Elist as well.
3672 if Ekind (B_Id) in Private_Kind
3673 and then Present (Full_View (B_Id))
3675 Ensure_Freeze_Node (Base_Type (Full_View (B_Id)));
3677 (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN));
3681 end Expand_N_Full_Type_Declaration;
3683 ---------------------------------
3684 -- Expand_N_Object_Declaration --
3685 ---------------------------------
3687 -- First we do special processing for objects of a tagged type where this
3688 -- is the point at which the type is frozen. The creation of the dispatch
3689 -- table and the initialization procedure have to be deferred to this
3690 -- point, since we reference previously declared primitive subprograms.
3692 -- For all types, we call an initialization procedure if there is one
3694 procedure Expand_N_Object_Declaration (N : Node_Id) is
3695 Def_Id : constant Entity_Id := Defining_Identifier (N);
3696 Expr : constant Node_Id := Expression (N);
3697 Loc : constant Source_Ptr := Sloc (N);
3698 Typ : constant Entity_Id := Etype (Def_Id);
3704 -- Don't do anything for deferred constants. All proper actions will
3705 -- be expanded during the full declaration.
3707 if No (Expr) and Constant_Present (N) then
3711 -- Make shared memory routines for shared passive variable
3713 if Is_Shared_Passive (Def_Id) then
3714 Make_Shared_Var_Procs (N);
3717 -- If tasks being declared, make sure we have an activation chain
3718 -- defined for the tasks (has no effect if we already have one), and
3719 -- also that a Master variable is established and that the appropriate
3720 -- enclosing construct is established as a task master.
3722 if Has_Task (Typ) then
3723 Build_Activation_Chain_Entity (N);
3724 Build_Master_Entity (Def_Id);
3727 -- Default initialization required, and no expression present
3731 -- Expand Initialize call for controlled objects. One may wonder why
3732 -- the Initialize Call is not done in the regular Init procedure
3733 -- attached to the record type. That's because the init procedure is
3734 -- recursively called on each component, including _Parent, thus the
3735 -- Init call for a controlled object would generate not only one
3736 -- Initialize call as it is required but one for each ancestor of
3737 -- its type. This processing is suppressed if No_Initialization set.
3739 if not Controlled_Type (Typ)
3740 or else No_Initialization (N)
3744 elsif not Abort_Allowed
3745 or else not Comes_From_Source (N)
3747 Insert_Actions_After (N,
3749 Ref => New_Occurrence_Of (Def_Id, Loc),
3750 Typ => Base_Type (Typ),
3751 Flist_Ref => Find_Final_List (Def_Id),
3752 With_Attach => Make_Integer_Literal (Loc, 1)));
3757 -- We need to protect the initialize call
3761 -- Initialize (...);
3763 -- Undefer_Abort.all;
3766 -- ??? this won't protect the initialize call for controlled
3767 -- components which are part of the init proc, so this block
3768 -- should probably also contain the call to _init_proc but this
3769 -- requires some code reorganization...
3772 L : constant List_Id :=
3774 (Ref => New_Occurrence_Of (Def_Id, Loc),
3775 Typ => Base_Type (Typ),
3776 Flist_Ref => Find_Final_List (Def_Id),
3777 With_Attach => Make_Integer_Literal (Loc, 1));
3779 Blk : constant Node_Id :=
3780 Make_Block_Statement (Loc,
3781 Handled_Statement_Sequence =>
3782 Make_Handled_Sequence_Of_Statements (Loc, L));
3785 Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer));
3786 Set_At_End_Proc (Handled_Statement_Sequence (Blk),
3787 New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc));
3788 Insert_Actions_After (N, New_List (Blk));
3789 Expand_At_End_Handler
3790 (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk)));
3794 -- Call type initialization procedure if there is one. We build the
3795 -- call and put it immediately after the object declaration, so that
3796 -- it will be expanded in the usual manner. Note that this will
3797 -- result in proper handling of defaulted discriminants. The call
3798 -- to the Init_Proc is suppressed if No_Initialization is set.
3800 if Has_Non_Null_Base_Init_Proc (Typ)
3801 and then not No_Initialization (N)
3803 -- The call to the initialization procedure does NOT freeze the
3804 -- object being initialized. This is because the call is not a
3805 -- source level call. This works fine, because the only possible
3806 -- statements depending on freeze status that can appear after the
3807 -- _Init call are rep clauses which can safely appear after actual
3808 -- references to the object.
3810 Id_Ref := New_Reference_To (Def_Id, Loc);
3811 Set_Must_Not_Freeze (Id_Ref);
3812 Set_Assignment_OK (Id_Ref);
3814 Insert_Actions_After (N,
3815 Build_Initialization_Call (Loc, Id_Ref, Typ));
3817 -- If simple initialization is required, then set an appropriate
3818 -- simple initialization expression in place. This special
3819 -- initialization is required even though No_Init_Flag is present.
3821 -- An internally generated temporary needs no initialization because
3822 -- it will be assigned subsequently. In particular, there is no point
3823 -- in applying Initialize_Scalars to such a temporary.
3825 elsif Needs_Simple_Initialization (Typ)
3826 and then not Is_Internal (Def_Id)
3828 Set_No_Initialization (N, False);
3829 Set_Expression (N, Get_Simple_Init_Val (Typ, Loc, Esize (Def_Id)));
3830 Analyze_And_Resolve (Expression (N), Typ);
3833 -- Generate attribute for Persistent_BSS if needed
3835 if Persistent_BSS_Mode
3836 and then Comes_From_Source (N)
3837 and then Is_Potentially_Persistent_Type (Typ)
3838 and then Is_Library_Level_Entity (Def_Id)
3844 Make_Linker_Section_Pragma
3845 (Def_Id, Sloc (N), ".persistent.bss");
3846 Insert_After (N, Prag);
3851 -- If access type, then we know it is null if not initialized
3853 if Is_Access_Type (Typ) then
3854 Set_Is_Known_Null (Def_Id);
3857 -- Explicit initialization present
3860 -- Obtain actual expression from qualified expression
3862 if Nkind (Expr) = N_Qualified_Expression then
3863 Expr_Q := Expression (Expr);
3868 -- When we have the appropriate type of aggregate in the expression
3869 -- (it has been determined during analysis of the aggregate by
3870 -- setting the delay flag), let's perform in place assignment and
3871 -- thus avoid creating a temporary.
3873 if Is_Delayed_Aggregate (Expr_Q) then
3874 Convert_Aggr_In_Object_Decl (N);
3877 -- Ada 2005 (AI-318-02): If the initialization expression is a
3878 -- call to a build-in-place function, then access to the declared
3879 -- object must be passed to the function. Currently we limit such
3880 -- functions to those with constrained limited result subtypes,
3881 -- but eventually we plan to expand the allowed forms of funtions
3882 -- that are treated as build-in-place.
3884 if Ada_Version >= Ada_05
3885 and then Is_Build_In_Place_Function_Call (Expr_Q)
3887 Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q);
3890 -- In most cases, we must check that the initial value meets any
3891 -- constraint imposed by the declared type. However, there is one
3892 -- very important exception to this rule. If the entity has an
3893 -- unconstrained nominal subtype, then it acquired its constraints
3894 -- from the expression in the first place, and not only does this
3895 -- mean that the constraint check is not needed, but an attempt to
3896 -- perform the constraint check can cause order order of
3897 -- elaboration problems.
3899 if not Is_Constr_Subt_For_U_Nominal (Typ) then
3901 -- If this is an allocator for an aggregate that has been
3902 -- allocated in place, delay checks until assignments are
3903 -- made, because the discriminants are not initialized.
3905 if Nkind (Expr) = N_Allocator
3906 and then No_Initialization (Expr)
3910 Apply_Constraint_Check (Expr, Typ);
3914 -- Ada 2005 (AI-251): Rewrite the expression that initializes a
3915 -- class-wide object to ensure that we copy the full object.
3918 -- CW : I'Class := Obj;
3920 -- CW__1 : I'Class := I'Class (Base_Address (Obj'Address));
3921 -- CW : I'Class renames Displace (CW__1, I'Tag);
3923 if Is_Interface (Typ)
3924 and then Is_Class_Wide_Type (Etype (Expr))
3925 and then Comes_From_Source (Def_Id)
3933 Make_Object_Declaration (Loc,
3934 Defining_Identifier =>
3935 Make_Defining_Identifier (Loc,
3936 New_Internal_Name ('D')),
3938 Object_Definition =>
3939 Make_Attribute_Reference (Loc,
3940 Prefix => Make_Identifier (Loc,
3941 Chars (Root_Type (Etype (Def_Id)))),
3942 Attribute_Name => Name_Class),
3945 Unchecked_Convert_To
3946 (Class_Wide_Type (Root_Type (Etype (Def_Id))),
3947 Make_Explicit_Dereference (Loc,
3948 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
3949 Make_Function_Call (Loc,
3951 New_Reference_To (RTE (RE_Base_Address),
3953 Parameter_Associations => New_List (
3954 Make_Attribute_Reference (Loc,
3955 Prefix => Relocate_Node (Expr),
3956 Attribute_Name => Name_Address)))))));
3958 Insert_Action (N, Decl_1);
3961 Make_Object_Renaming_Declaration (Loc,
3962 Defining_Identifier =>
3963 Make_Defining_Identifier (Loc,
3964 New_Internal_Name ('D')),
3967 Make_Attribute_Reference (Loc,
3969 Make_Identifier (Loc,
3970 Chars => Chars (Root_Type (Etype (Def_Id)))),
3971 Attribute_Name => Name_Class),
3974 Unchecked_Convert_To (
3975 Class_Wide_Type (Root_Type (Etype (Def_Id))),
3976 Make_Explicit_Dereference (Loc,
3977 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
3978 Make_Function_Call (Loc,
3980 New_Reference_To (RTE (RE_Displace), Loc),
3982 Parameter_Associations => New_List (
3983 Make_Attribute_Reference (Loc,
3986 (Defining_Identifier (Decl_1), Loc),
3987 Attribute_Name => Name_Address),
3989 Unchecked_Convert_To (RTE (RE_Tag),
3994 (Root_Type (Typ)))),
3997 Rewrite (N, Decl_2);
4000 -- Replace internal identifier of Decl_2 by the identifier
4001 -- found in the sources. We also have to exchange entities
4002 -- containing their defining identifiers to ensure the
4003 -- correct replacement of the object declaration by this
4004 -- object renaming declaration (because such definings
4005 -- identifier have been previously added by Enter_Name to
4006 -- the current scope).
4008 Set_Chars (Defining_Identifier (N), Chars (Def_Id));
4009 Exchange_Entities (Defining_Identifier (N), Def_Id);
4015 -- If the type is controlled we attach the object to the final
4016 -- list and adjust the target after the copy. This
4017 -- ??? incomplete sentence
4019 if Controlled_Type (Typ) then
4025 -- Attach the result to a dummy final list which will never
4026 -- be finalized if Delay_Finalize_Attachis set. It is
4027 -- important to attach to a dummy final list rather than not
4028 -- attaching at all in order to reset the pointers coming
4029 -- from the initial value. Equivalent code exists in the
4030 -- sec-stack case in Exp_Ch4.Expand_N_Allocator.
4032 if Delay_Finalize_Attach (N) then
4034 Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
4036 Make_Object_Declaration (Loc,
4037 Defining_Identifier => F,
4038 Object_Definition =>
4039 New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
4041 Flist := New_Reference_To (F, Loc);
4044 Flist := Find_Final_List (Def_Id);
4047 -- Adjustment is only needed when the controlled type is not
4050 if not Is_Limited_Type (Typ) then
4051 Insert_Actions_After (N,
4053 Ref => New_Reference_To (Def_Id, Loc),
4054 Typ => Base_Type (Typ),
4056 With_Attach => Make_Integer_Literal (Loc, 1)));
4061 -- For tagged types, when an init value is given, the tag has to
4062 -- be re-initialized separately in order to avoid the propagation
4063 -- of a wrong tag coming from a view conversion unless the type
4064 -- is class wide (in this case the tag comes from the init value).
4065 -- Suppress the tag assignment when Java_VM because JVM tags are
4066 -- represented implicitly in objects. Ditto for types that are
4067 -- CPP_CLASS, and for initializations that are aggregates, because
4068 -- they have to have the right tag.
4070 if Is_Tagged_Type (Typ)
4071 and then not Is_Class_Wide_Type (Typ)
4072 and then not Is_CPP_Class (Typ)
4073 and then not Java_VM
4074 and then Nkind (Expr) /= N_Aggregate
4076 -- The re-assignment of the tag has to be done even if the
4077 -- object is a constant.
4080 Make_Selected_Component (Loc,
4081 Prefix => New_Reference_To (Def_Id, Loc),
4083 New_Reference_To (First_Tag_Component (Typ), Loc));
4085 Set_Assignment_OK (New_Ref);
4088 Make_Assignment_Statement (Loc,
4091 Unchecked_Convert_To (RTE (RE_Tag),
4095 (Access_Disp_Table (Base_Type (Typ)))),
4098 -- For discrete types, set the Is_Known_Valid flag if the
4099 -- initializing value is known to be valid.
4101 elsif Is_Discrete_Type (Typ) and then Expr_Known_Valid (Expr) then
4102 Set_Is_Known_Valid (Def_Id);
4104 elsif Is_Access_Type (Typ) then
4106 -- For access types set the Is_Known_Non_Null flag if the
4107 -- initializing value is known to be non-null. We can also set
4108 -- Can_Never_Be_Null if this is a constant.
4110 if Known_Non_Null (Expr) then
4111 Set_Is_Known_Non_Null (Def_Id, True);
4113 if Constant_Present (N) then
4114 Set_Can_Never_Be_Null (Def_Id);
4119 -- If validity checking on copies, validate initial expression
4121 if Validity_Checks_On
4122 and then Validity_Check_Copies
4124 Ensure_Valid (Expr);
4125 Set_Is_Known_Valid (Def_Id);
4129 -- Cases where the back end cannot handle the initialization directly
4130 -- In such cases, we expand an assignment that will be appropriately
4131 -- handled by Expand_N_Assignment_Statement.
4133 -- The exclusion of the unconstrained case is wrong, but for now it
4134 -- is too much trouble ???
4136 if (Is_Possibly_Unaligned_Slice (Expr)
4137 or else (Is_Possibly_Unaligned_Object (Expr)
4138 and then not Represented_As_Scalar (Etype (Expr))))
4140 -- The exclusion of the unconstrained case is wrong, but for now
4141 -- it is too much trouble ???
4143 and then not (Is_Array_Type (Etype (Expr))
4144 and then not Is_Constrained (Etype (Expr)))
4147 Stat : constant Node_Id :=
4148 Make_Assignment_Statement (Loc,
4149 Name => New_Reference_To (Def_Id, Loc),
4150 Expression => Relocate_Node (Expr));
4152 Set_Expression (N, Empty);
4153 Set_No_Initialization (N);
4154 Set_Assignment_OK (Name (Stat));
4155 Set_No_Ctrl_Actions (Stat);
4156 Insert_After (N, Stat);
4162 -- For array type, check for size too large
4163 -- We really need this for record types too???
4165 if Is_Array_Type (Typ) then
4166 Apply_Array_Size_Check (N, Typ);
4170 when RE_Not_Available =>
4172 end Expand_N_Object_Declaration;
4174 ---------------------------------
4175 -- Expand_N_Subtype_Indication --
4176 ---------------------------------
4178 -- Add a check on the range of the subtype. The static case is partially
4179 -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
4180 -- to check here for the static case in order to avoid generating
4181 -- extraneous expanded code. Also deal with validity checking.
4183 procedure Expand_N_Subtype_Indication (N : Node_Id) is
4184 Ran : constant Node_Id := Range_Expression (Constraint (N));
4185 Typ : constant Entity_Id := Entity (Subtype_Mark (N));
4188 if Nkind (Constraint (N)) = N_Range_Constraint then
4189 Validity_Check_Range (Range_Expression (Constraint (N)));
4192 if Nkind (Parent (N)) = N_Constrained_Array_Definition
4194 Nkind (Parent (N)) = N_Slice
4196 Apply_Range_Check (Ran, Typ);
4198 end Expand_N_Subtype_Indication;
4200 ---------------------------
4201 -- Expand_N_Variant_Part --
4202 ---------------------------
4204 -- If the last variant does not contain the Others choice, replace it with
4205 -- an N_Others_Choice node since Gigi always wants an Others. Note that we
4206 -- do not bother to call Analyze on the modified variant part, since it's
4207 -- only effect would be to compute the Others_Discrete_Choices node
4208 -- laboriously, and of course we already know the list of choices that
4209 -- corresponds to the others choice (it's the list we are replacing!)
4211 procedure Expand_N_Variant_Part (N : Node_Id) is
4212 Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N));
4213 Others_Node : Node_Id;
4215 if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then
4216 Others_Node := Make_Others_Choice (Sloc (Last_Var));
4217 Set_Others_Discrete_Choices
4218 (Others_Node, Discrete_Choices (Last_Var));
4219 Set_Discrete_Choices (Last_Var, New_List (Others_Node));
4221 end Expand_N_Variant_Part;
4223 ---------------------------------
4224 -- Expand_Previous_Access_Type --
4225 ---------------------------------
4227 procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is
4228 T : Entity_Id := First_Entity (Current_Scope);
4231 -- Find all access types declared in the current scope, whose
4232 -- designated type is Def_Id.
4234 while Present (T) loop
4235 if Is_Access_Type (T)
4236 and then Designated_Type (T) = Def_Id
4238 Build_Master_Entity (Def_Id);
4239 Build_Master_Renaming (Parent (Def_Id), T);
4244 end Expand_Previous_Access_Type;
4246 ------------------------------
4247 -- Expand_Record_Controller --
4248 ------------------------------
4250 procedure Expand_Record_Controller (T : Entity_Id) is
4251 Def : Node_Id := Type_Definition (Parent (T));
4252 Comp_List : Node_Id;
4253 Comp_Decl : Node_Id;
4255 First_Comp : Node_Id;
4256 Controller_Type : Entity_Id;
4260 if Nkind (Def) = N_Derived_Type_Definition then
4261 Def := Record_Extension_Part (Def);
4264 if Null_Present (Def) then
4265 Set_Component_List (Def,
4266 Make_Component_List (Sloc (Def),
4267 Component_Items => Empty_List,
4268 Variant_Part => Empty,
4269 Null_Present => True));
4272 Comp_List := Component_List (Def);
4274 if Null_Present (Comp_List)
4275 or else Is_Empty_List (Component_Items (Comp_List))
4277 Loc := Sloc (Comp_List);
4279 Loc := Sloc (First (Component_Items (Comp_List)));
4282 if Is_Inherently_Limited_Type (T) then
4283 Controller_Type := RTE (RE_Limited_Record_Controller);
4285 Controller_Type := RTE (RE_Record_Controller);
4288 Ent := Make_Defining_Identifier (Loc, Name_uController);
4291 Make_Component_Declaration (Loc,
4292 Defining_Identifier => Ent,
4293 Component_Definition =>
4294 Make_Component_Definition (Loc,
4295 Aliased_Present => False,
4296 Subtype_Indication => New_Reference_To (Controller_Type, Loc)));
4298 if Null_Present (Comp_List)
4299 or else Is_Empty_List (Component_Items (Comp_List))
4301 Set_Component_Items (Comp_List, New_List (Comp_Decl));
4302 Set_Null_Present (Comp_List, False);
4305 -- The controller cannot be placed before the _Parent field since
4306 -- gigi lays out field in order and _parent must be first to preserve
4307 -- the polymorphism of tagged types.
4309 First_Comp := First (Component_Items (Comp_List));
4311 if not Is_Tagged_Type (T) then
4312 Insert_Before (First_Comp, Comp_Decl);
4314 -- if T is a tagged type, place controller declaration after
4315 -- parent field and after eventual tags of implemented
4316 -- interfaces, if present.
4319 while Present (First_Comp)
4321 (Chars (Defining_Identifier (First_Comp)) = Name_uParent
4322 or else Is_Tag (Defining_Identifier (First_Comp)))
4327 -- An empty tagged extension might consist only of the parent
4328 -- component. Otherwise insert the controller before the first
4329 -- component that is neither parent nor tag.
4331 if Present (First_Comp) then
4332 Insert_Before (First_Comp, Comp_Decl);
4334 Append (Comp_Decl, Component_Items (Comp_List));
4340 Analyze (Comp_Decl);
4341 Set_Ekind (Ent, E_Component);
4342 Init_Component_Location (Ent);
4344 -- Move the _controller entity ahead in the list of internal entities
4345 -- of the enclosing record so that it is selected instead of a
4346 -- potentially inherited one.
4349 E : constant Entity_Id := Last_Entity (T);
4353 pragma Assert (Chars (E) = Name_uController);
4355 Set_Next_Entity (E, First_Entity (T));
4356 Set_First_Entity (T, E);
4358 Comp := Next_Entity (E);
4359 while Next_Entity (Comp) /= E loop
4363 Set_Next_Entity (Comp, Empty);
4364 Set_Last_Entity (T, Comp);
4370 when RE_Not_Available =>
4372 end Expand_Record_Controller;
4374 ------------------------
4375 -- Expand_Tagged_Root --
4376 ------------------------
4378 procedure Expand_Tagged_Root (T : Entity_Id) is
4379 Def : constant Node_Id := Type_Definition (Parent (T));
4380 Comp_List : Node_Id;
4381 Comp_Decl : Node_Id;
4382 Sloc_N : Source_Ptr;
4385 if Null_Present (Def) then
4386 Set_Component_List (Def,
4387 Make_Component_List (Sloc (Def),
4388 Component_Items => Empty_List,
4389 Variant_Part => Empty,
4390 Null_Present => True));
4393 Comp_List := Component_List (Def);
4395 if Null_Present (Comp_List)
4396 or else Is_Empty_List (Component_Items (Comp_List))
4398 Sloc_N := Sloc (Comp_List);
4400 Sloc_N := Sloc (First (Component_Items (Comp_List)));
4404 Make_Component_Declaration (Sloc_N,
4405 Defining_Identifier => First_Tag_Component (T),
4406 Component_Definition =>
4407 Make_Component_Definition (Sloc_N,
4408 Aliased_Present => False,
4409 Subtype_Indication => New_Reference_To (RTE (RE_Tag), Sloc_N)));
4411 if Null_Present (Comp_List)
4412 or else Is_Empty_List (Component_Items (Comp_List))
4414 Set_Component_Items (Comp_List, New_List (Comp_Decl));
4415 Set_Null_Present (Comp_List, False);
4418 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
4421 -- We don't Analyze the whole expansion because the tag component has
4422 -- already been analyzed previously. Here we just insure that the tree
4423 -- is coherent with the semantic decoration
4425 Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
4428 when RE_Not_Available =>
4430 end Expand_Tagged_Root;
4432 ----------------------
4433 -- Clean_Task_Names --
4434 ----------------------
4436 procedure Clean_Task_Names
4438 Proc_Id : Entity_Id)
4442 and then not Restriction_Active (No_Implicit_Heap_Allocations)
4443 and then not Global_Discard_Names
4445 Set_Uses_Sec_Stack (Proc_Id);
4447 end Clean_Task_Names;
4449 -----------------------
4450 -- Freeze_Array_Type --
4451 -----------------------
4453 procedure Freeze_Array_Type (N : Node_Id) is
4454 Typ : constant Entity_Id := Entity (N);
4455 Base : constant Entity_Id := Base_Type (Typ);
4458 if not Is_Bit_Packed_Array (Typ) then
4460 -- If the component contains tasks, so does the array type. This may
4461 -- not be indicated in the array type because the component may have
4462 -- been a private type at the point of definition. Same if component
4463 -- type is controlled.
4465 Set_Has_Task (Base, Has_Task (Component_Type (Typ)));
4466 Set_Has_Controlled_Component (Base,
4467 Has_Controlled_Component (Component_Type (Typ))
4468 or else Is_Controlled (Component_Type (Typ)));
4470 if No (Init_Proc (Base)) then
4472 -- If this is an anonymous array created for a declaration with
4473 -- an initial value, its init_proc will never be called. The
4474 -- initial value itself may have been expanded into assign-
4475 -- ments, in which case the object declaration is carries the
4476 -- No_Initialization flag.
4479 and then Nkind (Associated_Node_For_Itype (Base)) =
4480 N_Object_Declaration
4481 and then (Present (Expression (Associated_Node_For_Itype (Base)))
4483 No_Initialization (Associated_Node_For_Itype (Base)))
4487 -- We do not need an init proc for string or wide [wide] string,
4488 -- since the only time these need initialization in normalize or
4489 -- initialize scalars mode, and these types are treated specially
4490 -- and do not need initialization procedures.
4492 elsif Root_Type (Base) = Standard_String
4493 or else Root_Type (Base) = Standard_Wide_String
4494 or else Root_Type (Base) = Standard_Wide_Wide_String
4498 -- Otherwise we have to build an init proc for the subtype
4501 Build_Array_Init_Proc (Base, N);
4505 if Typ = Base and then Has_Controlled_Component (Base) then
4506 Build_Controlling_Procs (Base);
4508 if not Is_Limited_Type (Component_Type (Typ))
4509 and then Number_Dimensions (Typ) = 1
4511 Build_Slice_Assignment (Typ);
4515 -- For packed case, there is a default initialization, except if the
4516 -- component type is itself a packed structure with an initialization
4519 elsif Present (Init_Proc (Component_Type (Base)))
4520 and then No (Base_Init_Proc (Base))
4522 Build_Array_Init_Proc (Base, N);
4524 end Freeze_Array_Type;
4526 -----------------------------
4527 -- Freeze_Enumeration_Type --
4528 -----------------------------
4530 procedure Freeze_Enumeration_Type (N : Node_Id) is
4531 Typ : constant Entity_Id := Entity (N);
4532 Loc : constant Source_Ptr := Sloc (Typ);
4539 Is_Contiguous : Boolean;
4544 pragma Warnings (Off, Func);
4547 -- Various optimization are possible if the given representation is
4550 Is_Contiguous := True;
4551 Ent := First_Literal (Typ);
4552 Last_Repval := Enumeration_Rep (Ent);
4555 while Present (Ent) loop
4556 if Enumeration_Rep (Ent) - Last_Repval /= 1 then
4557 Is_Contiguous := False;
4560 Last_Repval := Enumeration_Rep (Ent);
4566 if Is_Contiguous then
4567 Set_Has_Contiguous_Rep (Typ);
4568 Ent := First_Literal (Typ);
4570 Lst := New_List (New_Reference_To (Ent, Sloc (Ent)));
4573 -- Build list of literal references
4578 Ent := First_Literal (Typ);
4579 while Present (Ent) loop
4580 Append_To (Lst, New_Reference_To (Ent, Sloc (Ent)));
4586 -- Now build an array declaration
4588 -- typA : array (Natural range 0 .. num - 1) of ctype :=
4589 -- (v, v, v, v, v, ....)
4591 -- where ctype is the corresponding integer type. If the representation
4592 -- is contiguous, we only keep the first literal, which provides the
4593 -- offset for Pos_To_Rep computations.
4596 Make_Defining_Identifier (Loc,
4597 Chars => New_External_Name (Chars (Typ), 'A'));
4599 Append_Freeze_Action (Typ,
4600 Make_Object_Declaration (Loc,
4601 Defining_Identifier => Arr,
4602 Constant_Present => True,
4604 Object_Definition =>
4605 Make_Constrained_Array_Definition (Loc,
4606 Discrete_Subtype_Definitions => New_List (
4607 Make_Subtype_Indication (Loc,
4608 Subtype_Mark => New_Reference_To (Standard_Natural, Loc),
4610 Make_Range_Constraint (Loc,
4614 Make_Integer_Literal (Loc, 0),
4616 Make_Integer_Literal (Loc, Num - 1))))),
4618 Component_Definition =>
4619 Make_Component_Definition (Loc,
4620 Aliased_Present => False,
4621 Subtype_Indication => New_Reference_To (Typ, Loc))),
4624 Make_Aggregate (Loc,
4625 Expressions => Lst)));
4627 Set_Enum_Pos_To_Rep (Typ, Arr);
4629 -- Now we build the function that converts representation values to
4630 -- position values. This function has the form:
4632 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
4635 -- when enum-lit'Enum_Rep => return posval;
4636 -- when enum-lit'Enum_Rep => return posval;
4639 -- [raise Constraint_Error when F "invalid data"]
4644 -- Note: the F parameter determines whether the others case (no valid
4645 -- representation) raises Constraint_Error or returns a unique value
4646 -- of minus one. The latter case is used, e.g. in 'Valid code.
4648 -- Note: the reason we use Enum_Rep values in the case here is to avoid
4649 -- the code generator making inappropriate assumptions about the range
4650 -- of the values in the case where the value is invalid. ityp is a
4651 -- signed or unsigned integer type of appropriate width.
4653 -- Note: if exceptions are not supported, then we suppress the raise
4654 -- and return -1 unconditionally (this is an erroneous program in any
4655 -- case and there is no obligation to raise Constraint_Error here!) We
4656 -- also do this if pragma Restrictions (No_Exceptions) is active.
4658 -- Representations are signed
4660 if Enumeration_Rep (First_Literal (Typ)) < 0 then
4662 -- The underlying type is signed. Reset the Is_Unsigned_Type
4663 -- explicitly, because it might have been inherited from
4666 Set_Is_Unsigned_Type (Typ, False);
4668 if Esize (Typ) <= Standard_Integer_Size then
4669 Ityp := Standard_Integer;
4671 Ityp := Universal_Integer;
4674 -- Representations are unsigned
4677 if Esize (Typ) <= Standard_Integer_Size then
4678 Ityp := RTE (RE_Unsigned);
4680 Ityp := RTE (RE_Long_Long_Unsigned);
4684 -- The body of the function is a case statement. First collect case
4685 -- alternatives, or optimize the contiguous case.
4689 -- If representation is contiguous, Pos is computed by subtracting
4690 -- the representation of the first literal.
4692 if Is_Contiguous then
4693 Ent := First_Literal (Typ);
4695 if Enumeration_Rep (Ent) = Last_Repval then
4697 -- Another special case: for a single literal, Pos is zero
4699 Pos_Expr := Make_Integer_Literal (Loc, Uint_0);
4703 Convert_To (Standard_Integer,
4704 Make_Op_Subtract (Loc,
4706 Unchecked_Convert_To (Ityp,
4707 Make_Identifier (Loc, Name_uA)),
4709 Make_Integer_Literal (Loc,
4711 Enumeration_Rep (First_Literal (Typ)))));
4715 Make_Case_Statement_Alternative (Loc,
4716 Discrete_Choices => New_List (
4717 Make_Range (Sloc (Enumeration_Rep_Expr (Ent)),
4719 Make_Integer_Literal (Loc,
4720 Intval => Enumeration_Rep (Ent)),
4722 Make_Integer_Literal (Loc, Intval => Last_Repval))),
4724 Statements => New_List (
4725 Make_Return_Statement (Loc,
4726 Expression => Pos_Expr))));
4729 Ent := First_Literal (Typ);
4731 while Present (Ent) loop
4733 Make_Case_Statement_Alternative (Loc,
4734 Discrete_Choices => New_List (
4735 Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
4736 Intval => Enumeration_Rep (Ent))),
4738 Statements => New_List (
4739 Make_Return_Statement (Loc,
4741 Make_Integer_Literal (Loc,
4742 Intval => Enumeration_Pos (Ent))))));
4748 -- In normal mode, add the others clause with the test
4750 if not Restriction_Active (No_Exception_Handlers) then
4752 Make_Case_Statement_Alternative (Loc,
4753 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4754 Statements => New_List (
4755 Make_Raise_Constraint_Error (Loc,
4756 Condition => Make_Identifier (Loc, Name_uF),
4757 Reason => CE_Invalid_Data),
4758 Make_Return_Statement (Loc,
4760 Make_Integer_Literal (Loc, -1)))));
4762 -- If Restriction (No_Exceptions_Handlers) is active then we always
4763 -- return -1 (since we cannot usefully raise Constraint_Error in
4764 -- this case). See description above for further details.
4768 Make_Case_Statement_Alternative (Loc,
4769 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4770 Statements => New_List (
4771 Make_Return_Statement (Loc,
4773 Make_Integer_Literal (Loc, -1)))));
4776 -- Now we can build the function body
4779 Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos));
4782 Make_Subprogram_Body (Loc,
4784 Make_Function_Specification (Loc,
4785 Defining_Unit_Name => Fent,
4786 Parameter_Specifications => New_List (
4787 Make_Parameter_Specification (Loc,
4788 Defining_Identifier =>
4789 Make_Defining_Identifier (Loc, Name_uA),
4790 Parameter_Type => New_Reference_To (Typ, Loc)),
4791 Make_Parameter_Specification (Loc,
4792 Defining_Identifier =>
4793 Make_Defining_Identifier (Loc, Name_uF),
4794 Parameter_Type => New_Reference_To (Standard_Boolean, Loc))),
4796 Result_Definition => New_Reference_To (Standard_Integer, Loc)),
4798 Declarations => Empty_List,
4800 Handled_Statement_Sequence =>
4801 Make_Handled_Sequence_Of_Statements (Loc,
4802 Statements => New_List (
4803 Make_Case_Statement (Loc,
4805 Unchecked_Convert_To (Ityp,
4806 Make_Identifier (Loc, Name_uA)),
4807 Alternatives => Lst))));
4809 Set_TSS (Typ, Fent);
4812 if not Debug_Generated_Code then
4813 Set_Debug_Info_Off (Fent);
4817 when RE_Not_Available =>
4819 end Freeze_Enumeration_Type;
4821 ------------------------
4822 -- Freeze_Record_Type --
4823 ------------------------
4825 procedure Freeze_Record_Type (N : Node_Id) is
4827 Def_Id : constant Node_Id := Entity (N);
4828 Predef_List : List_Id;
4829 Type_Decl : constant Node_Id := Parent (Def_Id);
4831 Renamed_Eq : Node_Id := Empty;
4832 -- Could use some comments ???
4834 Wrapper_Decl_List : List_Id := No_List;
4835 Wrapper_Body_List : List_Id := No_List;
4836 Null_Proc_Decl_List : List_Id := No_List;
4839 -- Build discriminant checking functions if not a derived type (for
4840 -- derived types that are not tagged types, we always use the
4841 -- discriminant checking functions of the parent type). However, for
4842 -- untagged types the derivation may have taken place before the
4843 -- parent was frozen, so we copy explicitly the discriminant checking
4844 -- functions from the parent into the components of the derived type.
4846 if not Is_Derived_Type (Def_Id)
4847 or else Has_New_Non_Standard_Rep (Def_Id)
4848 or else Is_Tagged_Type (Def_Id)
4850 Build_Discr_Checking_Funcs (Type_Decl);
4852 elsif Is_Derived_Type (Def_Id)
4853 and then not Is_Tagged_Type (Def_Id)
4855 -- If we have a derived Unchecked_Union, we do not inherit the
4856 -- discriminant checking functions from the parent type since the
4857 -- discriminants are non existent.
4859 and then not Is_Unchecked_Union (Def_Id)
4860 and then Has_Discriminants (Def_Id)
4863 Old_Comp : Entity_Id;
4867 First_Component (Base_Type (Underlying_Type (Etype (Def_Id))));
4868 Comp := First_Component (Def_Id);
4869 while Present (Comp) loop
4870 if Ekind (Comp) = E_Component
4871 and then Chars (Comp) = Chars (Old_Comp)
4873 Set_Discriminant_Checking_Func (Comp,
4874 Discriminant_Checking_Func (Old_Comp));
4877 Next_Component (Old_Comp);
4878 Next_Component (Comp);
4883 if Is_Derived_Type (Def_Id)
4884 and then Is_Limited_Type (Def_Id)
4885 and then Is_Tagged_Type (Def_Id)
4887 Check_Stream_Attributes (Def_Id);
4890 -- Update task and controlled component flags, because some of the
4891 -- component types may have been private at the point of the record
4894 Comp := First_Component (Def_Id);
4896 while Present (Comp) loop
4897 if Has_Task (Etype (Comp)) then
4898 Set_Has_Task (Def_Id);
4900 elsif Has_Controlled_Component (Etype (Comp))
4901 or else (Chars (Comp) /= Name_uParent
4902 and then Is_Controlled (Etype (Comp)))
4904 Set_Has_Controlled_Component (Def_Id);
4907 Next_Component (Comp);
4910 -- Creation of the Dispatch Table. Note that a Dispatch Table is
4911 -- created for regular tagged types as well as for Ada types deriving
4912 -- from a C++ Class, but not for tagged types directly corresponding to
4913 -- the C++ classes. In the later case we assume that the Vtable is
4914 -- created in the C++ side and we just use it.
4916 if Is_Tagged_Type (Def_Id) then
4918 if Is_CPP_Class (Def_Id) then
4920 -- Because of the new C++ ABI compatibility we now allow the
4921 -- programer to use the Ada tag (and in this case we must do
4922 -- the normal expansion of the tag)
4924 if Etype (First_Component (Def_Id)) = RTE (RE_Tag)
4925 and then Underlying_Type (Etype (Def_Id)) = Def_Id
4927 Expand_Tagged_Root (Def_Id);
4930 Set_All_DT_Position (Def_Id);
4931 Set_Default_Constructor (Def_Id);
4934 -- Usually inherited primitives are not delayed but the first Ada
4935 -- extension of a CPP_Class is an exception since the address of
4936 -- the inherited subprogram has to be inserted in the new Ada
4937 -- Dispatch Table and this is a freezing action (usually the
4938 -- inherited primitive address is inserted in the DT by
4941 -- Similarly, if this is an inherited operation whose parent is
4942 -- not frozen yet, it is not in the DT of the parent, and we
4943 -- generate an explicit freeze node for the inherited operation,
4944 -- so that it is properly inserted in the DT of the current type.
4947 Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id));
4951 while Present (Elmt) loop
4952 Subp := Node (Elmt);
4954 if Present (Alias (Subp)) then
4955 if Is_CPP_Class (Etype (Def_Id)) then
4956 Set_Has_Delayed_Freeze (Subp);
4958 elsif Has_Delayed_Freeze (Alias (Subp))
4959 and then not Is_Frozen (Alias (Subp))
4961 Set_Is_Frozen (Subp, False);
4962 Set_Has_Delayed_Freeze (Subp);
4970 if Underlying_Type (Etype (Def_Id)) = Def_Id then
4971 Expand_Tagged_Root (Def_Id);
4974 -- Unfreeze momentarily the type to add the predefined primitives
4975 -- operations. The reason we unfreeze is so that these predefined
4976 -- operations will indeed end up as primitive operations (which
4977 -- must be before the freeze point).
4979 Set_Is_Frozen (Def_Id, False);
4981 -- Do not add the spec of the predefined primitives if we are
4982 -- compiling under restriction No_Dispatching_Calls
4984 if not Restriction_Active (No_Dispatching_Calls) then
4985 Make_Predefined_Primitive_Specs
4986 (Def_Id, Predef_List, Renamed_Eq);
4987 Insert_List_Before_And_Analyze (N, Predef_List);
4990 -- Ada 2005 (AI-391): For a nonabstract null extension, create
4991 -- wrapper functions for each nonoverridden inherited function
4992 -- with a controlling result of the type. The wrapper for such
4993 -- a function returns an extension aggregate that invokes the
4994 -- the parent function.
4996 if Ada_Version >= Ada_05
4997 and then not Is_Abstract_Type (Def_Id)
4998 and then Is_Null_Extension (Def_Id)
5000 Make_Controlling_Function_Wrappers
5001 (Def_Id, Wrapper_Decl_List, Wrapper_Body_List);
5002 Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
5005 -- Ada 2005 (AI-251): For a nonabstract type extension, build
5006 -- null procedure declarations for each set of homographic null
5007 -- procedures that are inherited from interface types but not
5008 -- overridden. This is done to ensure that the dispatch table
5009 -- entry associated with such null primitives are properly filled.
5011 if Ada_Version >= Ada_05
5012 and then Etype (Def_Id) /= Def_Id
5013 and then not Is_Abstract_Type (Def_Id)
5015 Make_Null_Procedure_Specs (Def_Id, Null_Proc_Decl_List);
5016 Insert_Actions (N, Null_Proc_Decl_List);
5019 Set_Is_Frozen (Def_Id, True);
5020 Set_All_DT_Position (Def_Id);
5022 -- Add the controlled component before the freezing actions
5023 -- referenced in those actions.
5025 if Has_New_Controlled_Component (Def_Id) then
5026 Expand_Record_Controller (Def_Id);
5029 -- Suppress creation of a dispatch table when Java_VM because the
5030 -- dispatching mechanism is handled internally by the JVM.
5034 -- Ada 2005 (AI-251): Build the secondary dispatch tables
5037 ADT : Elist_Id := Access_Disp_Table (Def_Id);
5039 procedure Add_Secondary_Tables (Typ : Entity_Id);
5040 -- Internal subprogram, recursively climb to the ancestors
5042 --------------------------
5043 -- Add_Secondary_Tables --
5044 --------------------------
5046 procedure Add_Secondary_Tables (Typ : Entity_Id) is
5053 -- Climb to the ancestor (if any) handling private types
5055 if Is_Concurrent_Record_Type (Typ) then
5056 if Present (Abstract_Interface_List (Typ)) then
5057 Add_Secondary_Tables
5058 (Etype (First (Abstract_Interface_List (Typ))));
5061 elsif Present (Full_View (Etype (Typ))) then
5062 if Full_View (Etype (Typ)) /= Typ then
5063 Add_Secondary_Tables (Full_View (Etype (Typ)));
5066 elsif Etype (Typ) /= Typ then
5067 Add_Secondary_Tables (Etype (Typ));
5070 if Present (Abstract_Interfaces (Typ))
5072 not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
5074 Iface := First_Elmt (Abstract_Interfaces (Typ));
5077 E := First_Entity (Typ);
5078 while Present (E) loop
5079 if Is_Tag (E) and then Chars (E) /= Name_uTag then
5082 Ancestor_Typ => Typ,
5083 Suffix_Index => Suffix_Index,
5084 Iface => Node (Iface),
5086 Acc_Disp_Tables => ADT,
5089 Append_Freeze_Actions (Def_Id, Result);
5090 Suffix_Index := Suffix_Index + 1;
5097 end Add_Secondary_Tables;
5099 -- Start of processing to build secondary dispatch tables
5102 -- Handle private types
5104 if Present (Full_View (Def_Id)) then
5105 Add_Secondary_Tables (Full_View (Def_Id));
5107 Add_Secondary_Tables (Def_Id);
5110 Set_Access_Disp_Table (Def_Id, ADT);
5111 Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
5115 -- Make sure that the primitives Initialize, Adjust and Finalize
5116 -- are Frozen before other TSS subprograms. We don't want them
5119 if Is_Controlled (Def_Id) then
5120 if not Is_Limited_Type (Def_Id) then
5121 Append_Freeze_Actions (Def_Id,
5123 (Find_Prim_Op (Def_Id, Name_Adjust), Sloc (Def_Id)));
5126 Append_Freeze_Actions (Def_Id,
5128 (Find_Prim_Op (Def_Id, Name_Initialize), Sloc (Def_Id)));
5130 Append_Freeze_Actions (Def_Id,
5132 (Find_Prim_Op (Def_Id, Name_Finalize), Sloc (Def_Id)));
5135 -- Freeze rest of primitive operations. There is no need to handle
5136 -- the predefined primitives if we are compiling under restriction
5137 -- No_Dispatching_Calls
5139 if not Restriction_Active (No_Dispatching_Calls) then
5140 Append_Freeze_Actions
5141 (Def_Id, Predefined_Primitive_Freeze (Def_Id));
5145 -- In the non-tagged case, an equality function is provided only for
5146 -- variant records (that are not unchecked unions).
5148 elsif Has_Discriminants (Def_Id)
5149 and then not Is_Limited_Type (Def_Id)
5152 Comps : constant Node_Id :=
5153 Component_List (Type_Definition (Type_Decl));
5157 and then Present (Variant_Part (Comps))
5159 Build_Variant_Record_Equality (Def_Id);
5164 -- Before building the record initialization procedure, if we are
5165 -- dealing with a concurrent record value type, then we must go through
5166 -- the discriminants, exchanging discriminals between the concurrent
5167 -- type and the concurrent record value type. See the section "Handling
5168 -- of Discriminants" in the Einfo spec for details.
5170 if Is_Concurrent_Record_Type (Def_Id)
5171 and then Has_Discriminants (Def_Id)
5174 Ctyp : constant Entity_Id :=
5175 Corresponding_Concurrent_Type (Def_Id);
5176 Conc_Discr : Entity_Id;
5177 Rec_Discr : Entity_Id;
5181 Conc_Discr := First_Discriminant (Ctyp);
5182 Rec_Discr := First_Discriminant (Def_Id);
5184 while Present (Conc_Discr) loop
5185 Temp := Discriminal (Conc_Discr);
5186 Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr));
5187 Set_Discriminal (Rec_Discr, Temp);
5189 Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr);
5190 Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr);
5192 Next_Discriminant (Conc_Discr);
5193 Next_Discriminant (Rec_Discr);
5198 if Has_Controlled_Component (Def_Id) then
5199 if No (Controller_Component (Def_Id)) then
5200 Expand_Record_Controller (Def_Id);
5203 Build_Controlling_Procs (Def_Id);
5206 Adjust_Discriminants (Def_Id);
5207 Build_Record_Init_Proc (Type_Decl, Def_Id);
5209 -- For tagged type, build bodies of primitive operations. Note that we
5210 -- do this after building the record initialization experiment, since
5211 -- the primitive operations may need the initialization routine
5213 if Is_Tagged_Type (Def_Id) then
5215 -- Do not add the body of the predefined primitives if we are
5216 -- compiling under restriction No_Dispatching_Calls
5218 if not Restriction_Active (No_Dispatching_Calls) then
5219 Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
5220 Append_Freeze_Actions (Def_Id, Predef_List);
5223 -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
5224 -- inherited functions, then add their bodies to the freeze actions.
5226 if Present (Wrapper_Body_List) then
5227 Append_Freeze_Actions (Def_Id, Wrapper_Body_List);
5230 -- Populate the two auxiliary tables used for dispatching
5231 -- asynchronous, conditional and timed selects for synchronized
5232 -- types that implement a limited interface.
5234 if Ada_Version >= Ada_05
5235 and then not Restriction_Active (No_Dispatching_Calls)
5236 and then Is_Concurrent_Record_Type (Def_Id)
5237 and then Has_Abstract_Interfaces (Def_Id)
5239 Append_Freeze_Actions (Def_Id,
5240 Make_Select_Specific_Data_Table (Def_Id));
5243 end Freeze_Record_Type;
5245 ------------------------------
5246 -- Freeze_Stream_Operations --
5247 ------------------------------
5249 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is
5250 Names : constant array (1 .. 4) of TSS_Name_Type :=
5255 Stream_Op : Entity_Id;
5258 -- Primitive operations of tagged types are frozen when the dispatch
5259 -- table is constructed.
5261 if not Comes_From_Source (Typ)
5262 or else Is_Tagged_Type (Typ)
5267 for J in Names'Range loop
5268 Stream_Op := TSS (Typ, Names (J));
5270 if Present (Stream_Op)
5271 and then Is_Subprogram (Stream_Op)
5272 and then Nkind (Unit_Declaration_Node (Stream_Op)) =
5273 N_Subprogram_Declaration
5274 and then not Is_Frozen (Stream_Op)
5276 Append_Freeze_Actions
5277 (Typ, Freeze_Entity (Stream_Op, Sloc (N)));
5280 end Freeze_Stream_Operations;
5286 -- Full type declarations are expanded at the point at which the type is
5287 -- frozen. The formal N is the Freeze_Node for the type. Any statements or
5288 -- declarations generated by the freezing (e.g. the procedure generated
5289 -- for initialization) are chained in the Actions field list of the freeze
5290 -- node using Append_Freeze_Actions.
5292 function Freeze_Type (N : Node_Id) return Boolean is
5293 Def_Id : constant Entity_Id := Entity (N);
5294 RACW_Seen : Boolean := False;
5295 Result : Boolean := False;
5298 -- Process associated access types needing special processing
5300 if Present (Access_Types_To_Process (N)) then
5302 E : Elmt_Id := First_Elmt (Access_Types_To_Process (N));
5304 while Present (E) loop
5306 if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
5307 Validate_RACW_Primitives (Node (E));
5317 -- If there are RACWs designating this type, make stubs now
5319 Remote_Types_Tagged_Full_View_Encountered (Def_Id);
5323 -- Freeze processing for record types
5325 if Is_Record_Type (Def_Id) then
5326 if Ekind (Def_Id) = E_Record_Type then
5327 Freeze_Record_Type (N);
5329 -- The subtype may have been declared before the type was frozen. If
5330 -- the type has controlled components it is necessary to create the
5331 -- entity for the controller explicitly because it did not exist at
5332 -- the point of the subtype declaration. Only the entity is needed,
5333 -- the back-end will obtain the layout from the type. This is only
5334 -- necessary if this is constrained subtype whose component list is
5335 -- not shared with the base type.
5337 elsif Ekind (Def_Id) = E_Record_Subtype
5338 and then Has_Discriminants (Def_Id)
5339 and then Last_Entity (Def_Id) /= Last_Entity (Base_Type (Def_Id))
5340 and then Present (Controller_Component (Def_Id))
5343 Old_C : constant Entity_Id := Controller_Component (Def_Id);
5347 if Scope (Old_C) = Base_Type (Def_Id) then
5349 -- The entity is the one in the parent. Create new one
5351 New_C := New_Copy (Old_C);
5352 Set_Parent (New_C, Parent (Old_C));
5359 if Is_Itype (Def_Id)
5360 and then Is_Record_Type (Underlying_Type (Scope (Def_Id)))
5362 -- The freeze node is only used to introduce the controller,
5363 -- the back-end has no use for it for a discriminated
5366 Set_Freeze_Node (Def_Id, Empty);
5367 Set_Has_Delayed_Freeze (Def_Id, False);
5371 -- Similar process if the controller of the subtype is not present
5372 -- but the parent has it. This can happen with constrained
5373 -- record components where the subtype is an itype.
5375 elsif Ekind (Def_Id) = E_Record_Subtype
5376 and then Is_Itype (Def_Id)
5377 and then No (Controller_Component (Def_Id))
5378 and then Present (Controller_Component (Etype (Def_Id)))
5381 Old_C : constant Entity_Id :=
5382 Controller_Component (Etype (Def_Id));
5383 New_C : constant Entity_Id := New_Copy (Old_C);
5386 Set_Next_Entity (New_C, First_Entity (Def_Id));
5387 Set_First_Entity (Def_Id, New_C);
5389 -- The freeze node is only used to introduce the controller,
5390 -- the back-end has no use for it for a discriminated
5393 Set_Freeze_Node (Def_Id, Empty);
5394 Set_Has_Delayed_Freeze (Def_Id, False);
5399 -- Freeze processing for array types
5401 elsif Is_Array_Type (Def_Id) then
5402 Freeze_Array_Type (N);
5404 -- Freeze processing for access types
5406 -- For pool-specific access types, find out the pool object used for
5407 -- this type, needs actual expansion of it in some cases. Here are the
5408 -- different cases :
5410 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;"
5411 -- ---> don't use any storage pool
5413 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr.
5415 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
5417 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
5418 -- ---> Storage Pool is the specified one
5420 -- See GNAT Pool packages in the Run-Time for more details
5422 elsif Ekind (Def_Id) = E_Access_Type
5423 or else Ekind (Def_Id) = E_General_Access_Type
5426 Loc : constant Source_Ptr := Sloc (N);
5427 Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
5428 Pool_Object : Entity_Id;
5431 Freeze_Action_Typ : Entity_Id;
5434 if Has_Storage_Size_Clause (Def_Id) then
5435 Siz_Exp := Expression (Parent (Storage_Size_Variable (Def_Id)));
5442 -- Rep Clause "for Def_Id'Storage_Size use 0;"
5443 -- ---> don't use any storage pool
5445 if Has_Storage_Size_Clause (Def_Id)
5446 and then Compile_Time_Known_Value (Siz_Exp)
5447 and then Expr_Value (Siz_Exp) = 0
5453 -- Rep Clause : for Def_Id'Storage_Size use Expr.
5455 -- Def_Id__Pool : Stack_Bounded_Pool
5456 -- (Expr, DT'Size, DT'Alignment);
5458 elsif Has_Storage_Size_Clause (Def_Id) then
5464 -- For unconstrained composite types we give a size of zero
5465 -- so that the pool knows that it needs a special algorithm
5466 -- for variable size object allocation.
5468 if Is_Composite_Type (Desig_Type)
5469 and then not Is_Constrained (Desig_Type)
5472 Make_Integer_Literal (Loc, 0);
5475 Make_Integer_Literal (Loc, Maximum_Alignment);
5479 Make_Attribute_Reference (Loc,
5480 Prefix => New_Reference_To (Desig_Type, Loc),
5481 Attribute_Name => Name_Max_Size_In_Storage_Elements);
5484 Make_Attribute_Reference (Loc,
5485 Prefix => New_Reference_To (Desig_Type, Loc),
5486 Attribute_Name => Name_Alignment);
5490 Make_Defining_Identifier (Loc,
5491 Chars => New_External_Name (Chars (Def_Id), 'P'));
5493 -- We put the code associated with the pools in the entity
5494 -- that has the later freeze node, usually the acces type
5495 -- but it can also be the designated_type; because the pool
5496 -- code requires both those types to be frozen
5498 if Is_Frozen (Desig_Type)
5499 and then (No (Freeze_Node (Desig_Type))
5500 or else Analyzed (Freeze_Node (Desig_Type)))
5502 Freeze_Action_Typ := Def_Id;
5504 -- A Taft amendment type cannot get the freeze actions
5505 -- since the full view is not there.
5507 elsif Is_Incomplete_Or_Private_Type (Desig_Type)
5508 and then No (Full_View (Desig_Type))
5510 Freeze_Action_Typ := Def_Id;
5513 Freeze_Action_Typ := Desig_Type;
5516 Append_Freeze_Action (Freeze_Action_Typ,
5517 Make_Object_Declaration (Loc,
5518 Defining_Identifier => Pool_Object,
5519 Object_Definition =>
5520 Make_Subtype_Indication (Loc,
5523 (RTE (RE_Stack_Bounded_Pool), Loc),
5526 Make_Index_Or_Discriminant_Constraint (Loc,
5527 Constraints => New_List (
5529 -- First discriminant is the Pool Size
5532 Storage_Size_Variable (Def_Id), Loc),
5534 -- Second discriminant is the element size
5538 -- Third discriminant is the alignment
5543 Set_Associated_Storage_Pool (Def_Id, Pool_Object);
5547 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
5548 -- ---> Storage Pool is the specified one
5550 elsif Present (Associated_Storage_Pool (Def_Id)) then
5552 -- Nothing to do the associated storage pool has been attached
5553 -- when analyzing the rep. clause
5558 -- For access-to-controlled types (including class-wide types and
5559 -- Taft-amendment types which potentially have controlled
5560 -- components), expand the list controller object that will store
5561 -- the dynamically allocated objects. Do not do this
5562 -- transformation for expander-generated access types, but do it
5563 -- for types that are the full view of types derived from other
5564 -- private types. Also suppress the list controller in the case
5565 -- of a designated type with convention Java, since this is used
5566 -- when binding to Java API specs, where there's no equivalent of
5567 -- a finalization list and we don't want to pull in the
5568 -- finalization support if not needed.
5570 if not Comes_From_Source (Def_Id)
5571 and then not Has_Private_Declaration (Def_Id)
5575 elsif (Controlled_Type (Desig_Type)
5576 and then Convention (Desig_Type) /= Convention_Java)
5578 (Is_Incomplete_Or_Private_Type (Desig_Type)
5579 and then No (Full_View (Desig_Type))
5581 -- An exception is made for types defined in the run-time
5582 -- because Ada.Tags.Tag itself is such a type and cannot
5583 -- afford this unnecessary overhead that would generates a
5584 -- loop in the expansion scheme...
5586 and then not In_Runtime (Def_Id)
5588 -- Another exception is if Restrictions (No_Finalization)
5589 -- is active, since then we know nothing is controlled.
5591 and then not Restriction_Active (No_Finalization))
5593 -- If the designated type is not frozen yet, its controlled
5594 -- status must be retrieved explicitly.
5596 or else (Is_Array_Type (Desig_Type)
5597 and then not Is_Frozen (Desig_Type)
5598 and then Controlled_Type (Component_Type (Desig_Type)))
5600 Set_Associated_Final_Chain (Def_Id,
5601 Make_Defining_Identifier (Loc,
5602 New_External_Name (Chars (Def_Id), 'L')));
5604 Append_Freeze_Action (Def_Id,
5605 Make_Object_Declaration (Loc,
5606 Defining_Identifier => Associated_Final_Chain (Def_Id),
5607 Object_Definition =>
5608 New_Reference_To (RTE (RE_List_Controller), Loc)));
5612 -- Freeze processing for enumeration types
5614 elsif Ekind (Def_Id) = E_Enumeration_Type then
5616 -- We only have something to do if we have a non-standard
5617 -- representation (i.e. at least one literal whose pos value
5618 -- is not the same as its representation)
5620 if Has_Non_Standard_Rep (Def_Id) then
5621 Freeze_Enumeration_Type (N);
5624 -- Private types that are completed by a derivation from a private
5625 -- type have an internally generated full view, that needs to be
5626 -- frozen. This must be done explicitly because the two views share
5627 -- the freeze node, and the underlying full view is not visible when
5628 -- the freeze node is analyzed.
5630 elsif Is_Private_Type (Def_Id)
5631 and then Is_Derived_Type (Def_Id)
5632 and then Present (Full_View (Def_Id))
5633 and then Is_Itype (Full_View (Def_Id))
5634 and then Has_Private_Declaration (Full_View (Def_Id))
5635 and then Freeze_Node (Full_View (Def_Id)) = N
5637 Set_Entity (N, Full_View (Def_Id));
5638 Result := Freeze_Type (N);
5639 Set_Entity (N, Def_Id);
5641 -- All other types require no expander action. There are such cases
5642 -- (e.g. task types and protected types). In such cases, the freeze
5643 -- nodes are there for use by Gigi.
5647 Freeze_Stream_Operations (N, Def_Id);
5651 when RE_Not_Available =>
5655 -------------------------
5656 -- Get_Simple_Init_Val --
5657 -------------------------
5659 function Get_Simple_Init_Val
5662 Size : Uint := No_Uint) return Node_Id
5669 -- This is the size to be used for computation of the appropriate
5670 -- initial value for the Normalize_Scalars and Initialize_Scalars case.
5674 -- These are the values computed by the procedure Check_Subtype_Bounds
5676 procedure Check_Subtype_Bounds;
5677 -- This procedure examines the subtype T, and its ancestor subtypes and
5678 -- derived types to determine the best known information about the
5679 -- bounds of the subtype. After the call Lo_Bound is set either to
5680 -- No_Uint if no information can be determined, or to a value which
5681 -- represents a known low bound, i.e. a valid value of the subtype can
5682 -- not be less than this value. Hi_Bound is similarly set to a known
5683 -- high bound (valid value cannot be greater than this).
5685 --------------------------
5686 -- Check_Subtype_Bounds --
5687 --------------------------
5689 procedure Check_Subtype_Bounds is
5698 Lo_Bound := No_Uint;
5699 Hi_Bound := No_Uint;
5701 -- Loop to climb ancestor subtypes and derived types
5705 if not Is_Discrete_Type (ST1) then
5709 Lo := Type_Low_Bound (ST1);
5710 Hi := Type_High_Bound (ST1);
5712 if Compile_Time_Known_Value (Lo) then
5713 Loval := Expr_Value (Lo);
5715 if Lo_Bound = No_Uint or else Lo_Bound < Loval then
5720 if Compile_Time_Known_Value (Hi) then
5721 Hival := Expr_Value (Hi);
5723 if Hi_Bound = No_Uint or else Hi_Bound > Hival then
5728 ST2 := Ancestor_Subtype (ST1);
5734 exit when ST1 = ST2;
5737 end Check_Subtype_Bounds;
5739 -- Start of processing for Get_Simple_Init_Val
5742 -- For a private type, we should always have an underlying type
5743 -- (because this was already checked in Needs_Simple_Initialization).
5744 -- What we do is to get the value for the underlying type and then do
5745 -- an Unchecked_Convert to the private type.
5747 if Is_Private_Type (T) then
5748 Val := Get_Simple_Init_Val (Underlying_Type (T), Loc, Size);
5750 -- A special case, if the underlying value is null, then qualify it
5751 -- with the underlying type, so that the null is properly typed
5752 -- Similarly, if it is an aggregate it must be qualified, because an
5753 -- unchecked conversion does not provide a context for it.
5755 if Nkind (Val) = N_Null
5756 or else Nkind (Val) = N_Aggregate
5759 Make_Qualified_Expression (Loc,
5761 New_Occurrence_Of (Underlying_Type (T), Loc),
5765 Result := Unchecked_Convert_To (T, Val);
5767 -- Don't truncate result (important for Initialize/Normalize_Scalars)
5769 if Nkind (Result) = N_Unchecked_Type_Conversion
5770 and then Is_Scalar_Type (Underlying_Type (T))
5772 Set_No_Truncation (Result);
5777 -- For scalars, we must have normalize/initialize scalars case
5779 elsif Is_Scalar_Type (T) then
5780 pragma Assert (Init_Or_Norm_Scalars);
5782 -- Compute size of object. If it is given by the caller, we can use
5783 -- it directly, otherwise we use Esize (T) as an estimate. As far as
5784 -- we know this covers all cases correctly.
5786 if Size = No_Uint or else Size <= Uint_0 then
5787 Size_To_Use := UI_Max (Uint_1, Esize (T));
5789 Size_To_Use := Size;
5792 -- Maximum size to use is 64 bits, since we will create values
5793 -- of type Unsigned_64 and the range must fit this type.
5795 if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then
5796 Size_To_Use := Uint_64;
5799 -- Check known bounds of subtype
5801 Check_Subtype_Bounds;
5803 -- Processing for Normalize_Scalars case
5805 if Normalize_Scalars then
5807 -- If zero is invalid, it is a convenient value to use that is
5808 -- for sure an appropriate invalid value in all situations.
5810 if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
5811 Val := Make_Integer_Literal (Loc, 0);
5813 -- Cases where all one bits is the appropriate invalid value
5815 -- For modular types, all 1 bits is either invalid or valid. If
5816 -- it is valid, then there is nothing that can be done since there
5817 -- are no invalid values (we ruled out zero already).
5819 -- For signed integer types that have no negative values, either
5820 -- there is room for negative values, or there is not. If there
5821 -- is, then all 1 bits may be interpretecd as minus one, which is
5822 -- certainly invalid. Alternatively it is treated as the largest
5823 -- positive value, in which case the observation for modular types
5826 -- For float types, all 1-bits is a NaN (not a number), which is
5827 -- certainly an appropriately invalid value.
5829 elsif Is_Unsigned_Type (T)
5830 or else Is_Floating_Point_Type (T)
5831 or else Is_Enumeration_Type (T)
5833 Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1);
5835 -- Resolve as Unsigned_64, because the largest number we
5836 -- can generate is out of range of universal integer.
5838 Analyze_And_Resolve (Val, RTE (RE_Unsigned_64));
5840 -- Case of signed types
5844 Signed_Size : constant Uint :=
5845 UI_Min (Uint_63, Size_To_Use - 1);
5848 -- Normally we like to use the most negative number. The
5849 -- one exception is when this number is in the known
5850 -- subtype range and the largest positive number is not in
5851 -- the known subtype range.
5853 -- For this exceptional case, use largest positive value
5855 if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint
5856 and then Lo_Bound <= (-(2 ** Signed_Size))
5857 and then Hi_Bound < 2 ** Signed_Size
5859 Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1);
5861 -- Normal case of largest negative value
5864 Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size));
5869 -- Here for Initialize_Scalars case
5872 -- For float types, use float values from System.Scalar_Values
5874 if Is_Floating_Point_Type (T) then
5875 if Root_Type (T) = Standard_Short_Float then
5876 Val_RE := RE_IS_Isf;
5877 elsif Root_Type (T) = Standard_Float then
5878 Val_RE := RE_IS_Ifl;
5879 elsif Root_Type (T) = Standard_Long_Float then
5880 Val_RE := RE_IS_Ilf;
5881 else pragma Assert (Root_Type (T) = Standard_Long_Long_Float);
5882 Val_RE := RE_IS_Ill;
5885 -- If zero is invalid, use zero values from System.Scalar_Values
5887 elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
5888 if Size_To_Use <= 8 then
5889 Val_RE := RE_IS_Iz1;
5890 elsif Size_To_Use <= 16 then
5891 Val_RE := RE_IS_Iz2;
5892 elsif Size_To_Use <= 32 then
5893 Val_RE := RE_IS_Iz4;
5895 Val_RE := RE_IS_Iz8;
5898 -- For unsigned, use unsigned values from System.Scalar_Values
5900 elsif Is_Unsigned_Type (T) then
5901 if Size_To_Use <= 8 then
5902 Val_RE := RE_IS_Iu1;
5903 elsif Size_To_Use <= 16 then
5904 Val_RE := RE_IS_Iu2;
5905 elsif Size_To_Use <= 32 then
5906 Val_RE := RE_IS_Iu4;
5908 Val_RE := RE_IS_Iu8;
5911 -- For signed, use signed values from System.Scalar_Values
5914 if Size_To_Use <= 8 then
5915 Val_RE := RE_IS_Is1;
5916 elsif Size_To_Use <= 16 then
5917 Val_RE := RE_IS_Is2;
5918 elsif Size_To_Use <= 32 then
5919 Val_RE := RE_IS_Is4;
5921 Val_RE := RE_IS_Is8;
5925 Val := New_Occurrence_Of (RTE (Val_RE), Loc);
5928 -- The final expression is obtained by doing an unchecked conversion
5929 -- of this result to the base type of the required subtype. We use
5930 -- the base type to avoid the unchecked conversion from chopping
5931 -- bits, and then we set Kill_Range_Check to preserve the "bad"
5934 Result := Unchecked_Convert_To (Base_Type (T), Val);
5936 -- Ensure result is not truncated, since we want the "bad" bits
5937 -- and also kill range check on result.
5939 if Nkind (Result) = N_Unchecked_Type_Conversion then
5940 Set_No_Truncation (Result);
5941 Set_Kill_Range_Check (Result, True);
5946 -- String or Wide_[Wide]_String (must have Initialize_Scalars set)
5948 elsif Root_Type (T) = Standard_String
5950 Root_Type (T) = Standard_Wide_String
5952 Root_Type (T) = Standard_Wide_Wide_String
5954 pragma Assert (Init_Or_Norm_Scalars);
5957 Make_Aggregate (Loc,
5958 Component_Associations => New_List (
5959 Make_Component_Association (Loc,
5960 Choices => New_List (
5961 Make_Others_Choice (Loc)),
5964 (Component_Type (T), Loc, Esize (Root_Type (T))))));
5966 -- Access type is initialized to null
5968 elsif Is_Access_Type (T) then
5972 -- No other possibilities should arise, since we should only be
5973 -- calling Get_Simple_Init_Val if Needs_Simple_Initialization
5974 -- returned True, indicating one of the above cases held.
5977 raise Program_Error;
5981 when RE_Not_Available =>
5983 end Get_Simple_Init_Val;
5985 ------------------------------
5986 -- Has_New_Non_Standard_Rep --
5987 ------------------------------
5989 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is
5991 if not Is_Derived_Type (T) then
5992 return Has_Non_Standard_Rep (T)
5993 or else Has_Non_Standard_Rep (Root_Type (T));
5995 -- If Has_Non_Standard_Rep is not set on the derived type, the
5996 -- representation is fully inherited.
5998 elsif not Has_Non_Standard_Rep (T) then
6002 return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T));
6004 -- May need a more precise check here: the First_Rep_Item may
6005 -- be a stream attribute, which does not affect the representation
6008 end Has_New_Non_Standard_Rep;
6014 function In_Runtime (E : Entity_Id) return Boolean is
6015 S1 : Entity_Id := Scope (E);
6018 while Scope (S1) /= Standard_Standard loop
6022 return Chars (S1) = Name_System or else Chars (S1) = Name_Ada;
6029 function Init_Formals (Typ : Entity_Id) return List_Id is
6030 Loc : constant Source_Ptr := Sloc (Typ);
6034 -- First parameter is always _Init : in out typ. Note that we need
6035 -- this to be in/out because in the case of the task record value,
6036 -- there are default record fields (_Priority, _Size, -Task_Info)
6037 -- that may be referenced in the generated initialization routine.
6039 Formals := New_List (
6040 Make_Parameter_Specification (Loc,
6041 Defining_Identifier =>
6042 Make_Defining_Identifier (Loc, Name_uInit),
6044 Out_Present => True,
6045 Parameter_Type => New_Reference_To (Typ, Loc)));
6047 -- For task record value, or type that contains tasks, add two more
6048 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain
6049 -- We also add these parameters for the task record type case.
6052 or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ))
6055 Make_Parameter_Specification (Loc,
6056 Defining_Identifier =>
6057 Make_Defining_Identifier (Loc, Name_uMaster),
6058 Parameter_Type => New_Reference_To (RTE (RE_Master_Id), Loc)));
6061 Make_Parameter_Specification (Loc,
6062 Defining_Identifier =>
6063 Make_Defining_Identifier (Loc, Name_uChain),
6065 Out_Present => True,
6067 New_Reference_To (RTE (RE_Activation_Chain), Loc)));
6070 Make_Parameter_Specification (Loc,
6071 Defining_Identifier =>
6072 Make_Defining_Identifier (Loc, Name_uTask_Name),
6075 New_Reference_To (Standard_String, Loc)));
6081 when RE_Not_Available =>
6085 -------------------------
6086 -- Init_Secondary_Tags --
6087 -------------------------
6089 procedure Init_Secondary_Tags
6092 Stmts_List : List_Id)
6094 Loc : constant Source_Ptr := Sloc (Target);
6096 Full_Typ : Entity_Id;
6097 AI_Tag_Comp : Entity_Id;
6099 Is_Synch_Typ : Boolean := False;
6100 -- In case of non concurrent-record-types each parent-type has the
6101 -- tags associated with the interface types that are not implemented
6102 -- by the ancestors; concurrent-record-types have their whole list of
6103 -- interface tags (and this case requires some special management).
6105 procedure Initialize_Tag
6108 Tag_Comp : in out Entity_Id;
6109 Iface_Tag : Node_Id);
6110 -- Initialize the tag of the secondary dispatch table of Typ associated
6111 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
6113 procedure Init_Secondary_Tags_Internal (Typ : Entity_Id);
6114 -- Internal subprogram used to recursively climb to the root type.
6115 -- We assume that all the primitives of the imported C++ class are
6116 -- defined in the C side.
6118 --------------------
6119 -- Initialize_Tag --
6120 --------------------
6122 procedure Initialize_Tag
6125 Tag_Comp : in out Entity_Id;
6126 Iface_Tag : Node_Id)
6131 -- If we are compiling under the CPP full ABI compatibility mode and
6132 -- the ancestor is a CPP_Pragma tagged type then we generate code to
6133 -- inherit the contents of the dispatch table directly from the
6136 if Is_CPP_Class (Etype (Typ)) then
6137 Append_To (Stmts_List,
6138 Build_Inherit_Prims (Loc,
6140 Make_Selected_Component (Loc,
6141 Prefix => New_Copy_Tree (Target),
6142 Selector_Name => New_Reference_To (Tag_Comp, Loc)),
6144 New_Reference_To (Iface_Tag, Loc),
6147 (DT_Entry_Count (First_Tag_Component (Iface)))));
6150 -- Initialize the pointer to the secondary DT associated with the
6153 Append_To (Stmts_List,
6154 Make_Assignment_Statement (Loc,
6156 Make_Selected_Component (Loc,
6157 Prefix => New_Copy_Tree (Target),
6158 Selector_Name => New_Reference_To (Tag_Comp, Loc)),
6160 New_Reference_To (Iface_Tag, Loc)));
6162 -- If the ancestor is CPP_Class, nothing else to do here
6164 if Is_CPP_Class (Etype (Typ)) then
6167 -- Otherwise, comment required ???
6170 -- Issue error if Set_Offset_To_Top is not available in a
6171 -- configurable run-time environment.
6173 if not RTE_Available (RE_Set_Offset_To_Top) then
6174 Error_Msg_CRT ("abstract interface types", Typ);
6178 -- We generate a different call when the parent of the type has
6181 if Typ /= Etype (Typ)
6182 and then Has_Discriminants (Etype (Typ))
6185 (Present (DT_Offset_To_Top_Func (Tag_Comp)));
6188 -- Set_Offset_To_Top
6190 -- Interface_T => Iface'Tag,
6191 -- Is_Constant => False,
6192 -- Offset_Value => n,
6193 -- Offset_Func => Fn'Address)
6195 Append_To (Stmts_List,
6196 Make_Procedure_Call_Statement (Loc,
6197 Name => New_Reference_To
6198 (RTE (RE_Set_Offset_To_Top), Loc),
6199 Parameter_Associations => New_List (
6200 Make_Attribute_Reference (Loc,
6201 Prefix => New_Copy_Tree (Target),
6202 Attribute_Name => Name_Address),
6204 Unchecked_Convert_To (RTE (RE_Tag),
6206 (Node (First_Elmt (Access_Disp_Table (Iface))),
6209 New_Occurrence_Of (Standard_False, Loc),
6211 Unchecked_Convert_To
6212 (RTE (RE_Storage_Offset),
6213 Make_Attribute_Reference (Loc,
6215 Make_Selected_Component (Loc,
6216 Prefix => New_Copy_Tree (Target),
6218 New_Reference_To (Tag_Comp, Loc)),
6219 Attribute_Name => Name_Position)),
6221 Unchecked_Convert_To (RTE (RE_Address),
6222 Make_Attribute_Reference (Loc,
6223 Prefix => New_Reference_To
6224 (DT_Offset_To_Top_Func (Tag_Comp), Loc),
6225 Attribute_Name => Name_Address)))));
6227 -- In this case the next component stores the value of the
6228 -- offset to the top.
6231 Next_Entity (Tag_Comp);
6232 pragma Assert (Present (Tag_Comp));
6234 Append_To (Stmts_List,
6235 Make_Assignment_Statement (Loc,
6237 Make_Selected_Component (Loc,
6238 Prefix => New_Copy_Tree (Target),
6239 Selector_Name => New_Reference_To (Tag_Comp, Loc)),
6241 Make_Attribute_Reference (Loc,
6243 Make_Selected_Component (Loc,
6244 Prefix => New_Copy_Tree (Target),
6246 New_Reference_To (Prev_E, Loc)),
6247 Attribute_Name => Name_Position)));
6249 -- Normal case: No discriminants in the parent type
6253 -- Set_Offset_To_Top
6255 -- Interface_T => Iface'Tag,
6256 -- Is_Constant => True,
6257 -- Offset_Value => n,
6258 -- Offset_Func => null);
6260 Append_To (Stmts_List,
6261 Make_Procedure_Call_Statement (Loc,
6262 Name => New_Reference_To
6263 (RTE (RE_Set_Offset_To_Top), Loc),
6264 Parameter_Associations => New_List (
6265 Make_Attribute_Reference (Loc,
6266 Prefix => New_Copy_Tree (Target),
6267 Attribute_Name => Name_Address),
6269 Unchecked_Convert_To (RTE (RE_Tag),
6272 (Access_Disp_Table (Iface))),
6275 New_Occurrence_Of (Standard_True, Loc),
6277 Unchecked_Convert_To
6278 (RTE (RE_Storage_Offset),
6279 Make_Attribute_Reference (Loc,
6281 Make_Selected_Component (Loc,
6282 Prefix => New_Copy_Tree (Target),
6284 New_Reference_To (Tag_Comp, Loc)),
6285 Attribute_Name => Name_Position)),
6288 (RTE (RE_Null_Address), Loc))));
6293 ----------------------------------
6294 -- Init_Secondary_Tags_Internal --
6295 ----------------------------------
6297 procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is
6301 -- Climb to the ancestor (if any) handling synchronized interface
6302 -- derivations and private types
6304 if Is_Concurrent_Record_Type (Typ) then
6306 Iface_List : constant List_Id := Abstract_Interface_List (Typ);
6309 if Is_Non_Empty_List (Iface_List) then
6310 Init_Secondary_Tags_Internal (Etype (First (Iface_List)));
6314 elsif Present (Full_View (Etype (Typ))) then
6315 if Full_View (Etype (Typ)) /= Typ then
6316 Init_Secondary_Tags_Internal (Full_View (Etype (Typ)));
6319 elsif Etype (Typ) /= Typ then
6320 Init_Secondary_Tags_Internal (Etype (Typ));
6323 if Is_Interface (Typ) then
6325 -- Set_Offset_To_Top
6327 -- Interface_T => Iface'Tag,
6328 -- Is_Constant => True,
6329 -- Offset_Value => 0,
6330 -- Offset_Func => null)
6332 Append_To (Stmts_List,
6333 Make_Procedure_Call_Statement (Loc,
6334 Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
6335 Parameter_Associations => New_List (
6336 Make_Attribute_Reference (Loc,
6337 Prefix => New_Copy_Tree (Target),
6338 Attribute_Name => Name_Address),
6339 Unchecked_Convert_To (RTE (RE_Tag),
6341 (Node (First_Elmt (Access_Disp_Table (Typ))),
6343 New_Occurrence_Of (Standard_True, Loc),
6344 Make_Integer_Literal (Loc, Uint_0),
6345 New_Reference_To (RTE (RE_Null_Address), Loc))));
6348 if Present (Abstract_Interfaces (Typ))
6349 and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
6351 if not Is_Synch_Typ then
6352 AI_Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
6353 pragma Assert (Present (AI_Tag_Comp));
6356 AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
6357 while Present (AI_Elmt) loop
6358 pragma Assert (Present (Node (ADT)));
6362 Iface => Node (AI_Elmt),
6363 Tag_Comp => AI_Tag_Comp,
6364 Iface_Tag => Node (ADT));
6367 AI_Tag_Comp := Next_Tag_Component (AI_Tag_Comp);
6368 Next_Elmt (AI_Elmt);
6371 end Init_Secondary_Tags_Internal;
6373 -- Start of processing for Init_Secondary_Tags
6376 -- Skip the first _Tag, which is the main tag of the tagged type.
6377 -- Following tags correspond with abstract interfaces.
6379 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
6381 -- Handle private types
6383 if Present (Full_View (Typ)) then
6384 Full_Typ := Full_View (Typ);
6389 if Is_Concurrent_Record_Type (Typ) then
6390 Is_Synch_Typ := True;
6391 AI_Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
6394 Init_Secondary_Tags_Internal (Full_Typ);
6395 end Init_Secondary_Tags;
6397 ----------------------------------------
6398 -- Make_Controlling_Function_Wrappers --
6399 ----------------------------------------
6401 procedure Make_Controlling_Function_Wrappers
6402 (Tag_Typ : Entity_Id;
6403 Decl_List : out List_Id;
6404 Body_List : out List_Id)
6406 Loc : constant Source_Ptr := Sloc (Tag_Typ);
6407 Prim_Elmt : Elmt_Id;
6409 Actual_List : List_Id;
6410 Formal_List : List_Id;
6412 Par_Formal : Entity_Id;
6413 Formal_Node : Node_Id;
6414 Func_Spec : Node_Id;
6415 Func_Decl : Node_Id;
6416 Func_Body : Node_Id;
6417 Return_Stmt : Node_Id;
6420 Decl_List := New_List;
6421 Body_List := New_List;
6423 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
6425 while Present (Prim_Elmt) loop
6426 Subp := Node (Prim_Elmt);
6428 -- If a primitive function with a controlling result of the type has
6429 -- not been overridden by the user, then we must create a wrapper
6430 -- function here that effectively overrides it and invokes the
6431 -- (non-abstract) parent function. This can only occur for a null
6432 -- extension. Note that functions with anonymous controlling access
6433 -- results don't qualify and must be overridden. We also exclude
6434 -- Input attributes, since each type will have its own version of
6435 -- Input constructed by the expander. The test for Comes_From_Source
6436 -- is needed to distinguish inherited operations from renamings
6437 -- (which also have Alias set).
6439 if Is_Abstract_Subprogram (Subp)
6440 and then Present (Alias (Subp))
6441 and then not Is_Abstract_Subprogram (Alias (Subp))
6442 and then not Comes_From_Source (Subp)
6443 and then Ekind (Subp) = E_Function
6444 and then Has_Controlling_Result (Subp)
6445 and then not Is_Access_Type (Etype (Subp))
6446 and then not Is_TSS (Subp, TSS_Stream_Input)
6448 Formal_List := No_List;
6449 Formal := First_Formal (Subp);
6451 if Present (Formal) then
6452 Formal_List := New_List;
6454 while Present (Formal) loop
6456 (Make_Parameter_Specification
6458 Defining_Identifier =>
6459 Make_Defining_Identifier (Sloc (Formal),
6460 Chars => Chars (Formal)),
6461 In_Present => In_Present (Parent (Formal)),
6462 Out_Present => Out_Present (Parent (Formal)),
6464 New_Reference_To (Etype (Formal), Loc),
6466 New_Copy_Tree (Expression (Parent (Formal)))),
6469 Next_Formal (Formal);
6474 Make_Function_Specification (Loc,
6475 Defining_Unit_Name =>
6476 Make_Defining_Identifier (Loc, Chars (Subp)),
6477 Parameter_Specifications =>
6479 Result_Definition =>
6480 New_Reference_To (Etype (Subp), Loc));
6482 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6483 Append_To (Decl_List, Func_Decl);
6485 -- Build a wrapper body that calls the parent function. The body
6486 -- contains a single return statement that returns an extension
6487 -- aggregate whose ancestor part is a call to the parent function,
6488 -- passing the formals as actuals (with any controlling arguments
6489 -- converted to the types of the corresponding formals of the
6490 -- parent function, which might be anonymous access types), and
6491 -- having a null extension.
6493 Formal := First_Formal (Subp);
6494 Par_Formal := First_Formal (Alias (Subp));
6495 Formal_Node := First (Formal_List);
6497 if Present (Formal) then
6498 Actual_List := New_List;
6500 Actual_List := No_List;
6503 while Present (Formal) loop
6504 if Is_Controlling_Formal (Formal) then
6505 Append_To (Actual_List,
6506 Make_Type_Conversion (Loc,
6508 New_Occurrence_Of (Etype (Par_Formal), Loc),
6511 (Defining_Identifier (Formal_Node), Loc)));
6516 (Defining_Identifier (Formal_Node), Loc));
6519 Next_Formal (Formal);
6520 Next_Formal (Par_Formal);
6525 Make_Return_Statement (Loc,
6527 Make_Extension_Aggregate (Loc,
6529 Make_Function_Call (Loc,
6530 Name => New_Reference_To (Alias (Subp), Loc),
6531 Parameter_Associations => Actual_List),
6532 Null_Record_Present => True));
6535 Make_Subprogram_Body (Loc,
6536 Specification => New_Copy_Tree (Func_Spec),
6537 Declarations => Empty_List,
6538 Handled_Statement_Sequence =>
6539 Make_Handled_Sequence_Of_Statements (Loc,
6540 Statements => New_List (Return_Stmt)));
6542 Set_Defining_Unit_Name
6543 (Specification (Func_Body),
6544 Make_Defining_Identifier (Loc, Chars (Subp)));
6546 Append_To (Body_List, Func_Body);
6548 -- Replace the inherited function with the wrapper function
6549 -- in the primitive operations list.
6551 Override_Dispatching_Operation
6552 (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec));
6555 Next_Elmt (Prim_Elmt);
6557 end Make_Controlling_Function_Wrappers;
6563 -- <Make_Eq_if shared components>
6565 -- when V1 => <Make_Eq_Case> on subcomponents
6567 -- when Vn => <Make_Eq_Case> on subcomponents
6570 function Make_Eq_Case
6573 Discr : Entity_Id := Empty) return List_Id
6575 Loc : constant Source_Ptr := Sloc (E);
6576 Result : constant List_Id := New_List;
6581 Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
6583 if No (Variant_Part (CL)) then
6587 Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
6589 if No (Variant) then
6593 Alt_List := New_List;
6595 while Present (Variant) loop
6596 Append_To (Alt_List,
6597 Make_Case_Statement_Alternative (Loc,
6598 Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
6599 Statements => Make_Eq_Case (E, Component_List (Variant))));
6601 Next_Non_Pragma (Variant);
6604 -- If we have an Unchecked_Union, use one of the parameters that
6605 -- captures the discriminants.
6607 if Is_Unchecked_Union (E) then
6609 Make_Case_Statement (Loc,
6610 Expression => New_Reference_To (Discr, Loc),
6611 Alternatives => Alt_List));
6615 Make_Case_Statement (Loc,
6617 Make_Selected_Component (Loc,
6618 Prefix => Make_Identifier (Loc, Name_X),
6619 Selector_Name => New_Copy (Name (Variant_Part (CL)))),
6620 Alternatives => Alt_List));
6641 -- or a null statement if the list L is empty
6645 L : List_Id) return Node_Id
6647 Loc : constant Source_Ptr := Sloc (E);
6649 Field_Name : Name_Id;
6654 return Make_Null_Statement (Loc);
6659 C := First_Non_Pragma (L);
6660 while Present (C) loop
6661 Field_Name := Chars (Defining_Identifier (C));
6663 -- The tags must not be compared they are not part of the value.
6664 -- Note also that in the following, we use Make_Identifier for
6665 -- the component names. Use of New_Reference_To to identify the
6666 -- components would be incorrect because the wrong entities for
6667 -- discriminants could be picked up in the private type case.
6669 if Field_Name /= Name_uTag then
6670 Evolve_Or_Else (Cond,
6673 Make_Selected_Component (Loc,
6674 Prefix => Make_Identifier (Loc, Name_X),
6676 Make_Identifier (Loc, Field_Name)),
6679 Make_Selected_Component (Loc,
6680 Prefix => Make_Identifier (Loc, Name_Y),
6682 Make_Identifier (Loc, Field_Name))));
6685 Next_Non_Pragma (C);
6689 return Make_Null_Statement (Loc);
6693 Make_Implicit_If_Statement (E,
6695 Then_Statements => New_List (
6696 Make_Return_Statement (Loc,
6697 Expression => New_Occurrence_Of (Standard_False, Loc))));
6702 -------------------------------
6703 -- Make_Null_Procedure_Specs --
6704 -------------------------------
6706 procedure Make_Null_Procedure_Specs
6707 (Tag_Typ : Entity_Id;
6708 Decl_List : out List_Id)
6710 Loc : constant Source_Ptr := Sloc (Tag_Typ);
6712 Formal_List : List_Id;
6713 Parent_Subp : Entity_Id;
6714 Prim_Elmt : Elmt_Id;
6715 Proc_Spec : Node_Id;
6716 Proc_Decl : Node_Id;
6719 function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean;
6720 -- Returns True if E is a null procedure that is an interface primitive
6722 ---------------------------------
6723 -- Is_Null_Interface_Primitive --
6724 ---------------------------------
6726 function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is
6728 return Comes_From_Source (E)
6729 and then Is_Dispatching_Operation (E)
6730 and then Ekind (E) = E_Procedure
6731 and then Null_Present (Parent (E))
6732 and then Is_Interface (Find_Dispatching_Type (E));
6733 end Is_Null_Interface_Primitive;
6735 -- Start of processing for Make_Null_Procedure_Specs
6738 Decl_List := New_List;
6739 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
6740 while Present (Prim_Elmt) loop
6741 Subp := Node (Prim_Elmt);
6743 -- If a null procedure inherited from an interface has not been
6744 -- overridden, then we build a null procedure declaration to
6745 -- override the inherited procedure.
6747 Parent_Subp := Alias (Subp);
6749 if Present (Parent_Subp)
6750 and then Is_Null_Interface_Primitive (Parent_Subp)
6752 Formal_List := No_List;
6753 Formal := First_Formal (Subp);
6755 if Present (Formal) then
6756 Formal_List := New_List;
6758 while Present (Formal) loop
6760 (Make_Parameter_Specification (Loc,
6761 Defining_Identifier =>
6762 Make_Defining_Identifier (Sloc (Formal),
6763 Chars => Chars (Formal)),
6764 In_Present => In_Present (Parent (Formal)),
6765 Out_Present => Out_Present (Parent (Formal)),
6767 New_Reference_To (Etype (Formal), Loc),
6769 New_Copy_Tree (Expression (Parent (Formal)))),
6772 Next_Formal (Formal);
6777 Make_Procedure_Specification (Loc,
6778 Defining_Unit_Name =>
6779 Make_Defining_Identifier (Loc, Chars (Subp)),
6780 Parameter_Specifications => Formal_List);
6781 Set_Null_Present (Proc_Spec);
6783 Proc_Decl := Make_Subprogram_Declaration (Loc, Proc_Spec);
6784 Append_To (Decl_List, Proc_Decl);
6785 Analyze (Proc_Decl);
6788 Next_Elmt (Prim_Elmt);
6790 end Make_Null_Procedure_Specs;
6792 -------------------------------------
6793 -- Make_Predefined_Primitive_Specs --
6794 -------------------------------------
6796 procedure Make_Predefined_Primitive_Specs
6797 (Tag_Typ : Entity_Id;
6798 Predef_List : out List_Id;
6799 Renamed_Eq : out Node_Id)
6801 Loc : constant Source_Ptr := Sloc (Tag_Typ);
6802 Res : constant List_Id := New_List;
6804 Eq_Needed : Boolean;
6806 Eq_Name : Name_Id := Name_Op_Eq;
6808 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean;
6809 -- Returns true if Prim is a renaming of an unresolved predefined
6810 -- equality operation.
6812 -------------------------------
6813 -- Is_Predefined_Eq_Renaming --
6814 -------------------------------
6816 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is
6818 return Chars (Prim) /= Name_Op_Eq
6819 and then Present (Alias (Prim))
6820 and then Comes_From_Source (Prim)
6821 and then Is_Intrinsic_Subprogram (Alias (Prim))
6822 and then Chars (Alias (Prim)) = Name_Op_Eq;
6823 end Is_Predefined_Eq_Renaming;
6825 -- Start of processing for Make_Predefined_Primitive_Specs
6828 Renamed_Eq := Empty;
6832 Append_To (Res, Predef_Spec_Or_Body (Loc,
6835 Profile => New_List (
6836 Make_Parameter_Specification (Loc,
6837 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
6838 Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
6840 Ret_Type => Standard_Long_Long_Integer));
6842 -- Spec of _Alignment
6844 Append_To (Res, Predef_Spec_Or_Body (Loc,
6846 Name => Name_uAlignment,
6847 Profile => New_List (
6848 Make_Parameter_Specification (Loc,
6849 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
6850 Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
6852 Ret_Type => Standard_Integer));
6854 -- Specs for dispatching stream attributes
6857 Stream_Op_TSS_Names :
6858 constant array (Integer range <>) of TSS_Name_Type :=
6864 for Op in Stream_Op_TSS_Names'Range loop
6865 if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then
6867 Predef_Stream_Attr_Spec (Loc, Tag_Typ,
6868 Stream_Op_TSS_Names (Op)));
6873 -- Spec of "=" if expanded if the type is not limited and if a
6874 -- user defined "=" was not already declared for the non-full
6875 -- view of a private extension
6877 if not Is_Limited_Type (Tag_Typ) then
6880 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
6881 while Present (Prim) loop
6883 -- If a primitive is encountered that renames the predefined
6884 -- equality operator before reaching any explicit equality
6885 -- primitive, then we still need to create a predefined
6886 -- equality function, because calls to it can occur via
6887 -- the renaming. A new name is created for the equality
6888 -- to avoid conflicting with any user-defined equality.
6889 -- (Note that this doesn't account for renamings of
6890 -- equality nested within subpackages???)
6892 if Is_Predefined_Eq_Renaming (Node (Prim)) then
6893 Eq_Name := New_External_Name (Chars (Node (Prim)), 'E');
6895 elsif Chars (Node (Prim)) = Name_Op_Eq
6896 and then (No (Alias (Node (Prim)))
6897 or else Nkind (Unit_Declaration_Node (Node (Prim))) =
6898 N_Subprogram_Renaming_Declaration)
6899 and then Etype (First_Formal (Node (Prim))) =
6900 Etype (Next_Formal (First_Formal (Node (Prim))))
6901 and then Base_Type (Etype (Node (Prim))) = Standard_Boolean
6907 -- If the parent equality is abstract, the inherited equality is
6908 -- abstract as well, and no body can be created for for it.
6910 elsif Chars (Node (Prim)) = Name_Op_Eq
6911 and then Present (Alias (Node (Prim)))
6912 and then Is_Abstract_Subprogram (Alias (Node (Prim)))
6921 -- If a renaming of predefined equality was found
6922 -- but there was no user-defined equality (so Eq_Needed
6923 -- is still true), then set the name back to Name_Op_Eq.
6924 -- But in the case where a user-defined equality was
6925 -- located after such a renaming, then the predefined
6926 -- equality function is still needed, so Eq_Needed must
6927 -- be set back to True.
6929 if Eq_Name /= Name_Op_Eq then
6931 Eq_Name := Name_Op_Eq;
6938 Eq_Spec := Predef_Spec_Or_Body (Loc,
6941 Profile => New_List (
6942 Make_Parameter_Specification (Loc,
6943 Defining_Identifier =>
6944 Make_Defining_Identifier (Loc, Name_X),
6945 Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
6946 Make_Parameter_Specification (Loc,
6947 Defining_Identifier =>
6948 Make_Defining_Identifier (Loc, Name_Y),
6949 Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
6950 Ret_Type => Standard_Boolean);
6951 Append_To (Res, Eq_Spec);
6953 if Eq_Name /= Name_Op_Eq then
6954 Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec));
6956 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
6957 while Present (Prim) loop
6959 -- Any renamings of equality that appeared before an
6960 -- overriding equality must be updated to refer to
6961 -- the entity for the predefined equality, otherwise
6962 -- calls via the renaming would get incorrectly
6963 -- resolved to call the user-defined equality function.
6965 if Is_Predefined_Eq_Renaming (Node (Prim)) then
6966 Set_Alias (Node (Prim), Renamed_Eq);
6968 -- Exit upon encountering a user-defined equality
6970 elsif Chars (Node (Prim)) = Name_Op_Eq
6971 and then No (Alias (Node (Prim)))
6981 -- Spec for dispatching assignment
6983 Append_To (Res, Predef_Spec_Or_Body (Loc,
6985 Name => Name_uAssign,
6986 Profile => New_List (
6987 Make_Parameter_Specification (Loc,
6988 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
6989 Out_Present => True,
6990 Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
6992 Make_Parameter_Specification (Loc,
6993 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
6994 Parameter_Type => New_Reference_To (Tag_Typ, Loc)))));
6997 -- Generate the declarations for the following primitive operations:
6999 -- disp_asynchronous_select
7000 -- disp_conditional_select
7001 -- disp_get_prim_op_kind
7003 -- disp_timed_select
7005 -- for limited interfaces and synchronized types that implement a
7006 -- limited interface.
7008 if Ada_Version >= Ada_05
7010 ((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ))
7011 or else (Is_Concurrent_Record_Type (Tag_Typ)
7012 and then Has_Abstract_Interfaces (Tag_Typ)))
7015 Make_Subprogram_Declaration (Loc,
7017 Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
7020 Make_Subprogram_Declaration (Loc,
7022 Make_Disp_Conditional_Select_Spec (Tag_Typ)));
7025 Make_Subprogram_Declaration (Loc,
7027 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
7030 Make_Subprogram_Declaration (Loc,
7032 Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
7035 Make_Subprogram_Declaration (Loc,
7037 Make_Disp_Timed_Select_Spec (Tag_Typ)));
7040 -- Specs for finalization actions that may be required in case a
7041 -- future extension contain a controlled element. We generate those
7042 -- only for root tagged types where they will get dummy bodies or
7043 -- when the type has controlled components and their body must be
7044 -- generated. It is also impossible to provide those for tagged
7045 -- types defined within s-finimp since it would involve circularity
7048 if In_Finalization_Root (Tag_Typ) then
7051 -- We also skip these if finalization is not available
7053 elsif Restriction_Active (No_Finalization) then
7056 elsif Etype (Tag_Typ) = Tag_Typ
7057 or else Controlled_Type (Tag_Typ)
7059 -- Ada 2005 (AI-251): We must also generate these subprograms if
7060 -- the immediate ancestor is an interface to ensure the correct
7061 -- initialization of its dispatch table.
7063 or else (not Is_Interface (Tag_Typ)
7065 Is_Interface (Etype (Tag_Typ)))
7067 if not Is_Limited_Type (Tag_Typ) then
7069 Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
7072 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
7076 end Make_Predefined_Primitive_Specs;
7078 ---------------------------------
7079 -- Needs_Simple_Initialization --
7080 ---------------------------------
7082 function Needs_Simple_Initialization (T : Entity_Id) return Boolean is
7084 -- Check for private type, in which case test applies to the
7085 -- underlying type of the private type.
7087 if Is_Private_Type (T) then
7089 RT : constant Entity_Id := Underlying_Type (T);
7092 if Present (RT) then
7093 return Needs_Simple_Initialization (RT);
7099 -- Cases needing simple initialization are access types, and, if pragma
7100 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
7103 elsif Is_Access_Type (T)
7104 or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T)))
7108 -- If Initialize/Normalize_Scalars is in effect, string objects also
7109 -- need initialization, unless they are created in the course of
7110 -- expanding an aggregate (since in the latter case they will be
7111 -- filled with appropriate initializing values before they are used).
7113 elsif Init_Or_Norm_Scalars
7115 (Root_Type (T) = Standard_String
7116 or else Root_Type (T) = Standard_Wide_String
7117 or else Root_Type (T) = Standard_Wide_Wide_String)
7120 or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate)
7127 end Needs_Simple_Initialization;
7129 ----------------------
7130 -- Predef_Deep_Spec --
7131 ----------------------
7133 function Predef_Deep_Spec
7135 Tag_Typ : Entity_Id;
7136 Name : TSS_Name_Type;
7137 For_Body : Boolean := False) return Node_Id
7143 if Name = TSS_Deep_Finalize then
7145 Type_B := Standard_Boolean;
7149 Make_Parameter_Specification (Loc,
7150 Defining_Identifier => Make_Defining_Identifier (Loc, Name_L),
7152 Out_Present => True,
7154 New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
7155 Type_B := Standard_Short_Short_Integer;
7159 Make_Parameter_Specification (Loc,
7160 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
7162 Out_Present => True,
7163 Parameter_Type => New_Reference_To (Tag_Typ, Loc)));
7166 Make_Parameter_Specification (Loc,
7167 Defining_Identifier => Make_Defining_Identifier (Loc, Name_B),
7168 Parameter_Type => New_Reference_To (Type_B, Loc)));
7170 return Predef_Spec_Or_Body (Loc,
7171 Name => Make_TSS_Name (Tag_Typ, Name),
7174 For_Body => For_Body);
7177 when RE_Not_Available =>
7179 end Predef_Deep_Spec;
7181 -------------------------
7182 -- Predef_Spec_Or_Body --
7183 -------------------------
7185 function Predef_Spec_Or_Body
7187 Tag_Typ : Entity_Id;
7190 Ret_Type : Entity_Id := Empty;
7191 For_Body : Boolean := False) return Node_Id
7193 Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name);
7197 Set_Is_Public (Id, Is_Public (Tag_Typ));
7199 -- The internal flag is set to mark these declarations because
7200 -- they have specific properties. First they are primitives even
7201 -- if they are not defined in the type scope (the freezing point
7202 -- is not necessarily in the same scope), furthermore the
7203 -- predefined equality can be overridden by a user-defined
7204 -- equality, no body will be generated in this case.
7206 Set_Is_Internal (Id);
7208 if not Debug_Generated_Code then
7209 Set_Debug_Info_Off (Id);
7212 if No (Ret_Type) then
7214 Make_Procedure_Specification (Loc,
7215 Defining_Unit_Name => Id,
7216 Parameter_Specifications => Profile);
7219 Make_Function_Specification (Loc,
7220 Defining_Unit_Name => Id,
7221 Parameter_Specifications => Profile,
7222 Result_Definition =>
7223 New_Reference_To (Ret_Type, Loc));
7226 -- If body case, return empty subprogram body. Note that this is
7227 -- ill-formed, because there is not even a null statement, and
7228 -- certainly not a return in the function case. The caller is
7229 -- expected to do surgery on the body to add the appropriate stuff.
7232 return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty);
7234 -- For the case of Input/Output attributes applied to an abstract type,
7235 -- generate abstract specifications. These will never be called,
7236 -- but we need the slots allocated in the dispatching table so
7237 -- that typ'Class'Input and typ'Class'Output will work properly.
7239 elsif (Is_TSS (Name, TSS_Stream_Input)
7241 Is_TSS (Name, TSS_Stream_Output))
7242 and then Is_Abstract_Type (Tag_Typ)
7244 return Make_Abstract_Subprogram_Declaration (Loc, Spec);
7246 -- Normal spec case, where we return a subprogram declaration
7249 return Make_Subprogram_Declaration (Loc, Spec);
7251 end Predef_Spec_Or_Body;
7253 -----------------------------
7254 -- Predef_Stream_Attr_Spec --
7255 -----------------------------
7257 function Predef_Stream_Attr_Spec
7259 Tag_Typ : Entity_Id;
7260 Name : TSS_Name_Type;
7261 For_Body : Boolean := False) return Node_Id
7263 Ret_Type : Entity_Id;
7266 if Name = TSS_Stream_Input then
7267 Ret_Type := Tag_Typ;
7272 return Predef_Spec_Or_Body (Loc,
7273 Name => Make_TSS_Name (Tag_Typ, Name),
7275 Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
7276 Ret_Type => Ret_Type,
7277 For_Body => For_Body);
7278 end Predef_Stream_Attr_Spec;
7280 ---------------------------------
7281 -- Predefined_Primitive_Bodies --
7282 ---------------------------------
7284 function Predefined_Primitive_Bodies
7285 (Tag_Typ : Entity_Id;
7286 Renamed_Eq : Node_Id) return List_Id
7288 Loc : constant Source_Ptr := Sloc (Tag_Typ);
7289 Res : constant List_Id := New_List;
7292 Eq_Needed : Boolean;
7297 -- See if we have a predefined "=" operator
7299 if Present (Renamed_Eq) then
7301 Eq_Name := Chars (Renamed_Eq);
7307 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
7308 while Present (Prim) loop
7309 if Chars (Node (Prim)) = Name_Op_Eq
7310 and then Is_Internal (Node (Prim))
7313 Eq_Name := Name_Op_Eq;
7320 -- Body of _Alignment
7322 Decl := Predef_Spec_Or_Body (Loc,
7324 Name => Name_uAlignment,
7325 Profile => New_List (
7326 Make_Parameter_Specification (Loc,
7327 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
7328 Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
7330 Ret_Type => Standard_Integer,
7333 Set_Handled_Statement_Sequence (Decl,
7334 Make_Handled_Sequence_Of_Statements (Loc, New_List (
7335 Make_Return_Statement (Loc,
7337 Make_Attribute_Reference (Loc,
7338 Prefix => Make_Identifier (Loc, Name_X),
7339 Attribute_Name => Name_Alignment)))));
7341 Append_To (Res, Decl);
7345 Decl := Predef_Spec_Or_Body (Loc,
7348 Profile => New_List (
7349 Make_Parameter_Specification (Loc,
7350 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
7351 Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
7353 Ret_Type => Standard_Long_Long_Integer,
7356 Set_Handled_Statement_Sequence (Decl,
7357 Make_Handled_Sequence_Of_Statements (Loc, New_List (
7358 Make_Return_Statement (Loc,
7360 Make_Attribute_Reference (Loc,
7361 Prefix => Make_Identifier (Loc, Name_X),
7362 Attribute_Name => Name_Size)))));
7364 Append_To (Res, Decl);
7366 -- Bodies for Dispatching stream IO routines. We need these only for
7367 -- non-limited types (in the limited case there is no dispatching).
7368 -- We also skip them if dispatching or finalization are not available.
7370 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read)
7371 and then No (TSS (Tag_Typ, TSS_Stream_Read))
7373 Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
7374 Append_To (Res, Decl);
7377 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write)
7378 and then No (TSS (Tag_Typ, TSS_Stream_Write))
7380 Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
7381 Append_To (Res, Decl);
7384 -- Skip bodies of _Input and _Output for the abstract case, since
7385 -- the corresponding specs are abstract (see Predef_Spec_Or_Body)
7387 if not Is_Abstract_Type (Tag_Typ) then
7388 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Input)
7389 and then No (TSS (Tag_Typ, TSS_Stream_Input))
7391 Build_Record_Or_Elementary_Input_Function
7392 (Loc, Tag_Typ, Decl, Ent);
7393 Append_To (Res, Decl);
7396 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
7397 and then No (TSS (Tag_Typ, TSS_Stream_Output))
7399 Build_Record_Or_Elementary_Output_Procedure
7400 (Loc, Tag_Typ, Decl, Ent);
7401 Append_To (Res, Decl);
7405 -- Generate the bodies for the following primitive operations:
7407 -- disp_asynchronous_select
7408 -- disp_conditional_select
7409 -- disp_get_prim_op_kind
7411 -- disp_timed_select
7413 -- for limited interfaces and synchronized types that implement a
7414 -- limited interface. The interface versions will have null bodies.
7416 if Ada_Version >= Ada_05
7418 not Restriction_Active (No_Dispatching_Calls)
7420 ((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ))
7421 or else (Is_Concurrent_Record_Type (Tag_Typ)
7422 and then Has_Abstract_Interfaces (Tag_Typ)))
7424 Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
7425 Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));
7426 Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ));
7427 Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ));
7428 Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ));
7431 if not Is_Limited_Type (Tag_Typ) then
7433 -- Body for equality
7437 Predef_Spec_Or_Body (Loc,
7440 Profile => New_List (
7441 Make_Parameter_Specification (Loc,
7442 Defining_Identifier =>
7443 Make_Defining_Identifier (Loc, Name_X),
7444 Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
7446 Make_Parameter_Specification (Loc,
7447 Defining_Identifier =>
7448 Make_Defining_Identifier (Loc, Name_Y),
7449 Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
7451 Ret_Type => Standard_Boolean,
7455 Def : constant Node_Id := Parent (Tag_Typ);
7456 Stmts : constant List_Id := New_List;
7457 Variant_Case : Boolean := Has_Discriminants (Tag_Typ);
7458 Comps : Node_Id := Empty;
7459 Typ_Def : Node_Id := Type_Definition (Def);
7462 if Variant_Case then
7463 if Nkind (Typ_Def) = N_Derived_Type_Definition then
7464 Typ_Def := Record_Extension_Part (Typ_Def);
7467 if Present (Typ_Def) then
7468 Comps := Component_List (Typ_Def);
7471 Variant_Case := Present (Comps)
7472 and then Present (Variant_Part (Comps));
7475 if Variant_Case then
7477 Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def)));
7478 Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps));
7480 Make_Return_Statement (Loc,
7481 Expression => New_Reference_To (Standard_True, Loc)));
7485 Make_Return_Statement (Loc,
7487 Expand_Record_Equality (Tag_Typ,
7489 Lhs => Make_Identifier (Loc, Name_X),
7490 Rhs => Make_Identifier (Loc, Name_Y),
7491 Bodies => Declarations (Decl))));
7494 Set_Handled_Statement_Sequence (Decl,
7495 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
7497 Append_To (Res, Decl);
7500 -- Body for dispatching assignment
7503 Predef_Spec_Or_Body (Loc,
7505 Name => Name_uAssign,
7506 Profile => New_List (
7507 Make_Parameter_Specification (Loc,
7508 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
7509 Out_Present => True,
7510 Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
7512 Make_Parameter_Specification (Loc,
7513 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
7514 Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
7517 Set_Handled_Statement_Sequence (Decl,
7518 Make_Handled_Sequence_Of_Statements (Loc, New_List (
7519 Make_Assignment_Statement (Loc,
7520 Name => Make_Identifier (Loc, Name_X),
7521 Expression => Make_Identifier (Loc, Name_Y)))));
7523 Append_To (Res, Decl);
7526 -- Generate dummy bodies for finalization actions of types that have
7527 -- no controlled components.
7529 -- Skip this processing if we are in the finalization routine in the
7530 -- runtime itself, otherwise we get hopelessly circularly confused!
7532 if In_Finalization_Root (Tag_Typ) then
7535 -- Skip this if finalization is not available
7537 elsif Restriction_Active (No_Finalization) then
7540 elsif (Etype (Tag_Typ) = Tag_Typ
7541 or else Is_Controlled (Tag_Typ)
7543 -- Ada 2005 (AI-251): We must also generate these subprograms
7544 -- if the immediate ancestor of Tag_Typ is an interface to
7545 -- ensure the correct initialization of its dispatch table.
7547 or else (not Is_Interface (Tag_Typ)
7549 Is_Interface (Etype (Tag_Typ))))
7550 and then not Has_Controlled_Component (Tag_Typ)
7552 if not Is_Limited_Type (Tag_Typ) then
7553 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
7555 if Is_Controlled (Tag_Typ) then
7556 Set_Handled_Statement_Sequence (Decl,
7557 Make_Handled_Sequence_Of_Statements (Loc,
7559 Ref => Make_Identifier (Loc, Name_V),
7561 Flist_Ref => Make_Identifier (Loc, Name_L),
7562 With_Attach => Make_Identifier (Loc, Name_B))));
7565 Set_Handled_Statement_Sequence (Decl,
7566 Make_Handled_Sequence_Of_Statements (Loc, New_List (
7567 Make_Null_Statement (Loc))));
7570 Append_To (Res, Decl);
7573 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
7575 if Is_Controlled (Tag_Typ) then
7576 Set_Handled_Statement_Sequence (Decl,
7577 Make_Handled_Sequence_Of_Statements (Loc,
7579 Ref => Make_Identifier (Loc, Name_V),
7581 With_Detach => Make_Identifier (Loc, Name_B))));
7584 Set_Handled_Statement_Sequence (Decl,
7585 Make_Handled_Sequence_Of_Statements (Loc, New_List (
7586 Make_Null_Statement (Loc))));
7589 Append_To (Res, Decl);
7593 end Predefined_Primitive_Bodies;
7595 ---------------------------------
7596 -- Predefined_Primitive_Freeze --
7597 ---------------------------------
7599 function Predefined_Primitive_Freeze
7600 (Tag_Typ : Entity_Id) return List_Id
7602 Loc : constant Source_Ptr := Sloc (Tag_Typ);
7603 Res : constant List_Id := New_List;
7608 Prim := First_Elmt (Primitive_Operations (Tag_Typ));
7609 while Present (Prim) loop
7610 if Is_Internal (Node (Prim)) then
7611 Frnodes := Freeze_Entity (Node (Prim), Loc);
7613 if Present (Frnodes) then
7614 Append_List_To (Res, Frnodes);
7622 end Predefined_Primitive_Freeze;
7624 -------------------------
7625 -- Stream_Operation_OK --
7626 -------------------------
7628 function Stream_Operation_OK
7630 Operation : TSS_Name_Type) return Boolean
7632 Has_Inheritable_Stream_Attribute : Boolean := False;
7635 if Is_Limited_Type (Typ)
7636 and then Is_Tagged_Type (Typ)
7637 and then Is_Derived_Type (Typ)
7639 -- Special case of a limited type extension: a default implementation
7640 -- of the stream attributes Read and Write exists if the attribute
7641 -- has been specified for an ancestor type.
7643 Has_Inheritable_Stream_Attribute :=
7644 Present (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
7648 not (Is_Limited_Type (Typ)
7649 and then not Has_Inheritable_Stream_Attribute)
7650 and then not Has_Unknown_Discriminants (Typ)
7651 and then not (Is_Interface (Typ)
7652 and then (Is_Task_Interface (Typ)
7653 or else Is_Protected_Interface (Typ)
7654 or else Is_Synchronized_Interface (Typ)))
7655 and then not Restriction_Active (No_Streams)
7656 and then not Restriction_Active (No_Dispatch)
7657 and then RTE_Available (RE_Tag)
7658 and then RTE_Available (RE_Root_Stream_Type);
7659 end Stream_Operation_OK;