1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Exp_Aggr
; use Exp_Aggr
;
33 with Exp_Ch4
; use Exp_Ch4
;
34 with Exp_Ch7
; use Exp_Ch7
;
35 with Exp_Ch9
; use Exp_Ch9
;
36 with Exp_Ch11
; use Exp_Ch11
;
37 with Exp_Disp
; use Exp_Disp
;
38 with Exp_Dist
; use Exp_Dist
;
39 with Exp_Smem
; use Exp_Smem
;
40 with Exp_Strm
; use Exp_Strm
;
41 with Exp_Tss
; use Exp_Tss
;
42 with Exp_Util
; use Exp_Util
;
43 with Freeze
; use Freeze
;
44 with Hostparm
; use Hostparm
;
45 with Nlists
; use Nlists
;
46 with Nmake
; use Nmake
;
48 with Restrict
; use Restrict
;
49 with Rtsfind
; use Rtsfind
;
51 with Sem_Ch3
; use Sem_Ch3
;
52 with Sem_Ch8
; use Sem_Ch8
;
53 with Sem_Eval
; use Sem_Eval
;
54 with Sem_Mech
; use Sem_Mech
;
55 with Sem_Res
; use Sem_Res
;
56 with Sem_Util
; use Sem_Util
;
57 with Sinfo
; use Sinfo
;
58 with Stand
; use Stand
;
59 with Snames
; use Snames
;
60 with Tbuild
; use Tbuild
;
61 with Ttypes
; use Ttypes
;
62 with Uintp
; use Uintp
;
63 with Validsw
; use Validsw
;
65 package body Exp_Ch3
is
67 -----------------------
68 -- Local Subprograms --
69 -----------------------
71 procedure Adjust_Discriminants
(Rtype
: Entity_Id
);
72 -- This is used when freezing a record type. It attempts to construct
73 -- more restrictive subtypes for discriminants so that the max size of
74 -- the record can be calculated more accurately. See the body of this
75 -- procedure for details.
77 procedure Build_Array_Init_Proc
(A_Type
: Entity_Id
; Nod
: Node_Id
);
78 -- Build initialization procedure for given array type. Nod is a node
79 -- used for attachment of any actions required in its construction.
80 -- It also supplies the source location used for the procedure.
82 procedure Build_Class_Wide_Master
(T
: Entity_Id
);
83 -- for access to class-wide limited types we must build a task master
84 -- because some subsequent extension may add a task component. To avoid
85 -- bringing in the tasking run-time whenever an access-to-class-wide
86 -- limited type is used, we use the soft-link mechanism and add a level
87 -- of indirection to calls to routines that manipulate Master_Ids.
89 function Build_Discriminant_Formals
93 -- This function uses the discriminants of a type to build a list of
94 -- formal parameters, used in the following function. If the flag Use_Dl
95 -- is set, the list is built using the already defined discriminals
96 -- of the type. Otherwise new identifiers are created, with the source
97 -- names of the discriminants.
99 procedure Build_Master_Renaming
(N
: Node_Id
; T
: Entity_Id
);
100 -- If the designated type of an access type is a task type or contains
101 -- tasks, we make sure that a _Master variable is declared in the current
102 -- scope, and then declare a renaming for it:
104 -- atypeM : Master_Id renames _Master;
106 -- where atyp is the name of the access type. This declaration is
107 -- used when an allocator for the access type is expanded. The node N
108 -- is the full declaration of the designated type that contains tasks.
109 -- The renaming declaration is inserted before N, and after the Master
112 procedure Build_Record_Init_Proc
(N
: Node_Id
; Pe
: Entity_Id
);
113 -- Build record initialization procedure. N is the type declaration
114 -- node, and Pe is the corresponding entity for the record type.
116 procedure Build_Variant_Record_Equality
(Typ
: Entity_Id
);
117 -- Create An Equality function for the non-tagged variant record 'Typ'
118 -- and attach it to the TSS list
120 procedure Check_Stream_Attributes
(Typ
: Entity_Id
);
121 -- Check that if a limited extension has a parent with user-defined
122 -- stream attributes, any limited component of the extension also has
123 -- the corresponding user-defined stream attributes.
125 procedure Expand_Tagged_Root
(T
: Entity_Id
);
126 -- Add a field _Tag at the beginning of the record. This field carries
127 -- the value of the access to the Dispatch table. This procedure is only
128 -- called on root (non CPP_Class) types, the _Tag field being inherited
129 -- by the descendants.
131 procedure Expand_Record_Controller
(T
: Entity_Id
);
132 -- T must be a record type that Has_Controlled_Component. Add a field _C
133 -- of type Record_Controller or Limited_Record_Controller in the record T.
135 procedure Freeze_Array_Type
(N
: Node_Id
);
136 -- Freeze an array type. Deals with building the initialization procedure,
137 -- creating the packed array type for a packed array and also with the
138 -- creation of the controlling procedures for the controlled case. The
139 -- argument N is the N_Freeze_Entity node for the type.
141 procedure Freeze_Enumeration_Type
(N
: Node_Id
);
142 -- Freeze enumeration type with non-standard representation. Builds the
143 -- array and function needed to convert between enumeration pos and
144 -- enumeration representation values. N is the N_Freeze_Entity node
147 procedure Freeze_Record_Type
(N
: Node_Id
);
148 -- Freeze record type. Builds all necessary discriminant checking
149 -- and other ancillary functions, and builds dispatch tables where
150 -- needed. The argument N is the N_Freeze_Entity node. This processing
151 -- applies only to E_Record_Type entities, not to class wide types,
152 -- record subtypes, or private types.
154 procedure Freeze_Stream_Operations
(N
: Node_Id
; Typ
: Entity_Id
);
155 -- Treat user-defined stream operations as renaming_as_body if the
156 -- subprogram they rename is not frozen when the type is frozen.
158 function Init_Formals
(Typ
: Entity_Id
) return List_Id
;
159 -- This function builds the list of formals for an initialization routine.
160 -- The first formal is always _Init with the given type. For task value
161 -- record types and types containing tasks, three additional formals are
164 -- _Master : Master_Id
165 -- _Chain : in out Activation_Chain
166 -- _Task_Id : Task_Image_Type
168 -- The caller must append additional entries for discriminants if required.
170 function In_Runtime
(E
: Entity_Id
) return Boolean;
171 -- Check if E is defined in the RTL (in a child of Ada or System). Used
172 -- to avoid to bring in the overhead of _Input, _Output for tagged types.
174 function Make_Eq_Case
(Node
: Node_Id
; CL
: Node_Id
) return List_Id
;
175 -- Building block for variant record equality. Defined to share the
176 -- code between the tagged and non-tagged case. Given a Component_List
177 -- node CL, it generates an 'if' followed by a 'case' statement that
178 -- compares all components of local temporaries named X and Y (that
179 -- are declared as formals at some upper level). Node provides the
180 -- Sloc to be used for the generated code.
182 function Make_Eq_If
(Node
: Node_Id
; L
: List_Id
) return Node_Id
;
183 -- Building block for variant record equality. Defined to share the
184 -- code between the tagged and non-tagged case. Given the list of
185 -- components (or discriminants) L, it generates a return statement
186 -- that compares all components of local temporaries named X and Y
187 -- (that are declared as formals at some upper level). Node provides
188 -- the Sloc to be used for the generated code.
190 procedure Make_Predefined_Primitive_Specs
191 (Tag_Typ
: Entity_Id
;
192 Predef_List
: out List_Id
;
193 Renamed_Eq
: out Node_Id
);
194 -- Create a list with the specs of the predefined primitive operations.
195 -- This list contains _Size, _Read, _Write, _Input and _Output for
196 -- every tagged types, plus _equality, _assign, _deep_finalize and
197 -- _deep_adjust for non limited tagged types. _Size, _Read, _Write,
198 -- _Input and _Output implement the corresponding attributes that need
199 -- to be dispatching when their arguments are classwide. _equality and
200 -- _assign, implement equality and assignment that also must be
201 -- dispatching. _Deep_Finalize and _Deep_Adjust are empty procedures
202 -- unless the type contains some controlled components that require
203 -- finalization actions. The list is returned in Predef_List. The
204 -- parameter Renamed_Eq either returns the value Empty, or else the
205 -- defining unit name for the predefined equality function in the
206 -- case where the type has a primitive operation that is a renaming
207 -- of predefined equality (but only if there is also an overriding
208 -- user-defined equality function). The returned Renamed_Eq will be
209 -- passed to the corresponding parameter of Predefined_Primitive_Bodies.
211 function Has_New_Non_Standard_Rep
(T
: Entity_Id
) return Boolean;
212 -- returns True if there are representation clauses for type T that
213 -- are not inherited. If the result is false, the init_proc and the
214 -- discriminant_checking functions of the parent can be reused by
217 function Predef_Spec_Or_Body
222 Ret_Type
: Entity_Id
:= Empty
;
223 For_Body
: Boolean := False)
225 -- This function generates the appropriate expansion for a predefined
226 -- primitive operation specified by its name, parameter profile and
227 -- return type (Empty means this is a procedure). If For_Body is false,
228 -- then the returned node is a subprogram declaration. If For_Body is
229 -- true, then the returned node is a empty subprogram body containing
230 -- no declarations and no statements.
232 function Predef_Stream_Attr_Spec
236 For_Body
: Boolean := False)
238 -- Specialized version of Predef_Spec_Or_Body that apply to _read, _write,
239 -- _input and _output whose specs are constructed in Exp_Strm.
241 function Predef_Deep_Spec
245 For_Body
: Boolean := False)
247 -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
248 -- and _deep_finalize
250 function Predefined_Primitive_Bodies
251 (Tag_Typ
: Entity_Id
;
252 Renamed_Eq
: Node_Id
)
254 -- Create the bodies of the predefined primitives that are described in
255 -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
256 -- the defining unit name of the type's predefined equality as returned
257 -- by Make_Predefined_Primitive_Specs.
259 function Predefined_Primitive_Freeze
(Tag_Typ
: Entity_Id
) return List_Id
;
260 -- Freeze entities of all predefined primitive operations. This is needed
261 -- because the bodies of these operations do not normally do any freezeing.
263 --------------------------
264 -- Adjust_Discriminants --
265 --------------------------
267 -- This procedure attempts to define subtypes for discriminants that
268 -- are more restrictive than those declared. Such a replacement is
269 -- possible if we can demonstrate that values outside the restricted
270 -- range would cause constraint errors in any case. The advantage of
271 -- restricting the discriminant types in this way is tha the maximum
272 -- size of the variant record can be calculated more conservatively.
274 -- An example of a situation in which we can perform this type of
275 -- restriction is the following:
277 -- subtype B is range 1 .. 10;
278 -- type Q is array (B range <>) of Integer;
280 -- type V (N : Natural) is record
284 -- In this situation, we can restrict the upper bound of N to 10, since
285 -- any larger value would cause a constraint error in any case.
287 -- There are many situations in which such restriction is possible, but
288 -- for now, we just look for cases like the above, where the component
289 -- in question is a one dimensional array whose upper bound is one of
290 -- the record discriminants. Also the component must not be part of
291 -- any variant part, since then the component does not always exist.
293 procedure Adjust_Discriminants
(Rtype
: Entity_Id
) is
294 Loc
: constant Source_Ptr
:= Sloc
(Rtype
);
311 Comp
:= First_Component
(Rtype
);
312 while Present
(Comp
) loop
314 -- If our parent is a variant, quit, we do not look at components
315 -- that are in variant parts, because they may not always exist.
317 P
:= Parent
(Comp
); -- component declaration
318 P
:= Parent
(P
); -- component list
320 exit when Nkind
(Parent
(P
)) = N_Variant
;
322 -- We are looking for a one dimensional array type
324 Ctyp
:= Etype
(Comp
);
326 if not Is_Array_Type
(Ctyp
)
327 or else Number_Dimensions
(Ctyp
) > 1
332 -- The lower bound must be constant, and the upper bound is a
333 -- discriminant (which is a discriminant of the current record).
335 Ityp
:= Etype
(First_Index
(Ctyp
));
336 Lo
:= Type_Low_Bound
(Ityp
);
337 Hi
:= Type_High_Bound
(Ityp
);
339 if not Compile_Time_Known_Value
(Lo
)
340 or else Nkind
(Hi
) /= N_Identifier
341 or else No
(Entity
(Hi
))
342 or else Ekind
(Entity
(Hi
)) /= E_Discriminant
347 -- We have an array with appropriate bounds
349 Loval
:= Expr_Value
(Lo
);
350 Discr
:= Entity
(Hi
);
351 Dtyp
:= Etype
(Discr
);
353 -- See if the discriminant has a known upper bound
355 Dhi
:= Type_High_Bound
(Dtyp
);
357 if not Compile_Time_Known_Value
(Dhi
) then
361 Dhiv
:= Expr_Value
(Dhi
);
363 -- See if base type of component array has known upper bound
365 Ahi
:= Type_High_Bound
(Etype
(First_Index
(Base_Type
(Ctyp
))));
367 if not Compile_Time_Known_Value
(Ahi
) then
371 Ahiv
:= Expr_Value
(Ahi
);
373 -- The condition for doing the restriction is that the high bound
374 -- of the discriminant is greater than the low bound of the array,
375 -- and is also greater than the high bound of the base type index.
377 if Dhiv
> Loval
and then Dhiv
> Ahiv
then
379 -- We can reset the upper bound of the discriminant type to
380 -- whichever is larger, the low bound of the component, or
381 -- the high bound of the base type array index.
383 -- We build a subtype that is declared as
385 -- subtype Tnn is discr_type range discr_type'First .. max;
387 -- And insert this declaration into the tree. The type of the
388 -- discriminant is then reset to this more restricted subtype.
390 Tnn
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
392 Insert_Action
(Declaration_Node
(Rtype
),
393 Make_Subtype_Declaration
(Loc
,
394 Defining_Identifier
=> Tnn
,
395 Subtype_Indication
=>
396 Make_Subtype_Indication
(Loc
,
397 Subtype_Mark
=> New_Occurrence_Of
(Dtyp
, Loc
),
399 Make_Range_Constraint
(Loc
,
403 Make_Attribute_Reference
(Loc
,
404 Attribute_Name
=> Name_First
,
405 Prefix
=> New_Occurrence_Of
(Dtyp
, Loc
)),
407 Make_Integer_Literal
(Loc
,
408 Intval
=> UI_Max
(Loval
, Ahiv
)))))));
410 Set_Etype
(Discr
, Tnn
);
414 Next_Component
(Comp
);
417 end Adjust_Discriminants
;
419 ---------------------------
420 -- Build_Array_Init_Proc --
421 ---------------------------
423 procedure Build_Array_Init_Proc
(A_Type
: Entity_Id
; Nod
: Node_Id
) is
424 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
425 Comp_Type
: constant Entity_Id
:= Component_Type
(A_Type
);
426 Index_List
: List_Id
;
429 Body_Stmts
: List_Id
;
431 function Init_Component
return List_Id
;
432 -- Create one statement to initialize one array component, designated
433 -- by a full set of indices.
435 function Init_One_Dimension
(N
: Int
) return List_Id
;
436 -- Create loop to initialize one dimension of the array. The single
437 -- statement in the loop body initializes the inner dimensions if any,
438 -- or else the single component. Note that this procedure is called
439 -- recursively, with N being the dimension to be initialized. A call
440 -- with N greater than the number of dimensions simply generates the
441 -- component initialization, terminating the recursion.
447 function Init_Component
return List_Id
is
452 Make_Indexed_Component
(Loc
,
453 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
454 Expressions
=> Index_List
);
456 if Needs_Simple_Initialization
(Comp_Type
) then
457 Set_Assignment_OK
(Comp
);
459 Make_Assignment_Statement
(Loc
,
461 Expression
=> Get_Simple_Init_Val
(Comp_Type
, Loc
)));
465 Build_Initialization_Call
(Loc
, Comp
, Comp_Type
, True, A_Type
);
469 ------------------------
470 -- Init_One_Dimension --
471 ------------------------
473 function Init_One_Dimension
(N
: Int
) return List_Id
is
477 -- If the component does not need initializing, then there is nothing
478 -- to do here, so we return a null body. This occurs when generating
479 -- the dummy Init_Proc needed for Initialize_Scalars processing.
481 if not Has_Non_Null_Base_Init_Proc
(Comp_Type
)
482 and then not Needs_Simple_Initialization
(Comp_Type
)
483 and then not Has_Task
(Comp_Type
)
485 return New_List
(Make_Null_Statement
(Loc
));
487 -- If all dimensions dealt with, we simply initialize the component
489 elsif N
> Number_Dimensions
(A_Type
) then
490 return Init_Component
;
492 -- Here we generate the required loop
496 Make_Defining_Identifier
(Loc
, New_External_Name
('J', N
));
498 Append
(New_Reference_To
(Index
, Loc
), Index_List
);
501 Make_Implicit_Loop_Statement
(Nod
,
504 Make_Iteration_Scheme
(Loc
,
505 Loop_Parameter_Specification
=>
506 Make_Loop_Parameter_Specification
(Loc
,
507 Defining_Identifier
=> Index
,
508 Discrete_Subtype_Definition
=>
509 Make_Attribute_Reference
(Loc
,
510 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
511 Attribute_Name
=> Name_Range
,
512 Expressions
=> New_List
(
513 Make_Integer_Literal
(Loc
, N
))))),
514 Statements
=> Init_One_Dimension
(N
+ 1)));
516 end Init_One_Dimension
;
518 -- Start of processing for Build_Array_Init_Proc
521 if Suppress_Init_Proc
(A_Type
) then
525 Index_List
:= New_List
;
527 -- We need an initialization procedure if any of the following is true:
529 -- 1. The component type has an initialization procedure
530 -- 2. The component type needs simple initialization
531 -- 3. Tasks are present
532 -- 4. The type is marked as a publc entity
534 -- The reason for the public entity test is to deal properly with the
535 -- Initialize_Scalars pragma. This pragma can be set in the client and
536 -- not in the declaring package, this means the client will make a call
537 -- to the initialization procedure (because one of conditions 1-3 must
538 -- apply in this case), and we must generate a procedure (even if it is
539 -- null) to satisfy the call in this case.
541 -- Exception: do not build an array init_proc for a type whose root type
542 -- is Standard.String or Standard.Wide_String, since there is no place
543 -- to put the code, and in any case we handle initialization of such
544 -- types (in the Initialize_Scalars case, that's the only time the issue
545 -- arises) in a special manner anyway which does not need an init_proc.
547 if Has_Non_Null_Base_Init_Proc
(Comp_Type
)
548 or else Needs_Simple_Initialization
(Comp_Type
)
549 or else Has_Task
(Comp_Type
)
550 or else (Is_Public
(A_Type
)
551 and then Root_Type
(A_Type
) /= Standard_String
552 and then Root_Type
(A_Type
) /= Standard_Wide_String
)
555 Make_Defining_Identifier
(Loc
, Name_uInit_Proc
);
557 Body_Stmts
:= Init_One_Dimension
(1);
560 Make_Subprogram_Body
(Loc
,
562 Make_Procedure_Specification
(Loc
,
563 Defining_Unit_Name
=> Proc_Id
,
564 Parameter_Specifications
=> Init_Formals
(A_Type
)),
565 Declarations
=> New_List
,
566 Handled_Statement_Sequence
=>
567 Make_Handled_Sequence_Of_Statements
(Loc
,
568 Statements
=> Body_Stmts
));
570 Set_Ekind
(Proc_Id
, E_Procedure
);
571 Set_Is_Public
(Proc_Id
, Is_Public
(A_Type
));
572 Set_Is_Internal
(Proc_Id
);
573 Set_Has_Completion
(Proc_Id
);
575 if not Debug_Generated_Code
then
576 Set_Debug_Info_Off
(Proc_Id
);
579 -- Set inlined unless controlled stuff or tasks around, in which
580 -- case we do not want to inline, because nested stuff may cause
581 -- difficulties in interunit inlining, and furthermore there is
582 -- in any case no point in inlining such complex init procs.
584 if not Has_Task
(Proc_Id
)
585 and then not Controlled_Type
(Proc_Id
)
587 Set_Is_Inlined
(Proc_Id
);
590 -- Associate Init_Proc with type, and determine if the procedure
591 -- is null (happens because of the Initialize_Scalars pragma case,
592 -- where we have to generate a null procedure in case it is called
593 -- by a client with Initialize_Scalars set). Such procedures have
594 -- to be generated, but do not have to be called, so we mark them
595 -- as null to suppress the call.
597 Set_Init_Proc
(A_Type
, Proc_Id
);
599 if List_Length
(Body_Stmts
) = 1
600 and then Nkind
(First
(Body_Stmts
)) = N_Null_Statement
602 Set_Is_Null_Init_Proc
(Proc_Id
);
606 end Build_Array_Init_Proc
;
608 -----------------------------
609 -- Build_Class_Wide_Master --
610 -----------------------------
612 procedure Build_Class_Wide_Master
(T
: Entity_Id
) is
613 Loc
: constant Source_Ptr
:= Sloc
(T
);
619 -- Nothing to do if there is no task hierarchy.
621 if Restrictions
(No_Task_Hierarchy
) then
625 -- Nothing to do if we already built a master entity for this scope
627 if not Has_Master_Entity
(Scope
(T
)) then
628 -- first build the master entity
629 -- _Master : constant Master_Id := Current_Master.all;
630 -- and insert it just before the current declaration
633 Make_Object_Declaration
(Loc
,
634 Defining_Identifier
=>
635 Make_Defining_Identifier
(Loc
, Name_uMaster
),
636 Constant_Present
=> True,
637 Object_Definition
=> New_Reference_To
(Standard_Integer
, Loc
),
639 Make_Explicit_Dereference
(Loc
,
640 New_Reference_To
(RTE
(RE_Current_Master
), Loc
)));
643 Insert_Before
(P
, Decl
);
645 Set_Has_Master_Entity
(Scope
(T
));
647 -- Now mark the containing scope as a task master
649 while Nkind
(P
) /= N_Compilation_Unit
loop
652 -- If we fall off the top, we are at the outer level, and the
653 -- environment task is our effective master, so nothing to mark.
655 if Nkind
(P
) = N_Task_Body
656 or else Nkind
(P
) = N_Block_Statement
657 or else Nkind
(P
) = N_Subprogram_Body
659 Set_Is_Task_Master
(P
, True);
665 -- Now define the renaming of the master_id.
668 Make_Defining_Identifier
(Loc
,
669 New_External_Name
(Chars
(T
), 'M'));
672 Make_Object_Renaming_Declaration
(Loc
,
673 Defining_Identifier
=> M_Id
,
674 Subtype_Mark
=> New_Reference_To
(Standard_Integer
, Loc
),
675 Name
=> Make_Identifier
(Loc
, Name_uMaster
));
676 Insert_Before
(Parent
(T
), Decl
);
679 Set_Master_Id
(T
, M_Id
);
680 end Build_Class_Wide_Master
;
682 --------------------------------
683 -- Build_Discr_Checking_Funcs --
684 --------------------------------
686 procedure Build_Discr_Checking_Funcs
(N
: Node_Id
) is
689 Enclosing_Func_Id
: Entity_Id
;
694 function Build_Case_Statement
695 (Case_Id
: Entity_Id
;
698 -- Need documentation for this spec ???
700 function Build_Dcheck_Function
701 (Case_Id
: Entity_Id
;
704 -- Build the discriminant checking function for a given variant
706 procedure Build_Dcheck_Functions
(Variant_Part_Node
: Node_Id
);
707 -- Builds the discriminant checking function for each variant of the
708 -- given variant part of the record type.
710 --------------------------
711 -- Build_Case_Statement --
712 --------------------------
714 function Build_Case_Statement
715 (Case_Id
: Entity_Id
;
719 Actuals_List
: List_Id
;
720 Alt_List
: List_Id
:= New_List
;
722 Case_Alt_Node
: Node_Id
;
724 Choice_List
: List_Id
;
726 Return_Node
: Node_Id
;
729 -- Build a case statement containing only two alternatives. The
730 -- first alternative corresponds exactly to the discrete choices
731 -- given on the variant with contains the components that we are
732 -- generating the checks for. If the discriminant is one of these
733 -- return False. The other alternative consists of the choice
734 -- "Others" and will return True indicating the discriminant did
737 Case_Node
:= New_Node
(N_Case_Statement
, Loc
);
739 -- Replace the discriminant which controls the variant, with the
740 -- name of the formal of the checking function.
742 Set_Expression
(Case_Node
,
743 Make_Identifier
(Loc
, Chars
(Case_Id
)));
745 Choice
:= First
(Discrete_Choices
(Variant
));
747 if Nkind
(Choice
) = N_Others_Choice
then
748 Choice_List
:= New_Copy_List
(Others_Discrete_Choices
(Choice
));
750 Choice_List
:= New_Copy_List
(Discrete_Choices
(Variant
));
753 if not Is_Empty_List
(Choice_List
) then
754 Case_Alt_Node
:= New_Node
(N_Case_Statement_Alternative
, Loc
);
755 Set_Discrete_Choices
(Case_Alt_Node
, Choice_List
);
757 -- In case this is a nested variant, we need to return the result
758 -- of the discriminant checking function for the immediately
759 -- enclosing variant.
761 if Present
(Enclosing_Func_Id
) then
762 Actuals_List
:= New_List
;
764 D
:= First_Discriminant
(Rec_Id
);
765 while Present
(D
) loop
766 Append
(Make_Identifier
(Loc
, Chars
(D
)), Actuals_List
);
767 Next_Discriminant
(D
);
771 Make_Return_Statement
(Loc
,
773 Make_Function_Call
(Loc
,
775 New_Reference_To
(Enclosing_Func_Id
, Loc
),
776 Parameter_Associations
=>
781 Make_Return_Statement
(Loc
,
783 New_Reference_To
(Standard_False
, Loc
));
786 Set_Statements
(Case_Alt_Node
, New_List
(Return_Node
));
787 Append
(Case_Alt_Node
, Alt_List
);
790 Case_Alt_Node
:= New_Node
(N_Case_Statement_Alternative
, Loc
);
791 Choice_List
:= New_List
(New_Node
(N_Others_Choice
, Loc
));
792 Set_Discrete_Choices
(Case_Alt_Node
, Choice_List
);
795 Make_Return_Statement
(Loc
,
797 New_Reference_To
(Standard_True
, Loc
));
799 Set_Statements
(Case_Alt_Node
, New_List
(Return_Node
));
800 Append
(Case_Alt_Node
, Alt_List
);
802 Set_Alternatives
(Case_Node
, Alt_List
);
804 end Build_Case_Statement
;
806 ---------------------------
807 -- Build_Dcheck_Function --
808 ---------------------------
810 function Build_Dcheck_Function
811 (Case_Id
: Entity_Id
;
817 Parameter_List
: List_Id
;
821 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
822 Sequence
:= Sequence
+ 1;
825 Make_Defining_Identifier
(Loc
,
826 Chars
=> New_External_Name
(Chars
(Rec_Id
), 'D', Sequence
));
828 Spec_Node
:= New_Node
(N_Function_Specification
, Loc
);
829 Set_Defining_Unit_Name
(Spec_Node
, Func_Id
);
831 Parameter_List
:= Build_Discriminant_Formals
(Rec_Id
, False);
833 Set_Parameter_Specifications
(Spec_Node
, Parameter_List
);
834 Set_Subtype_Mark
(Spec_Node
,
835 New_Reference_To
(Standard_Boolean
, Loc
));
836 Set_Specification
(Body_Node
, Spec_Node
);
837 Set_Declarations
(Body_Node
, New_List
);
839 Set_Handled_Statement_Sequence
(Body_Node
,
840 Make_Handled_Sequence_Of_Statements
(Loc
,
841 Statements
=> New_List
(
842 Build_Case_Statement
(Case_Id
, Variant
))));
844 Set_Ekind
(Func_Id
, E_Function
);
845 Set_Mechanism
(Func_Id
, Default_Mechanism
);
846 Set_Is_Inlined
(Func_Id
, True);
847 Set_Is_Pure
(Func_Id
, True);
848 Set_Is_Public
(Func_Id
, Is_Public
(Rec_Id
));
849 Set_Is_Internal
(Func_Id
, True);
851 if not Debug_Generated_Code
then
852 Set_Debug_Info_Off
(Func_Id
);
855 Append_Freeze_Action
(Rec_Id
, Body_Node
);
856 Set_Dcheck_Function
(Variant
, Func_Id
);
858 end Build_Dcheck_Function
;
860 ----------------------------
861 -- Build_Dcheck_Functions --
862 ----------------------------
864 procedure Build_Dcheck_Functions
(Variant_Part_Node
: Node_Id
) is
865 Component_List_Node
: Node_Id
;
867 Discr_Name
: Entity_Id
;
870 Saved_Enclosing_Func_Id
: Entity_Id
;
873 -- Build the discriminant checking function for each variant, label
874 -- all components of that variant with the function's name.
876 Discr_Name
:= Entity
(Name
(Variant_Part_Node
));
877 Variant
:= First_Non_Pragma
(Variants
(Variant_Part_Node
));
879 while Present
(Variant
) loop
880 Func_Id
:= Build_Dcheck_Function
(Discr_Name
, Variant
);
881 Component_List_Node
:= Component_List
(Variant
);
883 if not Null_Present
(Component_List_Node
) then
885 First_Non_Pragma
(Component_Items
(Component_List_Node
));
887 while Present
(Decl
) loop
888 Set_Discriminant_Checking_Func
889 (Defining_Identifier
(Decl
), Func_Id
);
891 Next_Non_Pragma
(Decl
);
894 if Present
(Variant_Part
(Component_List_Node
)) then
895 Saved_Enclosing_Func_Id
:= Enclosing_Func_Id
;
896 Enclosing_Func_Id
:= Func_Id
;
897 Build_Dcheck_Functions
(Variant_Part
(Component_List_Node
));
898 Enclosing_Func_Id
:= Saved_Enclosing_Func_Id
;
902 Next_Non_Pragma
(Variant
);
904 end Build_Dcheck_Functions
;
906 -- Start of processing for Build_Discr_Checking_Funcs
909 -- Only build if not done already
911 if not Discr_Check_Funcs_Built
(N
) then
912 Type_Def
:= Type_Definition
(N
);
914 if Nkind
(Type_Def
) = N_Record_Definition
then
915 if No
(Component_List
(Type_Def
)) then -- null record.
918 V
:= Variant_Part
(Component_List
(Type_Def
));
921 else pragma Assert
(Nkind
(Type_Def
) = N_Derived_Type_Definition
);
922 if No
(Component_List
(Record_Extension_Part
(Type_Def
))) then
926 (Component_List
(Record_Extension_Part
(Type_Def
)));
930 Rec_Id
:= Defining_Identifier
(N
);
932 if Present
(V
) and then not Is_Unchecked_Union
(Rec_Id
) then
934 Enclosing_Func_Id
:= Empty
;
935 Build_Dcheck_Functions
(V
);
938 Set_Discr_Check_Funcs_Built
(N
);
940 end Build_Discr_Checking_Funcs
;
942 --------------------------------
943 -- Build_Discriminant_Formals --
944 --------------------------------
946 function Build_Discriminant_Formals
953 Loc
: Source_Ptr
:= Sloc
(Rec_Id
);
954 Param_Spec_Node
: Node_Id
;
955 Parameter_List
: List_Id
:= New_List
;
958 if Has_Discriminants
(Rec_Id
) then
959 D
:= First_Discriminant
(Rec_Id
);
961 while Present
(D
) loop
965 Formal
:= Discriminal
(D
);
967 Formal
:= Make_Defining_Identifier
(Loc
, Chars
(D
));
971 Make_Parameter_Specification
(Loc
,
972 Defining_Identifier
=> Formal
,
974 New_Reference_To
(Etype
(D
), Loc
));
975 Append
(Param_Spec_Node
, Parameter_List
);
976 Next_Discriminant
(D
);
980 return Parameter_List
;
981 end Build_Discriminant_Formals
;
983 -------------------------------
984 -- Build_Initialization_Call --
985 -------------------------------
987 -- References to a discriminant inside the record type declaration
988 -- can appear either in the subtype_indication to constrain a
989 -- record or an array, or as part of a larger expression given for
990 -- the initial value of a component. In both of these cases N appears
991 -- in the record initialization procedure and needs to be replaced by
992 -- the formal parameter of the initialization procedure which
993 -- corresponds to that discriminant.
995 -- In the example below, references to discriminants D1 and D2 in proc_1
996 -- are replaced by references to formals with the same name
999 -- A similar replacement is done for calls to any record
1000 -- initialization procedure for any components that are themselves
1001 -- of a record type.
1003 -- type R (D1, D2 : Integer) is record
1004 -- X : Integer := F * D1;
1005 -- Y : Integer := F * D2;
1008 -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
1012 -- Out_2.X := F * D1;
1013 -- Out_2.Y := F * D2;
1016 function Build_Initialization_Call
1020 In_Init_Proc
: Boolean := False;
1021 Enclos_Type
: Entity_Id
:= Empty
;
1022 Discr_Map
: Elist_Id
:= New_Elmt_List
)
1025 First_Arg
: Node_Id
;
1031 Proc
: constant Entity_Id
:= Base_Init_Proc
(Typ
);
1032 Init_Type
: constant Entity_Id
:= Etype
(First_Formal
(Proc
));
1033 Full_Init_Type
: constant Entity_Id
:= Underlying_Type
(Init_Type
);
1034 Res
: List_Id
:= New_List
;
1035 Full_Type
: Entity_Id
:= Typ
;
1036 Controller_Typ
: Entity_Id
;
1039 -- Nothing to do if the Init_Proc is null, unless Initialize_Sclalars
1040 -- is active (in which case we make the call anyway, since in the
1041 -- actual compiled client it may be non null).
1043 if Is_Null_Init_Proc
(Proc
) and then not Init_Or_Norm_Scalars
then
1047 -- Go to full view if private type
1049 if Is_Private_Type
(Typ
)
1050 and then Present
(Full_View
(Typ
))
1052 Full_Type
:= Full_View
(Typ
);
1055 -- If Typ is derived, the procedure is the initialization procedure for
1056 -- the root type. Wrap the argument in an conversion to make it type
1057 -- honest. Actually it isn't quite type honest, because there can be
1058 -- conflicts of views in the private type case. That is why we set
1059 -- Conversion_OK in the conversion node.
1061 if (Is_Record_Type
(Typ
)
1062 or else Is_Array_Type
(Typ
)
1063 or else Is_Private_Type
(Typ
))
1064 and then Init_Type
/= Base_Type
(Typ
)
1066 First_Arg
:= OK_Convert_To
(Etype
(Init_Type
), Id_Ref
);
1067 Set_Etype
(First_Arg
, Init_Type
);
1070 First_Arg
:= Id_Ref
;
1073 Args
:= New_List
(Convert_Concurrent
(First_Arg
, Typ
));
1075 -- In the tasks case, add _Master as the value of the _Master parameter
1076 -- and _Chain as the value of the _Chain parameter. At the outer level,
1077 -- these will be variables holding the corresponding values obtained
1078 -- from GNARL. At inner levels, they will be the parameters passed down
1079 -- through the outer routines.
1081 if Has_Task
(Full_Type
) then
1082 if Restrictions
(No_Task_Hierarchy
) then
1084 -- See comments in System.Tasking.Initialization.Init_RTS
1087 Append_To
(Args
, Make_Integer_Literal
(Loc
, 3));
1089 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
1092 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
1094 Decls
:= Build_Task_Image_Decls
(Loc
, Id_Ref
, Enclos_Type
);
1095 Decl
:= Last
(Decls
);
1098 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
1099 Append_List
(Decls
, Res
);
1106 -- Add discriminant values if discriminants are present
1108 if Has_Discriminants
(Full_Init_Type
) then
1109 Discr
:= First_Discriminant
(Full_Init_Type
);
1111 while Present
(Discr
) loop
1113 -- If this is a discriminated concurrent type, the init_proc
1114 -- for the corresponding record is being called. Use that
1115 -- type directly to find the discriminant value, to handle
1116 -- properly intervening renamed discriminants.
1119 T
: Entity_Id
:= Full_Type
;
1122 if Is_Protected_Type
(T
) then
1123 T
:= Corresponding_Record_Type
(T
);
1127 Get_Discriminant_Value
(
1130 Discriminant_Constraint
(Full_Type
));
1133 if In_Init_Proc
then
1135 -- Replace any possible references to the discriminant in the
1136 -- call to the record initialization procedure with references
1137 -- to the appropriate formal parameter.
1139 if Nkind
(Arg
) = N_Identifier
1140 and then Ekind
(Entity
(Arg
)) = E_Discriminant
1142 Arg
:= New_Reference_To
(Discriminal
(Entity
(Arg
)), Loc
);
1144 -- Case of access discriminants. We replace the reference
1145 -- to the type by a reference to the actual object
1147 elsif Nkind
(Arg
) = N_Attribute_Reference
1148 and then Is_Access_Type
(Etype
(Arg
))
1149 and then Is_Entity_Name
(Prefix
(Arg
))
1150 and then Is_Type
(Entity
(Prefix
(Arg
)))
1153 Make_Attribute_Reference
(Loc
,
1154 Prefix
=> New_Copy
(Prefix
(Id_Ref
)),
1155 Attribute_Name
=> Name_Unrestricted_Access
);
1157 -- Otherwise make a copy of the default expression. Note
1158 -- that we use the current Sloc for this, because we do not
1159 -- want the call to appear to be at the declaration point.
1160 -- Within the expression, replace discriminants with their
1165 New_Copy_Tree
(Arg
, Map
=> Discr_Map
, New_Sloc
=> Loc
);
1169 if Is_Constrained
(Full_Type
) then
1170 Arg
:= Duplicate_Subexpr
(Arg
);
1172 -- The constraints come from the discriminant default
1173 -- exps, they must be reevaluated, so we use New_Copy_Tree
1174 -- but we ensure the proper Sloc (for any embedded calls).
1176 Arg
:= New_Copy_Tree
(Arg
, New_Sloc
=> Loc
);
1180 Append_To
(Args
, Arg
);
1182 Next_Discriminant
(Discr
);
1186 -- If this is a call to initialize the parent component of a derived
1187 -- tagged type, indicate that the tag should not be set in the parent.
1189 if Is_Tagged_Type
(Full_Init_Type
)
1190 and then not Is_CPP_Class
(Full_Init_Type
)
1191 and then Nkind
(Id_Ref
) = N_Selected_Component
1192 and then Chars
(Selector_Name
(Id_Ref
)) = Name_uParent
1194 Append_To
(Args
, New_Occurrence_Of
(Standard_False
, Loc
));
1198 Make_Procedure_Call_Statement
(Loc
,
1199 Name
=> New_Occurrence_Of
(Proc
, Loc
),
1200 Parameter_Associations
=> Args
));
1202 if Controlled_Type
(Typ
)
1203 and then Nkind
(Id_Ref
) = N_Selected_Component
1205 if Chars
(Selector_Name
(Id_Ref
)) /= Name_uParent
then
1206 Append_List_To
(Res
,
1208 Ref
=> New_Copy_Tree
(First_Arg
),
1211 Find_Final_List
(Typ
, New_Copy_Tree
(First_Arg
)),
1212 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
1214 -- If the enclosing type is an extension with new controlled
1215 -- components, it has his own record controller. If the parent
1216 -- also had a record controller, attach it to the new one.
1217 -- Build_Init_Statements relies on the fact that in this specific
1218 -- case the last statement of the result is the attach call to
1219 -- the controller. If this is changed, it must be synchronized.
1221 elsif Present
(Enclos_Type
)
1222 and then Has_New_Controlled_Component
(Enclos_Type
)
1223 and then Has_Controlled_Component
(Typ
)
1225 if Is_Return_By_Reference_Type
(Typ
) then
1226 Controller_Typ
:= RTE
(RE_Limited_Record_Controller
);
1228 Controller_Typ
:= RTE
(RE_Record_Controller
);
1231 Append_List_To
(Res
,
1234 Make_Selected_Component
(Loc
,
1235 Prefix
=> New_Copy_Tree
(First_Arg
),
1236 Selector_Name
=> Make_Identifier
(Loc
, Name_uController
)),
1237 Typ
=> Controller_Typ
,
1238 Flist_Ref
=> Find_Final_List
(Typ
, New_Copy_Tree
(First_Arg
)),
1239 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
1243 -- Discard dynamic string allocated for name after call to init_proc,
1244 -- to avoid storage leaks. This is done for composite types because
1245 -- the allocated name is used as prefix for the id constructed at run-
1246 -- time, and this allocated name is not released when the task itself
1249 if Has_Task
(Full_Type
)
1250 and then not Is_Task_Type
(Full_Type
)
1253 Make_Procedure_Call_Statement
(Loc
,
1254 Name
=> New_Occurrence_Of
(RTE
(RE_Free_Task_Image
), Loc
),
1255 Parameter_Associations
=> New_List
(
1256 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
))));
1260 end Build_Initialization_Call
;
1262 ---------------------------
1263 -- Build_Master_Renaming --
1264 ---------------------------
1266 procedure Build_Master_Renaming
(N
: Node_Id
; T
: Entity_Id
) is
1267 Loc
: constant Source_Ptr
:= Sloc
(N
);
1272 -- Nothing to do if there is no task hierarchy.
1274 if Restrictions
(No_Task_Hierarchy
) then
1279 Make_Defining_Identifier
(Loc
,
1280 New_External_Name
(Chars
(T
), 'M'));
1283 Make_Object_Renaming_Declaration
(Loc
,
1284 Defining_Identifier
=> M_Id
,
1285 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Master_Id
), Loc
),
1286 Name
=> Make_Identifier
(Loc
, Name_uMaster
));
1287 Insert_Before
(N
, Decl
);
1290 Set_Master_Id
(T
, M_Id
);
1292 end Build_Master_Renaming
;
1294 ----------------------------
1295 -- Build_Record_Init_Proc --
1296 ----------------------------
1298 procedure Build_Record_Init_Proc
(N
: Node_Id
; Pe
: Entity_Id
) is
1299 Loc
: Source_Ptr
:= Sloc
(N
);
1300 Proc_Id
: Entity_Id
;
1301 Rec_Type
: Entity_Id
;
1302 Discr_Map
: Elist_Id
:= New_Elmt_List
;
1303 Set_Tag
: Entity_Id
:= Empty
;
1305 function Build_Assignment
(Id
: Entity_Id
; N
: Node_Id
) return List_Id
;
1306 -- Build a assignment statement node which assigns to record
1307 -- component its default expression if defined. The left hand side
1308 -- of the assignment is marked Assignment_OK so that initialization
1309 -- of limited private records works correctly, Return also the
1310 -- adjustment call for controlled objects
1312 procedure Build_Discriminant_Assignments
(Statement_List
: List_Id
);
1313 -- If the record has discriminants, adds assignment statements to
1314 -- statement list to initialize the discriminant values from the
1315 -- arguments of the initialization procedure.
1317 function Build_Init_Statements
(Comp_List
: Node_Id
) return List_Id
;
1318 -- Build a list representing a sequence of statements which initialize
1319 -- components of the given component list. This may involve building
1320 -- case statements for the variant parts.
1322 function Build_Init_Call_Thru
1323 (Parameters
: List_Id
)
1325 -- Given a non-tagged type-derivation that declares discriminants,
1328 -- type R (R1, R2 : Integer) is record ... end record;
1330 -- type D (D1 : Integer) is new R (1, D1);
1332 -- we make the _init_proc of D be
1334 -- procedure _init_proc(X : D; D1 : Integer) is
1336 -- _init_proc( R(X), 1, D1);
1339 -- This function builds the call statement in this _init_proc.
1341 procedure Build_Init_Procedure
;
1342 -- Build the tree corresponding to the procedure specification and body
1343 -- of the initialization procedure (by calling all the preceding
1344 -- auxiliary routines), and install it as the _init TSS.
1346 procedure Build_Record_Checks
(S
: Node_Id
; Check_List
: List_Id
);
1347 -- Add range checks to components of disciminated records. S is a
1348 -- subtype indication of a record component. Check_List is a list
1349 -- to which the check actions are appended.
1351 function Component_Needs_Simple_Initialization
1354 -- Determines if a component needs simple initialization, given its
1355 -- type T. This is identical to Needs_Simple_Initialization, except
1356 -- that the types Tag and Vtable_Ptr, which are access types which
1357 -- would normally require simple initialization to null, do not
1358 -- require initialization as components, since they are explicitly
1359 -- initialized by other means.
1361 procedure Constrain_Array
1363 Check_List
: List_Id
);
1364 -- Called from Build_Record_Checks.
1365 -- Apply a list of index constraints to an unconstrained array type.
1366 -- The first parameter is the entity for the resulting subtype.
1367 -- Check_List is a list to which the check actions are appended.
1369 procedure Constrain_Index
1372 Check_List
: List_Id
);
1373 -- Called from Build_Record_Checks.
1374 -- Process an index constraint in a constrained array declaration.
1375 -- The constraint can be a subtype name, or a range with or without
1376 -- an explicit subtype mark. The index is the corresponding index of the
1377 -- unconstrained array. S is the range expression. Check_List is a list
1378 -- to which the check actions are appended.
1380 function Parent_Subtype_Renaming_Discrims
return Boolean;
1381 -- Returns True for base types N that rename discriminants, else False
1383 function Requires_Init_Proc
(Rec_Id
: Entity_Id
) return Boolean;
1384 -- Determines whether a record initialization procedure needs to be
1385 -- generated for the given record type.
1387 ----------------------
1388 -- Build_Assignment --
1389 ----------------------
1391 function Build_Assignment
(Id
: Entity_Id
; N
: Node_Id
) return List_Id
is
1394 Typ
: constant Entity_Id
:= Underlying_Type
(Etype
(Id
));
1395 Kind
: Node_Kind
:= Nkind
(N
);
1401 Make_Selected_Component
(Loc
,
1402 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
1403 Selector_Name
=> New_Occurrence_Of
(Id
, Loc
));
1404 Set_Assignment_OK
(Lhs
);
1406 -- Case of an access attribute applied to the current
1407 -- instance. Replace the reference to the type by a
1408 -- reference to the actual object. (Note that this
1409 -- handles the case of the top level of the expression
1410 -- being given by such an attribute, but doesn't cover
1411 -- uses nested within an initial value expression.
1412 -- Nested uses are unlikely to occur in practice,
1413 -- but theoretically possible. It's not clear how
1414 -- to handle them without fully traversing the
1417 if Kind
= N_Attribute_Reference
1418 and then (Attribute_Name
(N
) = Name_Unchecked_Access
1420 Attribute_Name
(N
) = Name_Unrestricted_Access
)
1421 and then Is_Entity_Name
(Prefix
(N
))
1422 and then Is_Type
(Entity
(Prefix
(N
)))
1423 and then Entity
(Prefix
(N
)) = Rec_Type
1426 Make_Attribute_Reference
(Loc
,
1427 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
1428 Attribute_Name
=> Name_Unrestricted_Access
);
1431 -- For a derived type the default value is copied from the component
1432 -- declaration of the parent. In the analysis of the init_proc for
1433 -- the parent the default value may have been expanded into a local
1434 -- variable, which is of course not usable here. We must copy the
1435 -- original expression and reanalyze.
1437 if Nkind
(Exp
) = N_Identifier
1438 and then not Comes_From_Source
(Exp
)
1439 and then Analyzed
(Exp
)
1440 and then not In_Open_Scopes
(Scope
(Entity
(Exp
)))
1441 and then Nkind
(Original_Node
(Exp
)) = N_Aggregate
1443 Exp
:= New_Copy_Tree
(Original_Node
(Exp
));
1447 Make_Assignment_Statement
(Loc
,
1449 Expression
=> Exp
));
1451 Set_No_Ctrl_Actions
(First
(Res
));
1453 -- Adjust the tag if tagged (because of possible view conversions).
1454 -- Suppress the tag adjustment when Java_VM because JVM tags are
1455 -- represented implicitly in objects.
1457 if Is_Tagged_Type
(Typ
) and then not Java_VM
then
1459 Make_Assignment_Statement
(Loc
,
1461 Make_Selected_Component
(Loc
,
1462 Prefix
=> New_Copy_Tree
(Lhs
),
1464 New_Reference_To
(Tag_Component
(Typ
), Loc
)),
1467 Unchecked_Convert_To
(RTE
(RE_Tag
),
1468 New_Reference_To
(Access_Disp_Table
(Typ
), Loc
))));
1471 -- Adjust the component if controlled except if it is an
1472 -- aggregate that will be expanded inline
1474 if Kind
= N_Qualified_Expression
then
1475 Kind
:= Nkind
(Parent
(N
));
1478 if Controlled_Type
(Typ
)
1479 and then not (Kind
= N_Aggregate
or else Kind
= N_Extension_Aggregate
)
1481 Append_List_To
(Res
,
1483 Ref
=> New_Copy_Tree
(Lhs
),
1486 Find_Final_List
(Etype
(Id
), New_Copy_Tree
(Lhs
)),
1487 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
1491 end Build_Assignment
;
1493 ------------------------------------
1494 -- Build_Discriminant_Assignments --
1495 ------------------------------------
1497 procedure Build_Discriminant_Assignments
(Statement_List
: List_Id
) is
1499 Is_Tagged
: constant Boolean := Is_Tagged_Type
(Rec_Type
);
1502 if Has_Discriminants
(Rec_Type
)
1503 and then not Is_Unchecked_Union
(Rec_Type
)
1505 D
:= First_Discriminant
(Rec_Type
);
1507 while Present
(D
) loop
1508 -- Don't generate the assignment for discriminants in derived
1509 -- tagged types if the discriminant is a renaming of some
1510 -- ancestor discriminant. This initialization will be done
1511 -- when initializing the _parent field of the derived record.
1513 if Is_Tagged
and then
1514 Present
(Corresponding_Discriminant
(D
))
1520 Append_List_To
(Statement_List
,
1521 Build_Assignment
(D
,
1522 New_Reference_To
(Discriminal
(D
), Loc
)));
1525 Next_Discriminant
(D
);
1528 end Build_Discriminant_Assignments
;
1530 --------------------------
1531 -- Build_Init_Call_Thru --
1532 --------------------------
1534 function Build_Init_Call_Thru
1535 (Parameters
: List_Id
)
1538 Parent_Proc
: constant Entity_Id
:=
1539 Base_Init_Proc
(Etype
(Rec_Type
));
1541 Parent_Type
: constant Entity_Id
:=
1542 Etype
(First_Formal
(Parent_Proc
));
1544 Uparent_Type
: constant Entity_Id
:=
1545 Underlying_Type
(Parent_Type
);
1547 First_Discr_Param
: Node_Id
;
1549 Parent_Discr
: Entity_Id
;
1550 First_Arg
: Node_Id
;
1556 -- First argument (_Init) is the object to be initialized.
1557 -- ??? not sure where to get a reasonable Loc for First_Arg
1560 OK_Convert_To
(Parent_Type
,
1561 New_Reference_To
(Defining_Identifier
(First
(Parameters
)), Loc
));
1563 Set_Etype
(First_Arg
, Parent_Type
);
1565 Args
:= New_List
(Convert_Concurrent
(First_Arg
, Rec_Type
));
1567 -- In the tasks case,
1568 -- add _Master as the value of the _Master parameter
1569 -- add _Chain as the value of the _Chain parameter.
1570 -- add _Task_Id as the value of the _Task_Id parameter.
1571 -- At the outer level, these will be variables holding the
1572 -- corresponding values obtained from GNARL or the expander.
1574 -- At inner levels, they will be the parameters passed down through
1575 -- the outer routines.
1577 First_Discr_Param
:= Next
(First
(Parameters
));
1579 if Has_Task
(Rec_Type
) then
1580 if Restrictions
(No_Task_Hierarchy
) then
1582 -- See comments in System.Tasking.Initialization.Init_RTS
1585 Append_To
(Args
, Make_Integer_Literal
(Loc
, 3));
1587 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
1590 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
1591 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Id
));
1592 First_Discr_Param
:= Next
(Next
(Next
(First_Discr_Param
)));
1595 -- Append discriminant values
1597 if Has_Discriminants
(Uparent_Type
) then
1598 pragma Assert
(not Is_Tagged_Type
(Uparent_Type
));
1600 Parent_Discr
:= First_Discriminant
(Uparent_Type
);
1601 while Present
(Parent_Discr
) loop
1603 -- Get the initial value for this discriminant
1604 -- ?????? needs to be cleaned up to use parent_Discr_Constr
1608 Discr_Value
: Elmt_Id
:=
1610 (Girder_Constraint
(Rec_Type
));
1612 Discr
: Entity_Id
:=
1613 First_Girder_Discriminant
(Uparent_Type
);
1615 while Original_Record_Component
(Parent_Discr
) /= Discr
loop
1616 Next_Girder_Discriminant
(Discr
);
1617 Next_Elmt
(Discr_Value
);
1620 Arg
:= Node
(Discr_Value
);
1623 -- Append it to the list
1625 if Nkind
(Arg
) = N_Identifier
1626 and then Ekind
(Entity
(Arg
)) = E_Discriminant
1629 New_Reference_To
(Discriminal
(Entity
(Arg
)), Loc
));
1631 -- Case of access discriminants. We replace the reference
1632 -- to the type by a reference to the actual object
1635 -- elsif Nkind (Arg) = N_Attribute_Reference
1636 -- and then Is_Entity_Name (Prefix (Arg))
1637 -- and then Is_Type (Entity (Prefix (Arg)))
1640 -- Make_Attribute_Reference (Loc,
1641 -- Prefix => New_Copy (Prefix (Id_Ref)),
1642 -- Attribute_Name => Name_Unrestricted_Access));
1645 Append_To
(Args
, New_Copy
(Arg
));
1648 Next_Discriminant
(Parent_Discr
);
1654 Make_Procedure_Call_Statement
(Loc
,
1655 Name
=> New_Occurrence_Of
(Parent_Proc
, Loc
),
1656 Parameter_Associations
=> Args
));
1659 end Build_Init_Call_Thru
;
1661 --------------------------
1662 -- Build_Init_Procedure --
1663 --------------------------
1665 procedure Build_Init_Procedure
is
1666 Body_Node
: Node_Id
;
1667 Handled_Stmt_Node
: Node_Id
;
1668 Parameters
: List_Id
;
1669 Proc_Spec_Node
: Node_Id
;
1670 Body_Stmts
: List_Id
;
1671 Record_Extension_Node
: Node_Id
;
1675 Body_Stmts
:= New_List
;
1676 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
1678 Proc_Id
:= Make_Defining_Identifier
(Loc
, Name_uInit_Proc
);
1679 Set_Ekind
(Proc_Id
, E_Procedure
);
1681 Proc_Spec_Node
:= New_Node
(N_Procedure_Specification
, Loc
);
1682 Set_Defining_Unit_Name
(Proc_Spec_Node
, Proc_Id
);
1684 Parameters
:= Init_Formals
(Rec_Type
);
1685 Append_List_To
(Parameters
,
1686 Build_Discriminant_Formals
(Rec_Type
, True));
1688 -- For tagged types, we add a flag to indicate whether the routine
1689 -- is called to initialize a parent component in the init_proc of
1690 -- a type extension. If the flag is false, we do not set the tag
1691 -- because it has been set already in the extension.
1693 if Is_Tagged_Type
(Rec_Type
)
1694 and then not Is_CPP_Class
(Rec_Type
)
1697 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
1699 Append_To
(Parameters
,
1700 Make_Parameter_Specification
(Loc
,
1701 Defining_Identifier
=> Set_Tag
,
1702 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
1703 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
1706 Set_Parameter_Specifications
(Proc_Spec_Node
, Parameters
);
1707 Set_Specification
(Body_Node
, Proc_Spec_Node
);
1708 Set_Declarations
(Body_Node
, New_List
);
1710 if Parent_Subtype_Renaming_Discrims
then
1712 -- N is a Derived_Type_Definition that renames the parameters
1713 -- of the ancestor type. We init it by expanding our discrims
1714 -- and call the ancestor _init_proc with a type-converted object
1716 Append_List_To
(Body_Stmts
,
1717 Build_Init_Call_Thru
(Parameters
));
1719 elsif Nkind
(Type_Definition
(N
)) = N_Record_Definition
then
1720 Build_Discriminant_Assignments
(Body_Stmts
);
1722 if not Null_Present
(Type_Definition
(N
)) then
1723 Append_List_To
(Body_Stmts
,
1724 Build_Init_Statements
(
1725 Component_List
(Type_Definition
(N
))));
1729 -- N is a Derived_Type_Definition with a possible non-empty
1730 -- extension. The initialization of a type extension consists
1731 -- in the initialization of the components in the extension.
1733 Build_Discriminant_Assignments
(Body_Stmts
);
1735 Record_Extension_Node
:=
1736 Record_Extension_Part
(Type_Definition
(N
));
1738 if not Null_Present
(Record_Extension_Node
) then
1741 Build_Init_Statements
(
1742 Component_List
(Record_Extension_Node
));
1745 -- The parent field must be initialized first because
1746 -- the offset of the new discriminants may depend on it
1748 Prepend_To
(Body_Stmts
, Remove_Head
(Stmts
));
1749 Append_List_To
(Body_Stmts
, Stmts
);
1754 -- Add here the assignment to instantiate the Tag
1756 -- The assignement corresponds to the code:
1758 -- _Init._Tag := Typ'Tag;
1760 -- Suppress the tag assignment when Java_VM because JVM tags are
1761 -- represented implicitly in objects.
1763 if Is_Tagged_Type
(Rec_Type
)
1764 and then not Is_CPP_Class
(Rec_Type
)
1765 and then not Java_VM
1768 Make_Assignment_Statement
(Loc
,
1770 Make_Selected_Component
(Loc
,
1771 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
1773 New_Reference_To
(Tag_Component
(Rec_Type
), Loc
)),
1776 New_Reference_To
(Access_Disp_Table
(Rec_Type
), Loc
));
1778 -- The tag must be inserted before the assignments to other
1779 -- components, because the initial value of the component may
1780 -- depend ot the tag (eg. through a dispatching operation on
1781 -- an access to the current type). The tag assignment is not done
1782 -- when initializing the parent component of a type extension,
1783 -- because in that case the tag is set in the extension.
1784 -- Extensions of imported C++ classes add a final complication,
1785 -- because we cannot inhibit tag setting in the constructor for
1786 -- the parent. In that case we insert the tag initialization
1787 -- after the calls to initialize the parent.
1790 Make_If_Statement
(Loc
,
1791 Condition
=> New_Occurrence_Of
(Set_Tag
, Loc
),
1792 Then_Statements
=> New_List
(Init_Tag
));
1794 if not Is_CPP_Class
(Etype
(Rec_Type
)) then
1795 Prepend_To
(Body_Stmts
, Init_Tag
);
1799 Nod
: Node_Id
:= First
(Body_Stmts
);
1802 -- We assume the first init_proc call is for the parent
1804 while Present
(Next
(Nod
))
1805 and then (Nkind
(Nod
) /= N_Procedure_Call_Statement
1806 or else Chars
(Name
(Nod
)) /= Name_uInit_Proc
)
1811 Insert_After
(Nod
, Init_Tag
);
1816 Handled_Stmt_Node
:= New_Node
(N_Handled_Sequence_Of_Statements
, Loc
);
1817 Set_Statements
(Handled_Stmt_Node
, Body_Stmts
);
1818 Set_Exception_Handlers
(Handled_Stmt_Node
, No_List
);
1819 Set_Handled_Statement_Sequence
(Body_Node
, Handled_Stmt_Node
);
1821 if not Debug_Generated_Code
then
1822 Set_Debug_Info_Off
(Proc_Id
);
1825 -- Associate Init_Proc with type, and determine if the procedure
1826 -- is null (happens because of the Initialize_Scalars pragma case,
1827 -- where we have to generate a null procedure in case it is called
1828 -- by a client with Initialize_Scalars set). Such procedures have
1829 -- to be generated, but do not have to be called, so we mark them
1830 -- as null to suppress the call.
1832 Set_Init_Proc
(Rec_Type
, Proc_Id
);
1834 if List_Length
(Body_Stmts
) = 1
1835 and then Nkind
(First
(Body_Stmts
)) = N_Null_Statement
1837 Set_Is_Null_Init_Proc
(Proc_Id
);
1839 end Build_Init_Procedure
;
1841 ---------------------------
1842 -- Build_Init_Statements --
1843 ---------------------------
1845 function Build_Init_Statements
(Comp_List
: Node_Id
) return List_Id
is
1847 Statement_List
: List_Id
;
1849 Check_List
: List_Id
:= New_List
;
1851 Per_Object_Constraint_Components
: Boolean;
1860 if Null_Present
(Comp_List
) then
1861 return New_List
(Make_Null_Statement
(Loc
));
1864 Statement_List
:= New_List
;
1866 -- Loop through components, skipping pragmas, in 2 steps. The first
1867 -- step deals with regular components. The second step deals with
1868 -- components have per object constraints, and no explicit initia-
1871 Per_Object_Constraint_Components
:= False;
1873 -- First step : regular components.
1875 Decl
:= First_Non_Pragma
(Component_Items
(Comp_List
));
1876 while Present
(Decl
) loop
1878 Build_Record_Checks
(Subtype_Indication
(Decl
), Check_List
);
1880 Id
:= Defining_Identifier
(Decl
);
1883 if Has_Per_Object_Constraint
(Id
)
1884 and then No
(Expression
(Decl
))
1886 -- Skip processing for now and ask for a second pass
1888 Per_Object_Constraint_Components
:= True;
1890 if Present
(Expression
(Decl
)) then
1891 Stmts
:= Build_Assignment
(Id
, Expression
(Decl
));
1893 elsif Has_Non_Null_Base_Init_Proc
(Typ
) then
1895 Build_Initialization_Call
(Loc
,
1896 Make_Selected_Component
(Loc
,
1897 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
1898 Selector_Name
=> New_Occurrence_Of
(Id
, Loc
)),
1899 Typ
, True, Rec_Type
, Discr_Map
=> Discr_Map
);
1901 elsif Component_Needs_Simple_Initialization
(Typ
) then
1903 Build_Assignment
(Id
, Get_Simple_Init_Val
(Typ
, Loc
));
1909 if Present
(Check_List
) then
1910 Append_List_To
(Statement_List
, Check_List
);
1913 if Present
(Stmts
) then
1915 -- Add the initialization of the record controller
1916 -- before the _Parent field is attached to it when
1917 -- the attachment can occur. It does not work to
1918 -- simply initialize the controller first: it must be
1919 -- initialized after the parent if the parent holds
1920 -- discriminants that can be used to compute the
1921 -- offset of the controller. This code relies on
1922 -- the last statement of the initialization call
1923 -- being the attachement of the parent. see
1924 -- Build_Initialization_Call.
1926 if Chars
(Id
) = Name_uController
1927 and then Rec_Type
/= Etype
(Rec_Type
)
1928 and then Has_Controlled_Component
(Etype
(Rec_Type
))
1929 and then Has_New_Controlled_Component
(Rec_Type
)
1931 Insert_List_Before
(Last
(Statement_List
), Stmts
);
1933 Append_List_To
(Statement_List
, Stmts
);
1938 Next_Non_Pragma
(Decl
);
1941 if Per_Object_Constraint_Components
then
1943 -- Second pass: components with per-object constraints
1945 Decl
:= First_Non_Pragma
(Component_Items
(Comp_List
));
1947 while Present
(Decl
) loop
1949 Id
:= Defining_Identifier
(Decl
);
1952 if Has_Per_Object_Constraint
(Id
)
1953 and then No
(Expression
(Decl
))
1955 if Has_Non_Null_Base_Init_Proc
(Typ
) then
1956 Append_List_To
(Statement_List
,
1957 Build_Initialization_Call
(Loc
,
1958 Make_Selected_Component
(Loc
,
1959 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
1960 Selector_Name
=> New_Occurrence_Of
(Id
, Loc
)),
1961 Typ
, True, Rec_Type
, Discr_Map
=> Discr_Map
));
1963 elsif Component_Needs_Simple_Initialization
(Typ
) then
1964 Append_List_To
(Statement_List
,
1965 Build_Assignment
(Id
, Get_Simple_Init_Val
(Typ
, Loc
)));
1969 Next_Non_Pragma
(Decl
);
1973 -- Process the variant part
1975 if Present
(Variant_Part
(Comp_List
)) then
1976 Alt_List
:= New_List
;
1977 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
1979 while Present
(Variant
) loop
1980 Loc
:= Sloc
(Variant
);
1981 Append_To
(Alt_List
,
1982 Make_Case_Statement_Alternative
(Loc
,
1984 New_Copy_List
(Discrete_Choices
(Variant
)),
1986 Build_Init_Statements
(Component_List
(Variant
))));
1988 Next_Non_Pragma
(Variant
);
1991 -- The expression of the case statement which is a reference
1992 -- to one of the discriminants is replaced by the appropriate
1993 -- formal parameter of the initialization procedure.
1995 Append_To
(Statement_List
,
1996 Make_Case_Statement
(Loc
,
1998 New_Reference_To
(Discriminal
(
1999 Entity
(Name
(Variant_Part
(Comp_List
)))), Loc
),
2000 Alternatives
=> Alt_List
));
2003 -- For a task record type, add the task create call and calls
2004 -- to bind any interrupt (signal) entries.
2006 if Is_Task_Record_Type
(Rec_Type
) then
2007 Append_To
(Statement_List
, Make_Task_Create_Call
(Rec_Type
));
2010 Task_Type
: constant Entity_Id
:=
2011 Corresponding_Concurrent_Type
(Rec_Type
);
2012 Task_Decl
: constant Node_Id
:= Parent
(Task_Type
);
2013 Task_Def
: constant Node_Id
:= Task_Definition
(Task_Decl
);
2018 if Present
(Task_Def
) then
2019 Vis_Decl
:= First
(Visible_Declarations
(Task_Def
));
2020 while Present
(Vis_Decl
) loop
2021 Loc
:= Sloc
(Vis_Decl
);
2023 if Nkind
(Vis_Decl
) = N_Attribute_Definition_Clause
then
2024 if Get_Attribute_Id
(Chars
(Vis_Decl
)) =
2027 Ent
:= Entity
(Name
(Vis_Decl
));
2029 if Ekind
(Ent
) = E_Entry
then
2030 Append_To
(Statement_List
,
2031 Make_Procedure_Call_Statement
(Loc
,
2032 Name
=> New_Reference_To
(
2033 RTE
(RE_Bind_Interrupt_To_Entry
), Loc
),
2034 Parameter_Associations
=> New_List
(
2035 Make_Selected_Component
(Loc
,
2037 Make_Identifier
(Loc
, Name_uInit
),
2039 Make_Identifier
(Loc
, Name_uTask_Id
)),
2040 Entry_Index_Expression
(
2041 Loc
, Ent
, Empty
, Task_Type
),
2042 Expression
(Vis_Decl
))));
2053 -- For a protected type, add statements generated by
2054 -- Make_Initialize_Protection.
2056 if Is_Protected_Record_Type
(Rec_Type
) then
2057 Append_List_To
(Statement_List
,
2058 Make_Initialize_Protection
(Rec_Type
));
2061 -- If no initializations when generated for component declarations
2062 -- corresponding to this Statement_List, append a null statement
2063 -- to the Statement_List to make it a valid Ada tree.
2065 if Is_Empty_List
(Statement_List
) then
2066 Append
(New_Node
(N_Null_Statement
, Loc
), Statement_List
);
2069 return Statement_List
;
2070 end Build_Init_Statements
;
2072 -------------------------
2073 -- Build_Record_Checks --
2074 -------------------------
2076 procedure Build_Record_Checks
(S
: Node_Id
; Check_List
: List_Id
) is
2078 Subtype_Mark_Id
: Entity_Id
;
2081 if Nkind
(S
) = N_Subtype_Indication
then
2082 Find_Type
(Subtype_Mark
(S
));
2084 Subtype_Mark_Id
:= Entity
(Subtype_Mark
(S
));
2086 -- Remaining processing depends on type
2088 case Ekind
(Subtype_Mark_Id
) is
2091 Constrain_Array
(S
, Check_List
);
2097 end Build_Record_Checks
;
2099 -------------------------------------------
2100 -- Component_Needs_Simple_Initialization --
2101 -------------------------------------------
2103 function Component_Needs_Simple_Initialization
2109 Needs_Simple_Initialization
(T
)
2110 and then not Is_RTE
(T
, RE_Tag
)
2111 and then not Is_RTE
(T
, RE_Vtable_Ptr
);
2112 end Component_Needs_Simple_Initialization
;
2114 ---------------------
2115 -- Constrain_Array --
2116 ---------------------
2118 procedure Constrain_Array
2120 Check_List
: List_Id
)
2122 C
: constant Node_Id
:= Constraint
(SI
);
2123 Number_Of_Constraints
: Nat
:= 0;
2128 T
:= Entity
(Subtype_Mark
(SI
));
2130 if Ekind
(T
) in Access_Kind
then
2131 T
:= Designated_Type
(T
);
2134 S
:= First
(Constraints
(C
));
2136 while Present
(S
) loop
2137 Number_Of_Constraints
:= Number_Of_Constraints
+ 1;
2141 -- In either case, the index constraint must provide a discrete
2142 -- range for each index of the array type and the type of each
2143 -- discrete range must be the same as that of the corresponding
2144 -- index. (RM 3.6.1)
2146 S
:= First
(Constraints
(C
));
2147 Index
:= First_Index
(T
);
2150 -- Apply constraints to each index type
2152 for J
in 1 .. Number_Of_Constraints
loop
2153 Constrain_Index
(Index
, S
, Check_List
);
2158 end Constrain_Array
;
2160 ---------------------
2161 -- Constrain_Index --
2162 ---------------------
2164 procedure Constrain_Index
2167 Check_List
: List_Id
)
2169 T
: constant Entity_Id
:= Etype
(Index
);
2172 if Nkind
(S
) = N_Range
then
2173 Process_Range_Expr_In_Decl
(S
, T
, Check_List
);
2175 end Constrain_Index
;
2177 --------------------------------------
2178 -- Parent_Subtype_Renaming_Discrims --
2179 --------------------------------------
2181 function Parent_Subtype_Renaming_Discrims
return Boolean is
2186 if Base_Type
(Pe
) /= Pe
then
2191 or else not Has_Discriminants
(Pe
)
2192 or else Is_Constrained
(Pe
)
2193 or else Is_Tagged_Type
(Pe
)
2198 -- If there are no explicit girder discriminants we have inherited
2199 -- the root type discriminants so far, so no renamings occurred.
2201 if First_Discriminant
(Pe
) = First_Girder_Discriminant
(Pe
) then
2205 -- Check if we have done some trivial renaming of the parent
2206 -- discriminants, i.e. someting like
2208 -- type DT (X1,X2: int) is new PT (X1,X2);
2210 De
:= First_Discriminant
(Pe
);
2211 Dp
:= First_Discriminant
(Etype
(Pe
));
2213 while Present
(De
) loop
2214 pragma Assert
(Present
(Dp
));
2216 if Corresponding_Discriminant
(De
) /= Dp
then
2220 Next_Discriminant
(De
);
2221 Next_Discriminant
(Dp
);
2224 return Present
(Dp
);
2225 end Parent_Subtype_Renaming_Discrims
;
2227 ------------------------
2228 -- Requires_Init_Proc --
2229 ------------------------
2231 function Requires_Init_Proc
(Rec_Id
: Entity_Id
) return Boolean is
2232 Comp_Decl
: Node_Id
;
2237 -- Definitely do not need one if specifically suppressed
2239 if Suppress_Init_Proc
(Rec_Id
) then
2243 -- Otherwise we need to generate an initialization procedure if
2244 -- Is_CPP_Class is False and at least one of the following applies:
2246 -- 1. Discriminants are present, since they need to be initialized
2247 -- with the appropriate discriminant constraint expressions.
2248 -- However, the discriminant of an unchecked union does not
2249 -- count, since the discriminant is not present.
2251 -- 2. The type is a tagged type, since the implicit Tag component
2252 -- needs to be initialized with a pointer to the dispatch table.
2254 -- 3. The type contains tasks
2256 -- 4. One or more components has an initial value
2258 -- 5. One or more components is for a type which itself requires
2259 -- an initialization procedure.
2261 -- 6. One or more components is a type that requires simple
2262 -- initialization (see Needs_Simple_Initialization), except
2263 -- that types Tag and Vtable_Ptr are excluded, since fields
2264 -- of these types are initialized by other means.
2266 -- 7. The type is the record type built for a task type (since at
2267 -- the very least, Create_Task must be called)
2269 -- 8. The type is the record type built for a protected type (since
2270 -- at least Initialize_Protection must be called)
2272 -- 9. The type is marked as a public entity. The reason we add this
2273 -- case (even if none of the above apply) is to properly handle
2274 -- Initialize_Scalars. If a package is compiled without an IS
2275 -- pragma, and the client is compiled with an IS pragma, then
2276 -- the client will think an initialization procedure is present
2277 -- and call it, when in fact no such procedure is required, but
2278 -- since the call is generated, there had better be a routine
2279 -- at the other end of the call, even if it does nothing!)
2281 -- Note: the reason we exclude the CPP_Class case is ???
2283 if Is_CPP_Class
(Rec_Id
) then
2286 elsif Is_Public
(Rec_Id
) then
2289 elsif (Has_Discriminants
(Rec_Id
)
2290 and then not Is_Unchecked_Union
(Rec_Id
))
2291 or else Is_Tagged_Type
(Rec_Id
)
2292 or else Is_Concurrent_Record_Type
(Rec_Id
)
2293 or else Has_Task
(Rec_Id
)
2298 Id
:= First_Component
(Rec_Id
);
2300 while Present
(Id
) loop
2301 Comp_Decl
:= Parent
(Id
);
2304 if Present
(Expression
(Comp_Decl
))
2305 or else Has_Non_Null_Base_Init_Proc
(Typ
)
2306 or else Component_Needs_Simple_Initialization
(Typ
)
2311 Next_Component
(Id
);
2315 end Requires_Init_Proc
;
2317 -- Start of processing for Build_Record_Init_Proc
2320 Rec_Type
:= Defining_Identifier
(N
);
2322 -- This may be full declaration of a private type, in which case
2323 -- the visible entity is a record, and the private entity has been
2324 -- exchanged with it in the private part of the current package.
2325 -- The initialization procedure is built for the record type, which
2326 -- is retrievable from the private entity.
2328 if Is_Incomplete_Or_Private_Type
(Rec_Type
) then
2329 Rec_Type
:= Underlying_Type
(Rec_Type
);
2332 -- If there are discriminants, build the discriminant map to replace
2333 -- discriminants by their discriminals in complex bound expressions.
2334 -- These only arise for the corresponding records of protected types.
2336 if Is_Concurrent_Record_Type
(Rec_Type
)
2337 and then Has_Discriminants
(Rec_Type
)
2343 Disc
:= First_Discriminant
(Rec_Type
);
2345 while Present
(Disc
) loop
2346 Append_Elmt
(Disc
, Discr_Map
);
2347 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
2348 Next_Discriminant
(Disc
);
2353 -- Derived types that have no type extension can use the initialization
2354 -- procedure of their parent and do not need a procedure of their own.
2355 -- This is only correct if there are no representation clauses for the
2356 -- type or its parent, and if the parent has in fact been frozen so
2357 -- that its initialization procedure exists.
2359 if Is_Derived_Type
(Rec_Type
)
2360 and then not Is_Tagged_Type
(Rec_Type
)
2361 and then not Has_New_Non_Standard_Rep
(Rec_Type
)
2362 and then not Parent_Subtype_Renaming_Discrims
2363 and then Has_Non_Null_Base_Init_Proc
(Etype
(Rec_Type
))
2365 Copy_TSS
(Base_Init_Proc
(Etype
(Rec_Type
)), Rec_Type
);
2367 -- Otherwise if we need an initialization procedure, then build one,
2368 -- mark it as public and inlinable and as having a completion.
2370 elsif Requires_Init_Proc
(Rec_Type
) then
2371 Build_Init_Procedure
;
2372 Set_Is_Public
(Proc_Id
, Is_Public
(Pe
));
2374 -- The initialization of protected records is not worth inlining.
2375 -- In addition, when compiled for another unit for inlining purposes,
2376 -- it may make reference to entities that have not been elaborated
2377 -- yet. The initialization of controlled records contains a nested
2378 -- clean-up procedure that makes it impractical to inline as well,
2379 -- and leads to undefined symbols if inlined in a different unit.
2380 -- Similar considerations apply to task types.
2382 if not Is_Concurrent_Type
(Rec_Type
)
2383 and then not Has_Task
(Rec_Type
)
2384 and then not Controlled_Type
(Rec_Type
)
2386 Set_Is_Inlined
(Proc_Id
);
2389 Set_Is_Internal
(Proc_Id
);
2390 Set_Has_Completion
(Proc_Id
);
2392 if not Debug_Generated_Code
then
2393 Set_Debug_Info_Off
(Proc_Id
);
2396 end Build_Record_Init_Proc
;
2398 ------------------------------------
2399 -- Build_Variant_Record_Equality --
2400 ------------------------------------
2404 -- function _Equality (X, Y : T) return Boolean is
2406 -- -- Compare discriminants
2408 -- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then
2412 -- -- Compare components
2414 -- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then
2418 -- -- Compare variant part
2422 -- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then
2427 -- if False or else X.Cn /= Y.Cn then
2434 procedure Build_Variant_Record_Equality
(Typ
: Entity_Id
) is
2435 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2436 F
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
2438 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_X
);
2439 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_Y
);
2440 Def
: constant Node_Id
:= Parent
(Typ
);
2441 Comps
: constant Node_Id
:= Component_List
(Type_Definition
(Def
));
2443 Function_Body
: Node_Id
;
2444 Stmts
: List_Id
:= New_List
;
2447 if Is_Derived_Type
(Typ
)
2448 and then not Has_New_Non_Standard_Rep
(Typ
)
2451 Parent_Eq
: Entity_Id
:= TSS
(Root_Type
(Typ
), Name_uEquality
);
2454 if Present
(Parent_Eq
) then
2455 Copy_TSS
(Parent_Eq
, Typ
);
2462 Make_Subprogram_Body
(Loc
,
2464 Make_Function_Specification
(Loc
,
2465 Defining_Unit_Name
=> F
,
2466 Parameter_Specifications
=> New_List
(
2467 Make_Parameter_Specification
(Loc
,
2468 Defining_Identifier
=> X
,
2469 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
2471 Make_Parameter_Specification
(Loc
,
2472 Defining_Identifier
=> Y
,
2473 Parameter_Type
=> New_Reference_To
(Typ
, Loc
))),
2475 Subtype_Mark
=> New_Reference_To
(Standard_Boolean
, Loc
)),
2477 Declarations
=> New_List
,
2478 Handled_Statement_Sequence
=>
2479 Make_Handled_Sequence_Of_Statements
(Loc
,
2480 Statements
=> Stmts
));
2482 -- For unchecked union case, raise program error. This will only
2483 -- happen in the case of dynamic dispatching for a tagged type,
2484 -- since in the static cases it is a compile time error.
2486 if Has_Unchecked_Union
(Typ
) then
2488 Make_Raise_Program_Error
(Loc
,
2489 Reason
=> PE_Unchecked_Union_Restriction
));
2493 Discriminant_Specifications
(Def
)));
2494 Append_List_To
(Stmts
,
2495 Make_Eq_Case
(Typ
, Comps
));
2499 Make_Return_Statement
(Loc
,
2500 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
2505 if not Debug_Generated_Code
then
2506 Set_Debug_Info_Off
(F
);
2508 end Build_Variant_Record_Equality
;
2510 -----------------------------
2511 -- Check_Stream_Attributes --
2512 -----------------------------
2514 procedure Check_Stream_Attributes
(Typ
: Entity_Id
) is
2516 Par
: constant Entity_Id
:= Root_Type
(Base_Type
(Typ
));
2517 Par_Read
: Boolean := Present
(TSS
(Par
, Name_uRead
));
2518 Par_Write
: Boolean := Present
(TSS
(Par
, Name_uWrite
));
2521 if Par_Read
or else Par_Write
then
2522 Comp
:= First_Component
(Typ
);
2523 while Present
(Comp
) loop
2524 if Comes_From_Source
(Comp
)
2525 and then Original_Record_Component
(Comp
) = Comp
2526 and then Is_Limited_Type
(Etype
(Comp
))
2528 if (Par_Read
and then
2529 No
(TSS
(Base_Type
(Etype
(Comp
)), Name_uRead
)))
2532 No
(TSS
(Base_Type
(Etype
(Comp
)), Name_uWrite
)))
2535 ("|component must have Stream attribute",
2540 Next_Component
(Comp
);
2543 end Check_Stream_Attributes
;
2545 ---------------------------
2546 -- Expand_Derived_Record --
2547 ---------------------------
2549 -- Add a field _parent at the beginning of the record extension. This is
2550 -- used to implement inheritance. Here are some examples of expansion:
2552 -- 1. no discriminants
2553 -- type T2 is new T1 with null record;
2555 -- type T2 is new T1 with record
2559 -- 2. renamed discriminants
2560 -- type T2 (B, C : Int) is new T1 (A => B) with record
2561 -- _Parent : T1 (A => B);
2565 -- 3. inherited discriminants
2566 -- type T2 is new T1 with record -- discriminant A inherited
2567 -- _Parent : T1 (A);
2571 procedure Expand_Derived_Record
(T
: Entity_Id
; Def
: Node_Id
) is
2572 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
2573 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2574 Rec_Ext_Part
: Node_Id
:= Record_Extension_Part
(Def
);
2575 Par_Subtype
: Entity_Id
;
2576 Comp_List
: Node_Id
;
2577 Comp_Decl
: Node_Id
;
2580 List_Constr
: constant List_Id
:= New_List
;
2583 -- Expand_Tagged_Extension is called directly from the semantics, so
2584 -- we must check to see whether expansion is active before proceeding
2586 if not Expander_Active
then
2590 -- This may be a derivation of an untagged private type whose full
2591 -- view is tagged, in which case the Derived_Type_Definition has no
2592 -- extension part. Build an empty one now.
2594 if No
(Rec_Ext_Part
) then
2596 Make_Record_Definition
(Loc
,
2598 Component_List
=> Empty
,
2599 Null_Present
=> True);
2601 Set_Record_Extension_Part
(Def
, Rec_Ext_Part
);
2602 Mark_Rewrite_Insertion
(Rec_Ext_Part
);
2605 Comp_List
:= Component_List
(Rec_Ext_Part
);
2607 Parent_N
:= Make_Defining_Identifier
(Loc
, Name_uParent
);
2609 -- If the derived type inherits its discriminants the type of the
2610 -- _parent field must be constrained by the inherited discriminants
2612 if Has_Discriminants
(T
)
2613 and then Nkind
(Indic
) /= N_Subtype_Indication
2614 and then not Is_Constrained
(Entity
(Indic
))
2616 D
:= First_Discriminant
(T
);
2617 while (Present
(D
)) loop
2618 Append_To
(List_Constr
, New_Occurrence_Of
(D
, Loc
));
2619 Next_Discriminant
(D
);
2624 Make_Subtype_Indication
(Loc
,
2625 Subtype_Mark
=> New_Reference_To
(Entity
(Indic
), Loc
),
2627 Make_Index_Or_Discriminant_Constraint
(Loc
,
2628 Constraints
=> List_Constr
)),
2631 -- Otherwise the original subtype_indication is just what is needed
2634 Par_Subtype
:= Process_Subtype
(New_Copy_Tree
(Indic
), Def
);
2637 Set_Parent_Subtype
(T
, Par_Subtype
);
2640 Make_Component_Declaration
(Loc
,
2641 Defining_Identifier
=> Parent_N
,
2642 Subtype_Indication
=> New_Reference_To
(Par_Subtype
, Loc
));
2644 if Null_Present
(Rec_Ext_Part
) then
2645 Set_Component_List
(Rec_Ext_Part
,
2646 Make_Component_List
(Loc
,
2647 Component_Items
=> New_List
(Comp_Decl
),
2648 Variant_Part
=> Empty
,
2649 Null_Present
=> False));
2650 Set_Null_Present
(Rec_Ext_Part
, False);
2652 elsif Null_Present
(Comp_List
)
2653 or else Is_Empty_List
(Component_Items
(Comp_List
))
2655 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
2656 Set_Null_Present
(Comp_List
, False);
2659 Insert_Before
(First
(Component_Items
(Comp_List
)), Comp_Decl
);
2662 Analyze
(Comp_Decl
);
2663 end Expand_Derived_Record
;
2665 ------------------------------------
2666 -- Expand_N_Full_Type_Declaration --
2667 ------------------------------------
2669 procedure Expand_N_Full_Type_Declaration
(N
: Node_Id
) is
2670 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2671 B_Id
: Entity_Id
:= Base_Type
(Def_Id
);
2676 if Is_Access_Type
(Def_Id
) then
2678 -- Anonymous access types are created for the components of the
2679 -- record parameter for an entry declaration. No master is created
2682 if Has_Task
(Designated_Type
(Def_Id
))
2683 and then Comes_From_Source
(N
)
2685 Build_Master_Entity
(Def_Id
);
2686 Build_Master_Renaming
(Parent
(Def_Id
), Def_Id
);
2688 -- Create a class-wide master because a Master_Id must be generated
2689 -- for access-to-limited-class-wide types, whose root may be extended
2690 -- with task components.
2692 elsif Is_Class_Wide_Type
(Designated_Type
(Def_Id
))
2693 and then Is_Limited_Type
(Designated_Type
(Def_Id
))
2694 and then Tasking_Allowed
2696 -- Don't create a class-wide master for types whose convention is
2697 -- Java since these types cannot embed Ada tasks anyway. Note that
2698 -- the following test cannot catch the following case:
2700 -- package java.lang.Object is
2701 -- type Typ is tagged limited private;
2702 -- type Ref is access all Typ'Class;
2704 -- type Typ is tagged limited ...;
2705 -- pragma Convention (Typ, Java)
2708 -- Because the convention appears after we have done the
2709 -- processing for type Ref.
2711 and then Convention
(Designated_Type
(Def_Id
)) /= Convention_Java
2713 Build_Class_Wide_Master
(Def_Id
);
2715 elsif Ekind
(Def_Id
) = E_Access_Protected_Subprogram_Type
then
2716 Expand_Access_Protected_Subprogram_Type
(N
);
2719 elsif Has_Task
(Def_Id
) then
2720 Expand_Previous_Access_Type
(Def_Id
);
2723 Par_Id
:= Etype
(B_Id
);
2725 -- The parent type is private then we need to inherit
2726 -- any TSS operations from the full view.
2728 if Ekind
(Par_Id
) in Private_Kind
2729 and then Present
(Full_View
(Par_Id
))
2731 Par_Id
:= Base_Type
(Full_View
(Par_Id
));
2734 if Nkind
(Type_Definition
(Original_Node
(N
)))
2735 = N_Derived_Type_Definition
2736 and then not Is_Tagged_Type
(Def_Id
)
2737 and then Present
(Freeze_Node
(Par_Id
))
2738 and then Present
(TSS_Elist
(Freeze_Node
(Par_Id
)))
2740 Ensure_Freeze_Node
(B_Id
);
2741 FN
:= Freeze_Node
(B_Id
);
2743 if No
(TSS_Elist
(FN
)) then
2744 Set_TSS_Elist
(FN
, New_Elmt_List
);
2748 T_E
: Elist_Id
:= TSS_Elist
(FN
);
2752 Elmt
:= First_Elmt
(TSS_Elist
(Freeze_Node
(Par_Id
)));
2754 while Present
(Elmt
) loop
2755 if Chars
(Node
(Elmt
)) /= Name_uInit
then
2756 Append_Elmt
(Node
(Elmt
), T_E
);
2762 -- If the derived type itself is private with a full view,
2763 -- then associate the full view with the inherited TSS_Elist
2766 if Ekind
(B_Id
) in Private_Kind
2767 and then Present
(Full_View
(B_Id
))
2769 Ensure_Freeze_Node
(Base_Type
(Full_View
(B_Id
)));
2771 (Freeze_Node
(Base_Type
(Full_View
(B_Id
))), TSS_Elist
(FN
));
2775 end Expand_N_Full_Type_Declaration
;
2777 ---------------------------------
2778 -- Expand_N_Object_Declaration --
2779 ---------------------------------
2781 -- First we do special processing for objects of a tagged type where this
2782 -- is the point at which the type is frozen. The creation of the dispatch
2783 -- table and the initialization procedure have to be deferred to this
2784 -- point, since we reference previously declared primitive subprograms.
2786 -- For all types, we call an initialization procedure if there is one
2788 procedure Expand_N_Object_Declaration
(N
: Node_Id
) is
2789 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2790 Typ
: constant Entity_Id
:= Etype
(Def_Id
);
2791 Loc
: constant Source_Ptr
:= Sloc
(N
);
2792 Expr
: Node_Id
:= Expression
(N
);
2798 -- If we have a task type in no run time mode, then complain and ignore
2801 and then not Restricted_Profile
2802 and then Is_Task_Type
(Typ
)
2804 Disallow_In_No_Run_Time_Mode
(N
);
2807 -- Don't do anything for deferred constants. All proper actions will
2808 -- be expanded during the redeclaration.
2810 elsif No
(Expr
) and Constant_Present
(N
) then
2814 -- Make shared memory routines for shared passive variable
2816 if Is_Shared_Passive
(Def_Id
) then
2817 Make_Shared_Var_Procs
(N
);
2820 -- If tasks being declared, make sure we have an activation chain
2821 -- defined for the tasks (has no effect if we already have one), and
2822 -- also that a Master variable is established and that the appropriate
2823 -- enclosing construct is established as a task master.
2825 if Has_Task
(Typ
) then
2826 Build_Activation_Chain_Entity
(N
);
2827 Build_Master_Entity
(Def_Id
);
2830 -- Default initialization required, and no expression present
2834 -- Expand Initialize call for controlled objects. One may wonder why
2835 -- the Initialize Call is not done in the regular Init procedure
2836 -- attached to the record type. That's because the init procedure is
2837 -- recursively called on each component, including _Parent, thus the
2838 -- Init call for a controlled object would generate not only one
2839 -- Initialize call as it is required but one for each ancestor of
2840 -- its type. This processing is suppressed if No_Initialization set.
2842 if not Controlled_Type
(Typ
)
2843 or else No_Initialization
(N
)
2847 elsif not Abort_Allowed
2848 or else not Comes_From_Source
(N
)
2850 Insert_Actions_After
(N
,
2852 Ref
=> New_Occurrence_Of
(Def_Id
, Loc
),
2853 Typ
=> Base_Type
(Typ
),
2854 Flist_Ref
=> Find_Final_List
(Def_Id
),
2855 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
2860 -- We need to protect the initialize call
2864 -- Initialize (...);
2866 -- Undefer_Abort.all;
2869 -- ??? this won't protect the initialize call for controlled
2870 -- components which are part of the init proc, so this block
2871 -- should probably also contain the call to _init_proc but this
2872 -- requires some code reorganization...
2875 L
: constant List_Id
:=
2877 Ref
=> New_Occurrence_Of
(Def_Id
, Loc
),
2878 Typ
=> Base_Type
(Typ
),
2879 Flist_Ref
=> Find_Final_List
(Def_Id
),
2880 With_Attach
=> Make_Integer_Literal
(Loc
, 1));
2882 Blk
: constant Node_Id
:=
2883 Make_Block_Statement
(Loc
,
2884 Handled_Statement_Sequence
=>
2885 Make_Handled_Sequence_Of_Statements
(Loc
, L
));
2888 Prepend_To
(L
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
2889 Set_At_End_Proc
(Handled_Statement_Sequence
(Blk
),
2890 New_Occurrence_Of
(RTE
(RE_Abort_Undefer_Direct
), Loc
));
2891 Insert_Actions_After
(N
, New_List
(Blk
));
2892 Expand_At_End_Handler
2893 (Handled_Statement_Sequence
(Blk
), Entity
(Identifier
(Blk
)));
2897 -- Call type initialization procedure if there is one. We build the
2898 -- call and put it immediately after the object declaration, so that
2899 -- it will be expanded in the usual manner. Note that this will
2900 -- result in proper handling of defaulted discriminants. The call
2901 -- to the Init_Proc is suppressed if No_Initialization is set.
2903 if Has_Non_Null_Base_Init_Proc
(Typ
)
2904 and then not No_Initialization
(N
)
2906 -- The call to the initialization procedure does NOT freeze
2907 -- the object being initialized. This is because the call is
2908 -- not a source level call. This works fine, because the only
2909 -- possible statements depending on freeze status that can
2910 -- appear after the _Init call are rep clauses which can
2911 -- safely appear after actual references to the object.
2913 Id_Ref
:= New_Reference_To
(Def_Id
, Loc
);
2914 Set_Must_Not_Freeze
(Id_Ref
);
2915 Set_Assignment_OK
(Id_Ref
);
2917 Insert_Actions_After
(N
,
2918 Build_Initialization_Call
(Loc
, Id_Ref
, Typ
));
2920 -- The initialization call may well set Not_Source_Assigned
2921 -- to False, because it looks like an modification, but the
2922 -- proper criterion is whether or not the type is at least
2923 -- partially initialized, so reset the flag appropriately.
2925 Set_Not_Source_Assigned
2926 (Def_Id
, not Is_Partially_Initialized_Type
(Typ
));
2928 -- If simple initialization is required, then set an appropriate
2929 -- simple initialization expression in place. This special
2930 -- initialization is required even though No_Init_Flag is present.
2932 elsif Needs_Simple_Initialization
(Typ
) then
2933 Set_No_Initialization
(N
, False);
2934 Set_Expression
(N
, Get_Simple_Init_Val
(Typ
, Loc
));
2935 Analyze_And_Resolve
(Expression
(N
), Typ
);
2938 -- Explicit initialization present
2941 -- Obtain actual expression from qualified expression
2943 if Nkind
(Expr
) = N_Qualified_Expression
then
2944 Expr_Q
:= Expression
(Expr
);
2949 -- When we have the appropriate type of aggregate in the
2950 -- expression (it has been determined during analysis of the
2951 -- aggregate by setting the delay flag), let's perform in
2952 -- place assignment and thus avoid creating a temporay.
2954 if Is_Delayed_Aggregate
(Expr_Q
) then
2955 Convert_Aggr_In_Object_Decl
(N
);
2958 -- In most cases, we must check that the initial value meets
2959 -- any constraint imposed by the declared type. However, there
2960 -- is one very important exception to this rule. If the entity
2961 -- has an unconstrained nominal subtype, then it acquired its
2962 -- constraints from the expression in the first place, and not
2963 -- only does this mean that the constraint check is not needed,
2964 -- but an attempt to perform the constraint check can
2965 -- cause order of elaboration problems.
2967 if not Is_Constr_Subt_For_U_Nominal
(Typ
) then
2969 -- If this is an allocator for an aggregate that has been
2970 -- allocated in place, delay checks until assignments are
2971 -- made, because the discriminants are not initialized.
2973 if Nkind
(Expr
) = N_Allocator
2974 and then No_Initialization
(Expr
)
2978 Apply_Constraint_Check
(Expr
, Typ
);
2982 -- If the type is controlled we attach the object to the final
2983 -- list and adjust the target after the copy. This
2985 if Controlled_Type
(Typ
) then
2991 -- Attach the result to a dummy final list which will never
2992 -- be finalized if Delay_Finalize_Attachis set. It is
2993 -- important to attach to a dummy final list rather than
2994 -- not attaching at all in order to reset the pointers
2995 -- coming from the initial value. Equivalent code exists
2996 -- in the sec-stack case in Exp_Ch4.Expand_N_Allocator.
2998 if Delay_Finalize_Attach
(N
) then
3000 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F'));
3002 Make_Object_Declaration
(Loc
,
3003 Defining_Identifier
=> F
,
3004 Object_Definition
=>
3005 New_Reference_To
(RTE
(RE_Finalizable_Ptr
), Loc
)));
3007 Flist
:= New_Reference_To
(F
, Loc
);
3010 Flist
:= Find_Final_List
(Def_Id
);
3013 Insert_Actions_After
(N
,
3015 Ref
=> New_Reference_To
(Def_Id
, Loc
),
3016 Typ
=> Base_Type
(Typ
),
3018 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
3022 -- For tagged types, when an init value is given, the tag has
3023 -- to be re-initialized separately in order to avoid the
3024 -- propagation of a wrong tag coming from a view conversion
3025 -- unless the type is class wide (in this case the tag comes
3026 -- from the init value). Suppress the tag assignment when
3027 -- Java_VM because JVM tags are represented implicitly
3028 -- in objects. Ditto for types that are CPP_CLASS.
3030 if Is_Tagged_Type
(Typ
)
3031 and then not Is_Class_Wide_Type
(Typ
)
3032 and then not Is_CPP_Class
(Typ
)
3033 and then not Java_VM
3035 -- The re-assignment of the tag has to be done even if
3036 -- the object is a constant
3039 Make_Selected_Component
(Loc
,
3040 Prefix
=> New_Reference_To
(Def_Id
, Loc
),
3042 New_Reference_To
(Tag_Component
(Typ
), Loc
));
3044 Set_Assignment_OK
(New_Ref
);
3047 Make_Assignment_Statement
(Loc
,
3050 Unchecked_Convert_To
(RTE
(RE_Tag
),
3052 (Access_Disp_Table
(Base_Type
(Typ
)), Loc
))));
3054 -- For discrete types, set the Is_Known_Valid flag if the
3055 -- initializing value is known to be valid.
3057 elsif Is_Discrete_Type
(Typ
)
3058 and then Expr_Known_Valid
(Expr
)
3060 Set_Is_Known_Valid
(Def_Id
);
3063 -- If validity checking on copies, validate initial expression
3065 if Validity_Checks_On
3066 and then Validity_Check_Copies
3068 Ensure_Valid
(Expr
);
3069 Set_Is_Known_Valid
(Def_Id
);
3074 -- For array type, check for size too large
3075 -- We really need this for record types too???
3077 if Is_Array_Type
(Typ
) then
3078 Apply_Array_Size_Check
(N
, Typ
);
3081 end Expand_N_Object_Declaration
;
3083 ---------------------------------
3084 -- Expand_N_Subtype_Indication --
3085 ---------------------------------
3087 -- Add a check on the range of the subtype. The static case is
3088 -- partially duplicated by Process_Range_Expr_In_Decl in Sem_Ch3,
3089 -- but we still need to check here for the static case in order to
3090 -- avoid generating extraneous expanded code.
3092 procedure Expand_N_Subtype_Indication
(N
: Node_Id
) is
3093 Ran
: Node_Id
:= Range_Expression
(Constraint
(N
));
3094 Typ
: Entity_Id
:= Entity
(Subtype_Mark
(N
));
3097 if Nkind
(Parent
(N
)) = N_Constrained_Array_Definition
or else
3098 Nkind
(Parent
(N
)) = N_Slice
3101 Apply_Range_Check
(Ran
, Typ
);
3103 end Expand_N_Subtype_Indication
;
3105 ---------------------------
3106 -- Expand_N_Variant_Part --
3107 ---------------------------
3109 -- If the last variant does not contain the Others choice, replace
3110 -- it with an N_Others_Choice node since Gigi always wants an Others.
3111 -- Note that we do not bother to call Analyze on the modified variant
3112 -- part, since it's only effect would be to compute the contents of
3113 -- the Others_Discrete_Choices node laboriously, and of course we
3114 -- already know the list of choices that corresponds to the others
3115 -- choice (it's the list we are replacing!)
3117 procedure Expand_N_Variant_Part
(N
: Node_Id
) is
3118 Last_Var
: constant Node_Id
:= Last_Non_Pragma
(Variants
(N
));
3119 Others_Node
: Node_Id
;
3122 if Nkind
(First
(Discrete_Choices
(Last_Var
))) /= N_Others_Choice
then
3123 Others_Node
:= Make_Others_Choice
(Sloc
(Last_Var
));
3124 Set_Others_Discrete_Choices
3125 (Others_Node
, Discrete_Choices
(Last_Var
));
3126 Set_Discrete_Choices
(Last_Var
, New_List
(Others_Node
));
3128 end Expand_N_Variant_Part
;
3130 ---------------------------------
3131 -- Expand_Previous_Access_Type --
3132 ---------------------------------
3134 procedure Expand_Previous_Access_Type
(Def_Id
: Entity_Id
) is
3135 T
: Entity_Id
:= First_Entity
(Current_Scope
);
3138 -- Find all access types declared in the current scope, whose
3139 -- designated type is Def_Id.
3141 while Present
(T
) loop
3142 if Is_Access_Type
(T
)
3143 and then Designated_Type
(T
) = Def_Id
3145 Build_Master_Entity
(Def_Id
);
3146 Build_Master_Renaming
(Parent
(Def_Id
), T
);
3151 end Expand_Previous_Access_Type
;
3153 ------------------------------
3154 -- Expand_Record_Controller --
3155 ------------------------------
3157 procedure Expand_Record_Controller
(T
: Entity_Id
) is
3158 Def
: Node_Id
:= Type_Definition
(Parent
(T
));
3159 Comp_List
: Node_Id
;
3160 Comp_Decl
: Node_Id
;
3162 First_Comp
: Node_Id
;
3163 Controller_Type
: Entity_Id
;
3167 if Nkind
(Def
) = N_Derived_Type_Definition
then
3168 Def
:= Record_Extension_Part
(Def
);
3171 if Null_Present
(Def
) then
3172 Set_Component_List
(Def
,
3173 Make_Component_List
(Sloc
(Def
),
3174 Component_Items
=> Empty_List
,
3175 Variant_Part
=> Empty
,
3176 Null_Present
=> True));
3179 Comp_List
:= Component_List
(Def
);
3181 if Null_Present
(Comp_List
)
3182 or else Is_Empty_List
(Component_Items
(Comp_List
))
3184 Loc
:= Sloc
(Comp_List
);
3186 Loc
:= Sloc
(First
(Component_Items
(Comp_List
)));
3189 if Is_Return_By_Reference_Type
(T
) then
3190 Controller_Type
:= RTE
(RE_Limited_Record_Controller
);
3192 Controller_Type
:= RTE
(RE_Record_Controller
);
3195 Ent
:= Make_Defining_Identifier
(Loc
, Name_uController
);
3198 Make_Component_Declaration
(Loc
,
3199 Defining_Identifier
=> Ent
,
3200 Subtype_Indication
=> New_Reference_To
(Controller_Type
, Loc
));
3202 if Null_Present
(Comp_List
)
3203 or else Is_Empty_List
(Component_Items
(Comp_List
))
3205 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
3206 Set_Null_Present
(Comp_List
, False);
3209 -- The controller cannot be placed before the _Parent field
3210 -- since gigi lays out field in order and _parent must be
3211 -- first to preserve the polymorphism of tagged types.
3213 First_Comp
:= First
(Component_Items
(Comp_List
));
3215 if Chars
(Defining_Identifier
(First_Comp
)) /= Name_uParent
3216 and then Chars
(Defining_Identifier
(First_Comp
)) /= Name_uTag
3218 Insert_Before
(First_Comp
, Comp_Decl
);
3220 Insert_After
(First_Comp
, Comp_Decl
);
3225 Analyze
(Comp_Decl
);
3226 Set_Ekind
(Ent
, E_Component
);
3227 Init_Component_Location
(Ent
);
3229 -- Move the _controller entity ahead in the list of internal
3230 -- entities of the enclosing record so that it is selected
3231 -- instead of a potentially inherited one.
3234 E
: Entity_Id
:= Last_Entity
(T
);
3238 pragma Assert
(Chars
(E
) = Name_uController
);
3240 Set_Next_Entity
(E
, First_Entity
(T
));
3241 Set_First_Entity
(T
, E
);
3243 Comp
:= Next_Entity
(E
);
3244 while Next_Entity
(Comp
) /= E
loop
3248 Set_Next_Entity
(Comp
, Empty
);
3249 Set_Last_Entity
(T
, Comp
);
3253 end Expand_Record_Controller
;
3255 ------------------------
3256 -- Expand_Tagged_Root --
3257 ------------------------
3259 procedure Expand_Tagged_Root
(T
: Entity_Id
) is
3260 Def
: constant Node_Id
:= Type_Definition
(Parent
(T
));
3261 Comp_List
: Node_Id
;
3262 Comp_Decl
: Node_Id
;
3263 Sloc_N
: Source_Ptr
;
3266 if Null_Present
(Def
) then
3267 Set_Component_List
(Def
,
3268 Make_Component_List
(Sloc
(Def
),
3269 Component_Items
=> Empty_List
,
3270 Variant_Part
=> Empty
,
3271 Null_Present
=> True));
3274 Comp_List
:= Component_List
(Def
);
3276 if Null_Present
(Comp_List
)
3277 or else Is_Empty_List
(Component_Items
(Comp_List
))
3279 Sloc_N
:= Sloc
(Comp_List
);
3281 Sloc_N
:= Sloc
(First
(Component_Items
(Comp_List
)));
3285 Make_Component_Declaration
(Sloc_N
,
3286 Defining_Identifier
=> Tag_Component
(T
),
3287 Subtype_Indication
=>
3288 New_Reference_To
(RTE
(RE_Tag
), Sloc_N
));
3290 if Null_Present
(Comp_List
)
3291 or else Is_Empty_List
(Component_Items
(Comp_List
))
3293 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
3294 Set_Null_Present
(Comp_List
, False);
3297 Insert_Before
(First
(Component_Items
(Comp_List
)), Comp_Decl
);
3300 -- We don't Analyze the whole expansion because the tag component has
3301 -- already been analyzed previously. Here we just insure that the
3302 -- tree is coherent with the semantic decoration
3304 Find_Type
(Subtype_Indication
(Comp_Decl
));
3305 end Expand_Tagged_Root
;
3307 -----------------------
3308 -- Freeze_Array_Type --
3309 -----------------------
3311 procedure Freeze_Array_Type
(N
: Node_Id
) is
3312 Typ
: constant Entity_Id
:= Entity
(N
);
3313 Base
: constant Entity_Id
:= Base_Type
(Typ
);
3316 -- Nothing to do for packed case
3318 if not Is_Bit_Packed_Array
(Typ
) then
3320 -- If the component contains tasks, so does the array type.
3321 -- This may not be indicated in the array type because the
3322 -- component may have been a private type at the point of
3323 -- definition. Same if component type is controlled.
3325 Set_Has_Task
(Base
, Has_Task
(Component_Type
(Typ
)));
3326 Set_Has_Controlled_Component
(Base
,
3327 Has_Controlled_Component
(Component_Type
(Typ
))
3328 or else Is_Controlled
(Component_Type
(Typ
)));
3330 if No
(Init_Proc
(Base
)) then
3332 -- If this is an anonymous array created for a declaration
3333 -- with an initial value, its init_proc will never be called.
3334 -- The initial value itself may have been expanded into assign-
3335 -- ments, in which case the object declaration is carries the
3336 -- No_Initialization flag.
3339 and then Nkind
(Associated_Node_For_Itype
(Base
)) =
3340 N_Object_Declaration
3341 and then (Present
(Expression
(Associated_Node_For_Itype
(Base
)))
3343 No_Initialization
(Associated_Node_For_Itype
(Base
)))
3347 -- We do not need an init proc for string or wide string, since
3348 -- the only time these need initialization in normalize or
3349 -- initialize scalars mode, and these types are treated specially
3350 -- and do not need initialization procedures.
3352 elsif Base
= Standard_String
3353 or else Base
= Standard_Wide_String
3357 -- Otherwise we have to build an init proc for the subtype
3360 Build_Array_Init_Proc
(Base
, N
);
3364 if Typ
= Base
and then Has_Controlled_Component
(Base
) then
3365 Build_Controlling_Procs
(Base
);
3368 end Freeze_Array_Type
;
3370 -----------------------------
3371 -- Freeze_Enumeration_Type --
3372 -----------------------------
3374 procedure Freeze_Enumeration_Type
(N
: Node_Id
) is
3375 Loc
: constant Source_Ptr
:= Sloc
(N
);
3376 Typ
: constant Entity_Id
:= Entity
(N
);
3386 -- Build list of literal references
3391 Ent
:= First_Literal
(Typ
);
3392 while Present
(Ent
) loop
3393 Append_To
(Lst
, New_Reference_To
(Ent
, Sloc
(Ent
)));
3398 -- Now build an array declaration
3400 -- typA : array (Natural range 0 .. num - 1) of ctype :=
3401 -- (v, v, v, v, v, ....)
3403 -- where ctype is the corresponding integer type
3406 Make_Defining_Identifier
(Loc
,
3407 Chars
=> New_External_Name
(Chars
(Typ
), 'A'));
3409 Append_Freeze_Action
(Typ
,
3410 Make_Object_Declaration
(Loc
,
3411 Defining_Identifier
=> Arr
,
3412 Constant_Present
=> True,
3414 Object_Definition
=>
3415 Make_Constrained_Array_Definition
(Loc
,
3416 Discrete_Subtype_Definitions
=> New_List
(
3417 Make_Subtype_Indication
(Loc
,
3418 Subtype_Mark
=> New_Reference_To
(Standard_Natural
, Loc
),
3420 Make_Range_Constraint
(Loc
,
3424 Make_Integer_Literal
(Loc
, 0),
3426 Make_Integer_Literal
(Loc
, Num
- 1))))),
3428 Subtype_Indication
=> New_Reference_To
(Typ
, Loc
)),
3431 Make_Aggregate
(Loc
,
3432 Expressions
=> Lst
)));
3434 Set_Enum_Pos_To_Rep
(Typ
, Arr
);
3436 -- Now we build the function that converts representation values to
3437 -- position values. This function has the form:
3439 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
3442 -- when enum-lit'Enum_Rep => return posval;
3443 -- when enum-lit'Enum_Rep => return posval;
3446 -- [raise Program_Error when F]
3451 -- Note: the F parameter determines whether the others case (no valid
3452 -- representation) raises Program_Error or returns a unique value of
3453 -- minus one. The latter case is used, e.g. in 'Valid code.
3455 -- Note: the reason we use Enum_Rep values in the case here is to
3456 -- avoid the code generator making inappropriate assumptions about
3457 -- the range of the values in the case where the value is invalid.
3458 -- ityp is a signed or unsigned integer type of appropriate width.
3460 -- Note: in the case of No_Run_Time mode, where we cannot handle
3461 -- a program error in any case, we suppress the raise and just
3462 -- return -1 unconditionally (this is an erroneous program in any
3463 -- case and there is no obligation to raise Program_Error here!)
3464 -- We also do this if pragma Restrictions (No_Exceptions) is active.
3466 -- First build list of cases
3470 Ent
:= First_Literal
(Typ
);
3471 while Present
(Ent
) loop
3473 Make_Case_Statement_Alternative
(Loc
,
3474 Discrete_Choices
=> New_List
(
3475 Make_Integer_Literal
(Sloc
(Enumeration_Rep_Expr
(Ent
)),
3476 Intval
=> Enumeration_Rep
(Ent
))),
3478 Statements
=> New_List
(
3479 Make_Return_Statement
(Loc
,
3481 Make_Integer_Literal
(Loc
,
3482 Intval
=> Enumeration_Pos
(Ent
))))));
3487 -- Representations are signed
3489 if Enumeration_Rep
(First_Literal
(Typ
)) < 0 then
3490 if Esize
(Typ
) <= Standard_Integer_Size
then
3491 Ityp
:= Standard_Integer
;
3493 Ityp
:= Universal_Integer
;
3496 -- Representations are unsigned
3499 if Esize
(Typ
) <= Standard_Integer_Size
then
3500 Ityp
:= RTE
(RE_Unsigned
);
3502 Ityp
:= RTE
(RE_Long_Long_Unsigned
);
3506 -- In normal mode, add the others clause with the test
3508 if not (No_Run_Time
or Restrictions
(No_Exceptions
)) then
3510 Make_Case_Statement_Alternative
(Loc
,
3511 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
3512 Statements
=> New_List
(
3513 Make_Raise_Program_Error
(Loc
,
3514 Condition
=> Make_Identifier
(Loc
, Name_uF
),
3515 Reason
=> PE_Invalid_Data
),
3516 Make_Return_Statement
(Loc
,
3518 Make_Integer_Literal
(Loc
, -1)))));
3520 -- If No_Run_Time mode, unconditionally return -1. Same
3521 -- treatment if we have pragma Restrictions (No_Exceptions).
3525 Make_Case_Statement_Alternative
(Loc
,
3526 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
3527 Statements
=> New_List
(
3528 Make_Return_Statement
(Loc
,
3530 Make_Integer_Literal
(Loc
, -1)))));
3533 -- Now we can build the function body
3536 Make_Defining_Identifier
(Loc
, Name_uRep_To_Pos
);
3539 Make_Subprogram_Body
(Loc
,
3541 Make_Function_Specification
(Loc
,
3542 Defining_Unit_Name
=> Fent
,
3543 Parameter_Specifications
=> New_List
(
3544 Make_Parameter_Specification
(Loc
,
3545 Defining_Identifier
=>
3546 Make_Defining_Identifier
(Loc
, Name_uA
),
3547 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
3548 Make_Parameter_Specification
(Loc
,
3549 Defining_Identifier
=>
3550 Make_Defining_Identifier
(Loc
, Name_uF
),
3551 Parameter_Type
=> New_Reference_To
(Standard_Boolean
, Loc
))),
3553 Subtype_Mark
=> New_Reference_To
(Standard_Integer
, Loc
)),
3555 Declarations
=> Empty_List
,
3557 Handled_Statement_Sequence
=>
3558 Make_Handled_Sequence_Of_Statements
(Loc
,
3559 Statements
=> New_List
(
3560 Make_Case_Statement
(Loc
,
3562 Unchecked_Convert_To
(Ityp
,
3563 Make_Identifier
(Loc
, Name_uA
)),
3564 Alternatives
=> Lst
))));
3566 Set_TSS
(Typ
, Fent
);
3569 if not Debug_Generated_Code
then
3570 Set_Debug_Info_Off
(Fent
);
3572 end Freeze_Enumeration_Type
;
3574 ------------------------
3575 -- Freeze_Record_Type --
3576 ------------------------
3578 procedure Freeze_Record_Type
(N
: Node_Id
) is
3579 Def_Id
: constant Node_Id
:= Entity
(N
);
3581 Type_Decl
: constant Node_Id
:= Parent
(Def_Id
);
3582 Predef_List
: List_Id
;
3584 Renamed_Eq
: Node_Id
:= Empty
;
3585 -- Could use some comments ???
3588 -- Build discriminant checking functions if not a derived type (for
3589 -- derived types that are not tagged types, we always use the
3590 -- discriminant checking functions of the parent type). However, for
3591 -- untagged types the derivation may have taken place before the
3592 -- parent was frozen, so we copy explicitly the discriminant checking
3593 -- functions from the parent into the components of the derived type.
3595 if not Is_Derived_Type
(Def_Id
)
3596 or else Has_New_Non_Standard_Rep
(Def_Id
)
3597 or else Is_Tagged_Type
(Def_Id
)
3599 Build_Discr_Checking_Funcs
(Type_Decl
);
3601 elsif Is_Derived_Type
(Def_Id
)
3602 and then not Is_Tagged_Type
(Def_Id
)
3603 and then Has_Discriminants
(Def_Id
)
3606 Old_Comp
: Entity_Id
;
3610 First_Component
(Base_Type
(Underlying_Type
(Etype
(Def_Id
))));
3611 Comp
:= First_Component
(Def_Id
);
3613 while Present
(Comp
) loop
3614 if Ekind
(Comp
) = E_Component
3615 and then Chars
(Comp
) = Chars
(Old_Comp
)
3617 Set_Discriminant_Checking_Func
(Comp
,
3618 Discriminant_Checking_Func
(Old_Comp
));
3621 Next_Component
(Old_Comp
);
3622 Next_Component
(Comp
);
3627 if Is_Derived_Type
(Def_Id
)
3628 and then Is_Limited_Type
(Def_Id
)
3629 and then Is_Tagged_Type
(Def_Id
)
3631 Check_Stream_Attributes
(Def_Id
);
3634 -- Update task and controlled component flags, because some of the
3635 -- component types may have been private at the point of the record
3638 Comp
:= First_Component
(Def_Id
);
3640 while Present
(Comp
) loop
3641 if Has_Task
(Etype
(Comp
)) then
3642 Set_Has_Task
(Def_Id
);
3644 elsif Has_Controlled_Component
(Etype
(Comp
))
3645 or else (Chars
(Comp
) /= Name_uParent
3646 and then Is_Controlled
(Etype
(Comp
)))
3648 Set_Has_Controlled_Component
(Def_Id
);
3651 Next_Component
(Comp
);
3654 -- Creation of the Dispatch Table. Note that a Dispatch Table is
3655 -- created for regular tagged types as well as for Ada types
3656 -- deriving from a C++ Class, but not for tagged types directly
3657 -- corresponding to the C++ classes. In the later case we assume
3658 -- that the Vtable is created in the C++ side and we just use it.
3660 if Is_Tagged_Type
(Def_Id
) then
3662 if Is_CPP_Class
(Def_Id
) then
3663 Set_All_DT_Position
(Def_Id
);
3664 Set_Default_Constructor
(Def_Id
);
3667 -- Usually inherited primitives are not delayed but the first
3668 -- Ada extension of a CPP_Class is an exception since the
3669 -- address of the inherited subprogram has to be inserted in
3670 -- the new Ada Dispatch Table and this is a freezing action
3671 -- (usually the inherited primitive address is inserted in the
3672 -- DT by Inherit_DT)
3674 if Is_CPP_Class
(Etype
(Def_Id
)) then
3676 Elmt
: Elmt_Id
:= First_Elmt
(Primitive_Operations
(Def_Id
));
3680 while Present
(Elmt
) loop
3681 Subp
:= Node
(Elmt
);
3683 if Present
(Alias
(Subp
)) then
3684 Set_Has_Delayed_Freeze
(Subp
);
3692 if Underlying_Type
(Etype
(Def_Id
)) = Def_Id
then
3693 Expand_Tagged_Root
(Def_Id
);
3696 -- Unfreeze momentarily the type to add the predefined
3697 -- primitives operations. The reason we unfreeze is so
3698 -- that these predefined operations will indeed end up
3699 -- as primitive operations (which must be before the
3702 Set_Is_Frozen
(Def_Id
, False);
3703 Make_Predefined_Primitive_Specs
3704 (Def_Id
, Predef_List
, Renamed_Eq
);
3705 Insert_List_Before_And_Analyze
(N
, Predef_List
);
3706 Set_Is_Frozen
(Def_Id
, True);
3707 Set_All_DT_Position
(Def_Id
);
3709 -- Add the controlled component before the freezing actions
3710 -- it is referenced in those actions.
3712 if Has_New_Controlled_Component
(Def_Id
) then
3713 Expand_Record_Controller
(Def_Id
);
3716 -- Suppress creation of a dispatch table when Java_VM because
3717 -- the dispatching mechanism is handled internally by the JVM.
3720 Append_Freeze_Actions
(Def_Id
, Make_DT
(Def_Id
));
3723 -- Make sure that the primitives Initialize, Adjust and
3724 -- Finalize are Frozen before other TSS subprograms. We
3725 -- don't want them Frozen inside.
3727 if Is_Controlled
(Def_Id
) then
3728 if not Is_Limited_Type
(Def_Id
) then
3729 Append_Freeze_Actions
(Def_Id
,
3731 (Find_Prim_Op
(Def_Id
, Name_Adjust
), Sloc
(Def_Id
)));
3734 Append_Freeze_Actions
(Def_Id
,
3736 (Find_Prim_Op
(Def_Id
, Name_Initialize
), Sloc
(Def_Id
)));
3738 Append_Freeze_Actions
(Def_Id
,
3740 (Find_Prim_Op
(Def_Id
, Name_Finalize
), Sloc
(Def_Id
)));
3743 -- Freeze rest of primitive operations
3745 Append_Freeze_Actions
3746 (Def_Id
, Predefined_Primitive_Freeze
(Def_Id
));
3749 -- In the non-tagged case, an equality function is provided only
3750 -- for variant records (that are not unchecked unions).
3752 elsif Has_Discriminants
(Def_Id
)
3753 and then not Is_Limited_Type
(Def_Id
)
3756 Comps
: constant Node_Id
:=
3757 Component_List
(Type_Definition
(Type_Decl
));
3761 and then Present
(Variant_Part
(Comps
))
3762 and then not Is_Unchecked_Union
(Def_Id
)
3764 Build_Variant_Record_Equality
(Def_Id
);
3769 -- Before building the record initialization procedure, if we are
3770 -- dealing with a concurrent record value type, then we must go
3771 -- through the discriminants, exchanging discriminals between the
3772 -- concurrent type and the concurrent record value type. See the
3773 -- section "Handling of Discriminants" in the Einfo spec for details.
3775 if Is_Concurrent_Record_Type
(Def_Id
)
3776 and then Has_Discriminants
(Def_Id
)
3779 Ctyp
: constant Entity_Id
:=
3780 Corresponding_Concurrent_Type
(Def_Id
);
3781 Conc_Discr
: Entity_Id
;
3782 Rec_Discr
: Entity_Id
;
3786 Conc_Discr
:= First_Discriminant
(Ctyp
);
3787 Rec_Discr
:= First_Discriminant
(Def_Id
);
3789 while Present
(Conc_Discr
) loop
3790 Temp
:= Discriminal
(Conc_Discr
);
3791 Set_Discriminal
(Conc_Discr
, Discriminal
(Rec_Discr
));
3792 Set_Discriminal
(Rec_Discr
, Temp
);
3794 Set_Discriminal_Link
(Discriminal
(Conc_Discr
), Conc_Discr
);
3795 Set_Discriminal_Link
(Discriminal
(Rec_Discr
), Rec_Discr
);
3797 Next_Discriminant
(Conc_Discr
);
3798 Next_Discriminant
(Rec_Discr
);
3803 if Has_Controlled_Component
(Def_Id
) then
3804 if No
(Controller_Component
(Def_Id
)) then
3805 Expand_Record_Controller
(Def_Id
);
3808 Build_Controlling_Procs
(Def_Id
);
3811 Adjust_Discriminants
(Def_Id
);
3812 Build_Record_Init_Proc
(Type_Decl
, Def_Id
);
3814 -- For tagged type, build bodies of primitive operations. Note
3815 -- that we do this after building the record initialization
3816 -- experiment, since the primitive operations may need the
3817 -- initialization routine
3819 if Is_Tagged_Type
(Def_Id
) then
3820 Predef_List
:= Predefined_Primitive_Bodies
(Def_Id
, Renamed_Eq
);
3821 Append_Freeze_Actions
(Def_Id
, Predef_List
);
3824 end Freeze_Record_Type
;
3826 ------------------------------
3827 -- Freeze_Stream_Operations --
3828 ------------------------------
3830 procedure Freeze_Stream_Operations
(N
: Node_Id
; Typ
: Entity_Id
) is
3831 Names
: constant array (1 .. 4) of Name_Id
:=
3832 (Name_uInput
, Name_uOutput
, Name_uRead
, Name_uWrite
);
3833 Stream_Op
: Entity_Id
;
3836 -- Primitive operations of tagged types are frozen when the dispatch
3837 -- table is constructed.
3839 if not Comes_From_Source
(Typ
)
3840 or else Is_Tagged_Type
(Typ
)
3845 for J
in Names
'Range loop
3846 Stream_Op
:= TSS
(Typ
, Names
(J
));
3848 if Present
(Stream_Op
)
3849 and then Is_Subprogram
(Stream_Op
)
3850 and then Nkind
(Unit_Declaration_Node
(Stream_Op
)) =
3851 N_Subprogram_Declaration
3852 and then not Is_Frozen
(Stream_Op
)
3854 Append_Freeze_Actions
3855 (Typ
, Freeze_Entity
(Stream_Op
, Sloc
(N
)));
3858 end Freeze_Stream_Operations
;
3864 -- Full type declarations are expanded at the point at which the type
3865 -- is frozen. The formal N is the Freeze_Node for the type. Any statements
3866 -- or declarations generated by the freezing (e.g. the procedure generated
3867 -- for initialization) are chained in the Acions field list of the freeze
3868 -- node using Append_Freeze_Actions.
3870 procedure Freeze_Type
(N
: Node_Id
) is
3871 Def_Id
: constant Entity_Id
:= Entity
(N
);
3874 -- Process associated access types needing special processing
3876 if Present
(Access_Types_To_Process
(N
)) then
3878 E
: Elmt_Id
:= First_Elmt
(Access_Types_To_Process
(N
));
3880 while Present
(E
) loop
3882 -- If the access type is a RACW, call the expansion procedure
3883 -- for this remote pointer.
3885 if Is_Remote_Access_To_Class_Wide_Type
(Node
(E
)) then
3886 Remote_Types_Tagged_Full_View_Encountered
(Def_Id
);
3894 -- Freeze processing for record types
3896 if Is_Record_Type
(Def_Id
) then
3897 if Ekind
(Def_Id
) = E_Record_Type
then
3898 Freeze_Record_Type
(N
);
3900 -- The subtype may have been declared before the type was frozen.
3901 -- If the type has controlled components it is necessary to create
3902 -- the entity for the controller explicitly because it did not
3903 -- exist at the point of the subtype declaration. Only the entity is
3904 -- needed, the back-end will obtain the layout from the type.
3905 -- This is only necessary if this is constrained subtype whose
3906 -- component list is not shared with the base type.
3908 elsif Ekind
(Def_Id
) = E_Record_Subtype
3909 and then Has_Discriminants
(Def_Id
)
3910 and then Last_Entity
(Def_Id
) /= Last_Entity
(Base_Type
(Def_Id
))
3911 and then Present
(Controller_Component
(Def_Id
))
3914 Old_C
: Entity_Id
:= Controller_Component
(Def_Id
);
3918 if Scope
(Old_C
) = Base_Type
(Def_Id
) then
3920 -- The entity is the one in the parent. Create new one.
3922 New_C
:= New_Copy
(Old_C
);
3923 Set_Parent
(New_C
, Parent
(Old_C
));
3931 -- Freeze processing for array types
3933 elsif Is_Array_Type
(Def_Id
) then
3934 Freeze_Array_Type
(N
);
3936 -- Freeze processing for access types
3938 -- For pool-specific access types, find out the pool object used for
3939 -- this type, needs actual expansion of it in some cases. Here are the
3940 -- different cases :
3942 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;"
3943 -- ---> don't use any storage pool
3945 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr.
3947 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
3949 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
3950 -- ---> Storage Pool is the specified one
3952 -- See GNAT Pool packages in the Run-Time for more details
3954 elsif Ekind
(Def_Id
) = E_Access_Type
3955 or else Ekind
(Def_Id
) = E_General_Access_Type
3958 Loc
: constant Source_Ptr
:= Sloc
(N
);
3959 Desig_Type
: constant Entity_Id
:= Designated_Type
(Def_Id
);
3960 Pool_Object
: Entity_Id
;
3963 Freeze_Action_Typ
: Entity_Id
;
3966 if Has_Storage_Size_Clause
(Def_Id
) then
3967 Siz_Exp
:= Expression
(Parent
(Storage_Size_Variable
(Def_Id
)));
3974 -- Rep Clause "for Def_Id'Storage_Size use 0;"
3975 -- ---> don't use any storage pool
3977 if Has_Storage_Size_Clause
(Def_Id
)
3978 and then Compile_Time_Known_Value
(Siz_Exp
)
3979 and then Expr_Value
(Siz_Exp
) = 0
3985 -- Rep Clause : for Def_Id'Storage_Size use Expr.
3987 -- Def_Id__Pool : Stack_Bounded_Pool
3988 -- (Expr, DT'Size, DT'Alignment);
3990 elsif Has_Storage_Size_Clause
(Def_Id
) then
3996 -- For unconstrained composite types we give a size of
3997 -- zero so that the pool knows that it needs a special
3998 -- algorithm for variable size object allocation.
4000 if Is_Composite_Type
(Desig_Type
)
4001 and then not Is_Constrained
(Desig_Type
)
4004 Make_Integer_Literal
(Loc
, 0);
4007 Make_Integer_Literal
(Loc
, Maximum_Alignment
);
4011 Make_Attribute_Reference
(Loc
,
4012 Prefix
=> New_Reference_To
(Desig_Type
, Loc
),
4013 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
);
4016 Make_Attribute_Reference
(Loc
,
4017 Prefix
=> New_Reference_To
(Desig_Type
, Loc
),
4018 Attribute_Name
=> Name_Alignment
);
4022 Make_Defining_Identifier
(Loc
,
4023 Chars
=> New_External_Name
(Chars
(Def_Id
), 'P'));
4025 -- We put the code associated with the pools in the
4026 -- entity that has the later freeze node, usually the
4027 -- acces type but it can also be the designated_type;
4028 -- because the pool code requires both those types to be
4031 if Is_Frozen
(Desig_Type
)
4032 and then (not Present
(Freeze_Node
(Desig_Type
))
4033 or else Analyzed
(Freeze_Node
(Desig_Type
)))
4035 Freeze_Action_Typ
:= Def_Id
;
4037 -- A Taft amendment type cannot get the freeze actions
4038 -- since the full view is not there.
4040 elsif Is_Incomplete_Or_Private_Type
(Desig_Type
)
4041 and then No
(Full_View
(Desig_Type
))
4043 Freeze_Action_Typ
:= Def_Id
;
4046 Freeze_Action_Typ
:= Desig_Type
;
4049 Append_Freeze_Action
(Freeze_Action_Typ
,
4050 Make_Object_Declaration
(Loc
,
4051 Defining_Identifier
=> Pool_Object
,
4052 Object_Definition
=>
4053 Make_Subtype_Indication
(Loc
,
4056 (RTE
(RE_Stack_Bounded_Pool
), Loc
),
4059 Make_Index_Or_Discriminant_Constraint
(Loc
,
4060 Constraints
=> New_List
(
4062 -- First discriminant is the Pool Size
4065 Storage_Size_Variable
(Def_Id
), Loc
),
4067 -- Second discriminant is the element size
4071 -- Third discriminant is the alignment
4076 Set_Associated_Storage_Pool
(Def_Id
, Pool_Object
);
4080 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
4081 -- ---> Storage Pool is the specified one
4083 elsif Present
(Associated_Storage_Pool
(Def_Id
)) then
4085 -- Nothing to do the associated storage pool has been attached
4086 -- when analyzing the rep. clause
4091 -- For access-to-controlled types (including class-wide types
4092 -- and Taft-amendment types which potentially have controlled
4093 -- components), expand the list controller object that will
4094 -- store the dynamically allocated objects. Do not do this
4095 -- transformation for expander-generated access types, but do it
4096 -- for types that are the full view of types derived from other
4097 -- private types. Also suppress the list controller in the case
4098 -- of a designated type with convention Java, since this is used
4099 -- when binding to Java API specs, where there's no equivalent
4100 -- of a finalization list and we don't want to pull in the
4101 -- finalization support if not needed.
4103 if not Comes_From_Source
(Def_Id
)
4104 and then not Has_Private_Declaration
(Def_Id
)
4108 elsif (Controlled_Type
(Desig_Type
)
4109 and then Convention
(Desig_Type
) /= Convention_Java
)
4110 or else (Is_Incomplete_Or_Private_Type
(Desig_Type
)
4111 and then No
(Full_View
(Desig_Type
))
4113 -- An exception is made for types defined in the run-time
4114 -- because Ada.Tags.Tag itself is such a type and cannot
4115 -- afford this unnecessary overhead that would generates a
4116 -- loop in the expansion scheme...
4117 -- Similarly, if No_Run_Time is enabled, the designated type
4118 -- cannot be controlled.
4120 and then not In_Runtime
(Def_Id
)
4121 and then not No_Run_Time
)
4123 -- If the designated type is not frozen yet, its controlled
4124 -- status must be retrieved explicitly.
4126 or else (Is_Array_Type
(Desig_Type
)
4127 and then not Is_Frozen
(Desig_Type
)
4128 and then Controlled_Type
(Component_Type
(Desig_Type
)))
4130 Set_Associated_Final_Chain
(Def_Id
,
4131 Make_Defining_Identifier
(Loc
,
4132 New_External_Name
(Chars
(Def_Id
), 'L')));
4134 Append_Freeze_Action
(Def_Id
,
4135 Make_Object_Declaration
(Loc
,
4136 Defining_Identifier
=> Associated_Final_Chain
(Def_Id
),
4137 Object_Definition
=>
4138 New_Reference_To
(RTE
(RE_List_Controller
), Loc
)));
4142 -- Freeze processing for enumeration types
4144 elsif Ekind
(Def_Id
) = E_Enumeration_Type
then
4146 -- We only have something to do if we have a non-standard
4147 -- representation (i.e. at least one literal whose pos value
4148 -- is not the same as its representation)
4150 if Has_Non_Standard_Rep
(Def_Id
) then
4151 Freeze_Enumeration_Type
(N
);
4154 -- private types that are completed by a derivation from a private
4155 -- type have an internally generated full view, that needs to be
4156 -- frozen. This must be done explicitly because the two views share
4157 -- the freeze node, and the underlying full view is not visible when
4158 -- the freeze node is analyzed.
4160 elsif Is_Private_Type
(Def_Id
)
4161 and then Is_Derived_Type
(Def_Id
)
4162 and then Present
(Full_View
(Def_Id
))
4163 and then Is_Itype
(Full_View
(Def_Id
))
4164 and then Has_Private_Declaration
(Full_View
(Def_Id
))
4165 and then Freeze_Node
(Full_View
(Def_Id
)) = N
4167 Set_Entity
(N
, Full_View
(Def_Id
));
4169 Set_Entity
(N
, Def_Id
);
4171 -- All other types require no expander action. There are such
4172 -- cases (e.g. task types and protected types). In such cases,
4173 -- the freeze nodes are there for use by Gigi.
4177 Freeze_Stream_Operations
(N
, Def_Id
);
4180 -------------------------
4181 -- Get_Simple_Init_Val --
4182 -------------------------
4184 function Get_Simple_Init_Val
4195 -- For a private type, we should always have an underlying type
4196 -- (because this was already checked in Needs_Simple_Initialization).
4197 -- What we do is to get the value for the underlying type and then
4198 -- do an Unchecked_Convert to the private type.
4200 if Is_Private_Type
(T
) then
4201 Val
:= Get_Simple_Init_Val
(Underlying_Type
(T
), Loc
);
4203 -- A special case, if the underlying value is null, then qualify
4204 -- it with the underlying type, so that the null is properly typed
4205 -- Similarly, if it is an aggregate it must be qualified, because
4206 -- an unchecked conversion does not provide a context for it.
4208 if Nkind
(Val
) = N_Null
4209 or else Nkind
(Val
) = N_Aggregate
4212 Make_Qualified_Expression
(Loc
,
4214 New_Occurrence_Of
(Underlying_Type
(T
), Loc
),
4218 return Unchecked_Convert_To
(T
, Val
);
4220 -- For scalars, we must have normalize/initialize scalars case
4222 elsif Is_Scalar_Type
(T
) then
4223 pragma Assert
(Init_Or_Norm_Scalars
);
4225 -- Processing for Normalize_Scalars case
4227 if Normalize_Scalars
then
4229 -- First prepare a value (out of subtype range if possible)
4231 if Is_Real_Type
(T
) or else Is_Integer_Type
(T
) then
4233 Make_Attribute_Reference
(Loc
,
4234 Prefix
=> New_Occurrence_Of
(Base_Type
(T
), Loc
),
4235 Attribute_Name
=> Name_First
);
4237 elsif Is_Modular_Integer_Type
(T
) then
4239 Make_Attribute_Reference
(Loc
,
4240 Prefix
=> New_Occurrence_Of
(Base_Type
(T
), Loc
),
4241 Attribute_Name
=> Name_Last
);
4244 pragma Assert
(Is_Enumeration_Type
(T
));
4246 if Esize
(T
) <= 8 then
4247 Typ
:= RTE
(RE_Unsigned_8
);
4248 elsif Esize
(T
) <= 16 then
4249 Typ
:= RTE
(RE_Unsigned_16
);
4250 elsif Esize
(T
) <= 32 then
4251 Typ
:= RTE
(RE_Unsigned_32
);
4253 Typ
:= RTE
(RE_Unsigned_64
);
4257 Make_Attribute_Reference
(Loc
,
4258 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4259 Attribute_Name
=> Name_Last
);
4262 -- Here for Initialize_Scalars case
4265 if Is_Floating_Point_Type
(T
) then
4266 if Root_Type
(T
) = Standard_Short_Float
then
4267 Val_RE
:= RE_IS_Isf
;
4268 elsif Root_Type
(T
) = Standard_Float
then
4269 Val_RE
:= RE_IS_Ifl
;
4271 -- The form of the following test is quite deliberate, it
4272 -- catches the case of architectures (the most common case)
4273 -- where Long_Long_Float is the same as Long_Float, and in
4274 -- such cases initializes Long_Long_Float variables from the
4275 -- Long_Float constant (since the Long_Long_Float constant is
4276 -- only for use on the x86).
4278 elsif Esize
(Root_Type
(T
)) = Esize
(Standard_Long_Float
) then
4279 Val_RE
:= RE_IS_Ilf
;
4281 -- Otherwise we have extended real on an x86
4283 else pragma Assert
(Root_Type
(T
) = Standard_Long_Long_Float
);
4284 Val_RE
:= RE_IS_Ill
;
4287 elsif Is_Unsigned_Type
(Base_Type
(T
)) then
4288 if Esize
(T
) = 8 then
4289 Val_RE
:= RE_IS_Iu1
;
4290 elsif Esize
(T
) = 16 then
4291 Val_RE
:= RE_IS_Iu2
;
4292 elsif Esize
(T
) = 32 then
4293 Val_RE
:= RE_IS_Iu4
;
4294 else pragma Assert
(Esize
(T
) = 64);
4295 Val_RE
:= RE_IS_Iu8
;
4299 if Esize
(T
) = 8 then
4300 Val_RE
:= RE_IS_Is1
;
4301 elsif Esize
(T
) = 16 then
4302 Val_RE
:= RE_IS_Is2
;
4303 elsif Esize
(T
) = 32 then
4304 Val_RE
:= RE_IS_Is4
;
4305 else pragma Assert
(Esize
(T
) = 64);
4306 Val_RE
:= RE_IS_Is8
;
4310 Val
:= New_Occurrence_Of
(RTE
(Val_RE
), Loc
);
4313 -- The final expression is obtained by doing an unchecked
4314 -- conversion of this result to the base type of the
4315 -- required subtype. We use the base type to avoid the
4316 -- unchecked conversion from chopping bits, and then we
4317 -- set Kill_Range_Check to preserve the "bad" value.
4319 Result
:= Unchecked_Convert_To
(Base_Type
(T
), Val
);
4321 if Nkind
(Result
) = N_Unchecked_Type_Conversion
then
4322 Set_Kill_Range_Check
(Result
, True);
4327 -- String or Wide_String (must have Initialize_Scalars set)
4329 elsif Root_Type
(T
) = Standard_String
4331 Root_Type
(T
) = Standard_Wide_String
4333 pragma Assert
(Init_Or_Norm_Scalars
);
4336 Make_Aggregate
(Loc
,
4337 Component_Associations
=> New_List
(
4338 Make_Component_Association
(Loc
,
4339 Choices
=> New_List
(
4340 Make_Others_Choice
(Loc
)),
4342 Get_Simple_Init_Val
(Component_Type
(T
), Loc
))));
4344 -- Access type is initialized to null
4346 elsif Is_Access_Type
(T
) then
4350 -- We initialize modular packed bit arrays to zero, to make sure that
4351 -- unused bits are zero, as required (see spec of Exp_Pakd). Also note
4352 -- that this improves gigi code, since the value tracing knows that
4353 -- all bits of the variable start out at zero. The value of zero has
4354 -- to be unchecked converted to the proper array type.
4356 elsif Is_Bit_Packed_Array
(T
) then
4358 PAT
: constant Entity_Id
:= Packed_Array_Type
(T
);
4362 pragma Assert
(Is_Modular_Integer_Type
(PAT
));
4365 Make_Unchecked_Type_Conversion
(Loc
,
4366 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
4367 Expression
=> Make_Integer_Literal
(Loc
, 0));
4369 Set_Etype
(Expression
(Nod
), PAT
);
4373 -- No other possibilities should arise, since we should only be
4374 -- calling Get_Simple_Init_Val if Needs_Simple_Initialization
4375 -- returned True, indicating one of the above cases held.
4378 raise Program_Error
;
4380 end Get_Simple_Init_Val
;
4382 ------------------------------
4383 -- Has_New_Non_Standard_Rep --
4384 ------------------------------
4386 function Has_New_Non_Standard_Rep
(T
: Entity_Id
) return Boolean is
4388 if not Is_Derived_Type
(T
) then
4389 return Has_Non_Standard_Rep
(T
)
4390 or else Has_Non_Standard_Rep
(Root_Type
(T
));
4392 -- If Has_Non_Standard_Rep is not set on the derived type, the
4393 -- representation is fully inherited.
4395 elsif not Has_Non_Standard_Rep
(T
) then
4399 return First_Rep_Item
(T
) /= First_Rep_Item
(Root_Type
(T
));
4401 -- May need a more precise check here: the First_Rep_Item may
4402 -- be a stream attribute, which does not affect the representation
4405 end Has_New_Non_Standard_Rep
;
4411 function In_Runtime
(E
: Entity_Id
) return Boolean is
4412 S1
: Entity_Id
:= Scope
(E
);
4415 while Scope
(S1
) /= Standard_Standard
loop
4419 return Chars
(S1
) = Name_System
or else Chars
(S1
) = Name_Ada
;
4426 function Init_Formals
(Typ
: Entity_Id
) return List_Id
is
4427 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
4431 -- First parameter is always _Init : in out typ. Note that we need
4432 -- this to be in/out because in the case of the task record value,
4433 -- there are default record fields (_Priority, _Size, -Task_Info)
4434 -- that may be referenced in the generated initialization routine.
4436 Formals
:= New_List
(
4437 Make_Parameter_Specification
(Loc
,
4438 Defining_Identifier
=>
4439 Make_Defining_Identifier
(Loc
, Name_uInit
),
4441 Out_Present
=> True,
4442 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
4444 -- For task record value, or type that contains tasks, add two more
4445 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain
4446 -- We also add these parameters for the task record type case.
4449 or else (Is_Record_Type
(Typ
) and then Is_Task_Record_Type
(Typ
))
4452 Make_Parameter_Specification
(Loc
,
4453 Defining_Identifier
=>
4454 Make_Defining_Identifier
(Loc
, Name_uMaster
),
4455 Parameter_Type
=> New_Reference_To
(RTE
(RE_Master_Id
), Loc
)));
4458 Make_Parameter_Specification
(Loc
,
4459 Defining_Identifier
=>
4460 Make_Defining_Identifier
(Loc
, Name_uChain
),
4462 Out_Present
=> True,
4464 New_Reference_To
(RTE
(RE_Activation_Chain
), Loc
)));
4467 Make_Parameter_Specification
(Loc
,
4468 Defining_Identifier
=>
4469 Make_Defining_Identifier
(Loc
, Name_uTask_Id
),
4472 New_Reference_To
(RTE
(RE_Task_Image_Type
), Loc
)));
4482 -- <Make_Eq_if shared components>
4484 -- when V1 => <Make_Eq_Case> on subcomponents
4486 -- when Vn => <Make_Eq_Case> on subcomponents
4489 function Make_Eq_Case
(Node
: Node_Id
; CL
: Node_Id
) return List_Id
is
4490 Loc
: constant Source_Ptr
:= Sloc
(Node
);
4493 Result
: List_Id
:= New_List
;
4496 Append_To
(Result
, Make_Eq_If
(Node
, Component_Items
(CL
)));
4498 if No
(Variant_Part
(CL
)) then
4502 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(CL
)));
4504 if No
(Variant
) then
4508 Alt_List
:= New_List
;
4510 while Present
(Variant
) loop
4511 Append_To
(Alt_List
,
4512 Make_Case_Statement_Alternative
(Loc
,
4513 Discrete_Choices
=> New_Copy_List
(Discrete_Choices
(Variant
)),
4514 Statements
=> Make_Eq_Case
(Node
, Component_List
(Variant
))));
4516 Next_Non_Pragma
(Variant
);
4520 Make_Case_Statement
(Loc
,
4522 Make_Selected_Component
(Loc
,
4523 Prefix
=> Make_Identifier
(Loc
, Name_X
),
4524 Selector_Name
=> New_Copy
(Name
(Variant_Part
(CL
)))),
4525 Alternatives
=> Alt_List
));
4545 -- or a null statement if the list L is empty
4547 function Make_Eq_If
(Node
: Node_Id
; L
: List_Id
) return Node_Id
is
4548 Loc
: constant Source_Ptr
:= Sloc
(Node
);
4550 Field_Name
: Name_Id
;
4555 return Make_Null_Statement
(Loc
);
4560 C
:= First_Non_Pragma
(L
);
4561 while Present
(C
) loop
4562 Field_Name
:= Chars
(Defining_Identifier
(C
));
4564 -- The tags must not be compared they are not part of the value.
4565 -- Note also that in the following, we use Make_Identifier for
4566 -- the component names. Use of New_Reference_To to identify the
4567 -- components would be incorrect because the wrong entities for
4568 -- discriminants could be picked up in the private type case.
4570 if Field_Name
/= Name_uTag
then
4571 Evolve_Or_Else
(Cond
,
4574 Make_Selected_Component
(Loc
,
4575 Prefix
=> Make_Identifier
(Loc
, Name_X
),
4577 Make_Identifier
(Loc
, Field_Name
)),
4580 Make_Selected_Component
(Loc
,
4581 Prefix
=> Make_Identifier
(Loc
, Name_Y
),
4583 Make_Identifier
(Loc
, Field_Name
))));
4586 Next_Non_Pragma
(C
);
4590 return Make_Null_Statement
(Loc
);
4594 Make_Implicit_If_Statement
(Node
,
4596 Then_Statements
=> New_List
(
4597 Make_Return_Statement
(Loc
,
4598 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
4603 -------------------------------------
4604 -- Make_Predefined_Primitive_Specs --
4605 -------------------------------------
4607 procedure Make_Predefined_Primitive_Specs
4608 (Tag_Typ
: Entity_Id
;
4609 Predef_List
: out List_Id
;
4610 Renamed_Eq
: out Node_Id
)
4612 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
4613 Res
: List_Id
:= New_List
;
4615 Eq_Needed
: Boolean;
4617 Eq_Name
: Name_Id
:= Name_Op_Eq
;
4619 function Is_Predefined_Eq_Renaming
(Prim
: Node_Id
) return Boolean;
4620 -- Returns true if Prim is a renaming of an unresolved predefined
4621 -- equality operation.
4623 function Is_Predefined_Eq_Renaming
(Prim
: Node_Id
) return Boolean is
4625 return Chars
(Prim
) /= Name_Op_Eq
4626 and then Present
(Alias
(Prim
))
4627 and then Comes_From_Source
(Prim
)
4628 and then Is_Intrinsic_Subprogram
(Alias
(Prim
))
4629 and then Chars
(Alias
(Prim
)) = Name_Op_Eq
;
4630 end Is_Predefined_Eq_Renaming
;
4632 -- Start of processing for Make_Predefined_Primitive_Specs
4635 Renamed_Eq
:= Empty
;
4639 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
4642 Profile
=> New_List
(
4643 Make_Parameter_Specification
(Loc
,
4644 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
4645 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
4647 Ret_Type
=> Standard_Long_Long_Integer
));
4649 -- Specs for dispatching stream attributes. We skip these for limited
4650 -- types, since there is no question of dispatching in the limited case.
4652 -- We also skip these operations in No_Run_Time mode, where
4653 -- dispatching stream operations cannot be used (this is currently
4654 -- a No_Run_Time restriction).
4656 if not (No_Run_Time
or else Is_Limited_Type
(Tag_Typ
)) then
4657 Append_To
(Res
, Predef_Stream_Attr_Spec
(Loc
, Tag_Typ
, Name_uRead
));
4658 Append_To
(Res
, Predef_Stream_Attr_Spec
(Loc
, Tag_Typ
, Name_uWrite
));
4659 Append_To
(Res
, Predef_Stream_Attr_Spec
(Loc
, Tag_Typ
, Name_uInput
));
4660 Append_To
(Res
, Predef_Stream_Attr_Spec
(Loc
, Tag_Typ
, Name_uOutput
));
4663 if not Is_Limited_Type
(Tag_Typ
) then
4665 -- Spec of "=" if expanded if the type is not limited and if a
4666 -- user defined "=" was not already declared for the non-full
4667 -- view of a private extension
4671 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
4672 while Present
(Prim
) loop
4673 -- If a primitive is encountered that renames the predefined
4674 -- equality operator before reaching any explicit equality
4675 -- primitive, then we still need to create a predefined
4676 -- equality function, because calls to it can occur via
4677 -- the renaming. A new name is created for the equality
4678 -- to avoid conflicting with any user-defined equality.
4679 -- (Note that this doesn't account for renamings of
4680 -- equality nested within subpackages???)
4682 if Is_Predefined_Eq_Renaming
(Node
(Prim
)) then
4683 Eq_Name
:= New_External_Name
(Chars
(Node
(Prim
)), 'E');
4685 elsif Chars
(Node
(Prim
)) = Name_Op_Eq
4686 and then (No
(Alias
(Node
(Prim
)))
4687 or else Nkind
(Unit_Declaration_Node
(Node
(Prim
))) =
4688 N_Subprogram_Renaming_Declaration
)
4689 and then Etype
(First_Formal
(Node
(Prim
))) =
4690 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
4696 -- If the parent equality is abstract, the inherited equality is
4697 -- abstract as well, and no body can be created for for it.
4699 elsif Chars
(Node
(Prim
)) = Name_Op_Eq
4700 and then Present
(Alias
(Node
(Prim
)))
4701 and then Is_Abstract
(Alias
(Node
(Prim
)))
4710 -- If a renaming of predefined equality was found
4711 -- but there was no user-defined equality (so Eq_Needed
4712 -- is still true), then set the name back to Name_Op_Eq.
4713 -- But in the case where a user-defined equality was
4714 -- located after such a renaming, then the predefined
4715 -- equality function is still needed, so Eq_Needed must
4716 -- be set back to True.
4718 if Eq_Name
/= Name_Op_Eq
then
4720 Eq_Name
:= Name_Op_Eq
;
4727 Eq_Spec
:= Predef_Spec_Or_Body
(Loc
,
4730 Profile
=> New_List
(
4731 Make_Parameter_Specification
(Loc
,
4732 Defining_Identifier
=>
4733 Make_Defining_Identifier
(Loc
, Name_X
),
4734 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)),
4735 Make_Parameter_Specification
(Loc
,
4736 Defining_Identifier
=>
4737 Make_Defining_Identifier
(Loc
, Name_Y
),
4738 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
4739 Ret_Type
=> Standard_Boolean
);
4740 Append_To
(Res
, Eq_Spec
);
4742 if Eq_Name
/= Name_Op_Eq
then
4743 Renamed_Eq
:= Defining_Unit_Name
(Specification
(Eq_Spec
));
4745 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
4746 while Present
(Prim
) loop
4748 -- Any renamings of equality that appeared before an
4749 -- overriding equality must be updated to refer to
4750 -- the entity for the predefined equality, otherwise
4751 -- calls via the renaming would get incorrectly
4752 -- resolved to call the user-defined equality function.
4754 if Is_Predefined_Eq_Renaming
(Node
(Prim
)) then
4755 Set_Alias
(Node
(Prim
), Renamed_Eq
);
4757 -- Exit upon encountering a user-defined equality
4759 elsif Chars
(Node
(Prim
)) = Name_Op_Eq
4760 and then No
(Alias
(Node
(Prim
)))
4770 -- Spec for dispatching assignment
4772 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
4774 Name
=> Name_uAssign
,
4775 Profile
=> New_List
(
4776 Make_Parameter_Specification
(Loc
,
4777 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
4778 Out_Present
=> True,
4779 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)),
4781 Make_Parameter_Specification
(Loc
,
4782 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
4783 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)))));
4786 -- Specs for finalization actions that may be required in case a
4787 -- future extension contain a controlled element. We generate those
4788 -- only for root tagged types where they will get dummy bodies or
4789 -- when the type has controlled components and their body must be
4790 -- generated. It is also impossible to provide those for tagged
4791 -- types defined within s-finimp since it would involve circularity
4794 if In_Finalization_Root
(Tag_Typ
) then
4797 -- We also skip these in No_Run_Time mode where finalization is
4798 -- never permissible.
4800 elsif No_Run_Time
then
4803 elsif Etype
(Tag_Typ
) = Tag_Typ
or else Controlled_Type
(Tag_Typ
) then
4805 if not Is_Limited_Type
(Tag_Typ
) then
4807 Predef_Deep_Spec
(Loc
, Tag_Typ
, Name_uDeep_Adjust
));
4810 Append_To
(Res
, Predef_Deep_Spec
(Loc
, Tag_Typ
, Name_uDeep_Finalize
));
4814 end Make_Predefined_Primitive_Specs
;
4816 ---------------------------------
4817 -- Needs_Simple_Initialization --
4818 ---------------------------------
4820 function Needs_Simple_Initialization
(T
: Entity_Id
) return Boolean is
4822 -- Check for private type, in which case test applies to the
4823 -- underlying type of the private type.
4825 if Is_Private_Type
(T
) then
4827 RT
: constant Entity_Id
:= Underlying_Type
(T
);
4830 if Present
(RT
) then
4831 return Needs_Simple_Initialization
(RT
);
4837 -- Cases needing simple initialization are access types, and, if pragma
4838 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
4841 elsif Is_Access_Type
(T
)
4842 or else (Init_Or_Norm_Scalars
and then (Is_Scalar_Type
(T
)))
4844 or else (Is_Bit_Packed_Array
(T
)
4845 and then Is_Modular_Integer_Type
(Packed_Array_Type
(T
)))
4849 -- If Initialize/Normalize_Scalars is in effect, string objects also
4850 -- need initialization, unless they are created in the course of
4851 -- expanding an aggregate (since in the latter case they will be
4852 -- filled with appropriate initializing values before they are used).
4854 elsif Init_Or_Norm_Scalars
4856 (Root_Type
(T
) = Standard_String
4857 or else Root_Type
(T
) = Standard_Wide_String
)
4860 or else Nkind
(Associated_Node_For_Itype
(T
)) /= N_Aggregate
)
4867 end Needs_Simple_Initialization
;
4869 ----------------------
4870 -- Predef_Deep_Spec --
4871 ----------------------
4873 function Predef_Deep_Spec
4875 Tag_Typ
: Entity_Id
;
4877 For_Body
: Boolean := False)
4884 if Name
= Name_uDeep_Finalize
then
4886 Type_B
:= Standard_Boolean
;
4890 Make_Parameter_Specification
(Loc
,
4891 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_L
),
4893 Out_Present
=> True,
4895 New_Reference_To
(RTE
(RE_Finalizable_Ptr
), Loc
)));
4896 Type_B
:= Standard_Short_Short_Integer
;
4900 Make_Parameter_Specification
(Loc
,
4901 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
4903 Out_Present
=> True,
4904 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)));
4907 Make_Parameter_Specification
(Loc
,
4908 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_B
),
4909 Parameter_Type
=> New_Reference_To
(Type_B
, Loc
)));
4911 return Predef_Spec_Or_Body
(Loc
,
4915 For_Body
=> For_Body
);
4916 end Predef_Deep_Spec
;
4918 -------------------------
4919 -- Predef_Spec_Or_Body --
4920 -------------------------
4922 function Predef_Spec_Or_Body
4924 Tag_Typ
: Entity_Id
;
4927 Ret_Type
: Entity_Id
:= Empty
;
4928 For_Body
: Boolean := False)
4931 Id
: Entity_Id
:= Make_Defining_Identifier
(Loc
, Name
);
4935 Set_Is_Public
(Id
, Is_Public
(Tag_Typ
));
4937 -- The internal flag is set to mark these declarations because
4938 -- they have specific properties. First they are primitives even
4939 -- if they are not defined in the type scope (the freezing point
4940 -- is not necessarily in the same scope), furthermore the
4941 -- predefined equality can be overridden by a user-defined
4942 -- equality, no body will be generated in this case.
4944 Set_Is_Internal
(Id
);
4946 if not Debug_Generated_Code
then
4947 Set_Debug_Info_Off
(Id
);
4950 if No
(Ret_Type
) then
4952 Make_Procedure_Specification
(Loc
,
4953 Defining_Unit_Name
=> Id
,
4954 Parameter_Specifications
=> Profile
);
4957 Make_Function_Specification
(Loc
,
4958 Defining_Unit_Name
=> Id
,
4959 Parameter_Specifications
=> Profile
,
4961 New_Reference_To
(Ret_Type
, Loc
));
4964 -- If body case, return empty subprogram body. Note that this is
4965 -- ill-formed, because there is not even a null statement, and
4966 -- certainly not a return in the function case. The caller is
4967 -- expected to do surgery on the body to add the appropriate stuff.
4970 return Make_Subprogram_Body
(Loc
, Spec
, Empty_List
, Empty
);
4972 -- For the case of _Input and _Output applied to an abstract type,
4973 -- generate abstract specifications. These will never be called,
4974 -- but we need the slots allocated in the dispatching table so
4975 -- that typ'Class'Input and typ'Class'Output will work properly.
4977 elsif (Name
= Name_uInput
or else Name
= Name_uOutput
)
4978 and then Is_Abstract
(Tag_Typ
)
4980 return Make_Abstract_Subprogram_Declaration
(Loc
, Spec
);
4982 -- Normal spec case, where we return a subprogram declaration
4985 return Make_Subprogram_Declaration
(Loc
, Spec
);
4987 end Predef_Spec_Or_Body
;
4989 -----------------------------
4990 -- Predef_Stream_Attr_Spec --
4991 -----------------------------
4993 function Predef_Stream_Attr_Spec
4995 Tag_Typ
: Entity_Id
;
4997 For_Body
: Boolean := False)
5000 Ret_Type
: Entity_Id
;
5003 if Name
= Name_uInput
then
5004 Ret_Type
:= Tag_Typ
;
5009 return Predef_Spec_Or_Body
(Loc
,
5012 Profile
=> Build_Stream_Attr_Profile
(Loc
, Tag_Typ
, Name
),
5013 Ret_Type
=> Ret_Type
,
5014 For_Body
=> For_Body
);
5015 end Predef_Stream_Attr_Spec
;
5017 ---------------------------------
5018 -- Predefined_Primitive_Bodies --
5019 ---------------------------------
5021 function Predefined_Primitive_Bodies
5022 (Tag_Typ
: Entity_Id
;
5023 Renamed_Eq
: Node_Id
)
5026 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
5028 Res
: List_Id
:= New_List
;
5030 Eq_Needed
: Boolean;
5035 -- See if we have a predefined "=" operator
5037 if Present
(Renamed_Eq
) then
5039 Eq_Name
:= Chars
(Renamed_Eq
);
5045 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
5046 while Present
(Prim
) loop
5047 if Chars
(Node
(Prim
)) = Name_Op_Eq
5048 and then Is_Internal
(Node
(Prim
))
5051 Eq_Name
:= Name_Op_Eq
;
5060 Decl
:= Predef_Spec_Or_Body
(Loc
,
5063 Profile
=> New_List
(
5064 Make_Parameter_Specification
(Loc
,
5065 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
5066 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
5068 Ret_Type
=> Standard_Long_Long_Integer
,
5071 Set_Handled_Statement_Sequence
(Decl
,
5072 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5073 Make_Return_Statement
(Loc
,
5075 Make_Attribute_Reference
(Loc
,
5076 Prefix
=> Make_Identifier
(Loc
, Name_X
),
5077 Attribute_Name
=> Name_Size
)))));
5079 Append_To
(Res
, Decl
);
5081 -- Bodies for Dispatching stream IO routines. We need these only for
5082 -- non-limited types (in the limited case there is no dispatching).
5083 -- and we always skip them in No_Run_Time mode where streams are not
5086 if not (Is_Limited_Type
(Tag_Typ
) or else No_Run_Time
) then
5087 if No
(TSS
(Tag_Typ
, Name_uRead
)) then
5088 Build_Record_Read_Procedure
(Loc
, Tag_Typ
, Decl
, Ent
);
5089 Append_To
(Res
, Decl
);
5092 if No
(TSS
(Tag_Typ
, Name_uWrite
)) then
5093 Build_Record_Write_Procedure
(Loc
, Tag_Typ
, Decl
, Ent
);
5094 Append_To
(Res
, Decl
);
5097 -- Skip bodies of _Input and _Output for the abstract case, since
5098 -- the corresponding specs are abstract (see Predef_Spec_Or_Body)
5100 if not Is_Abstract
(Tag_Typ
) then
5101 if No
(TSS
(Tag_Typ
, Name_uInput
)) then
5102 Build_Record_Or_Elementary_Input_Function
5103 (Loc
, Tag_Typ
, Decl
, Ent
);
5104 Append_To
(Res
, Decl
);
5107 if No
(TSS
(Tag_Typ
, Name_uOutput
)) then
5108 Build_Record_Or_Elementary_Output_Procedure
5109 (Loc
, Tag_Typ
, Decl
, Ent
);
5110 Append_To
(Res
, Decl
);
5115 if not Is_Limited_Type
(Tag_Typ
) then
5117 -- Body for equality
5121 Decl
:= Predef_Spec_Or_Body
(Loc
,
5124 Profile
=> New_List
(
5125 Make_Parameter_Specification
(Loc
,
5126 Defining_Identifier
=>
5127 Make_Defining_Identifier
(Loc
, Name_X
),
5128 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)),
5130 Make_Parameter_Specification
(Loc
,
5131 Defining_Identifier
=>
5132 Make_Defining_Identifier
(Loc
, Name_Y
),
5133 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
5135 Ret_Type
=> Standard_Boolean
,
5139 Def
: constant Node_Id
:= Parent
(Tag_Typ
);
5140 Variant_Case
: Boolean := Has_Discriminants
(Tag_Typ
);
5141 Comps
: Node_Id
:= Empty
;
5142 Typ_Def
: Node_Id
:= Type_Definition
(Def
);
5143 Stmts
: List_Id
:= New_List
;
5146 if Variant_Case
then
5147 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
5148 Typ_Def
:= Record_Extension_Part
(Typ_Def
);
5151 if Present
(Typ_Def
) then
5152 Comps
:= Component_List
(Typ_Def
);
5155 Variant_Case
:= Present
(Comps
)
5156 and then Present
(Variant_Part
(Comps
));
5159 if Variant_Case
then
5161 Make_Eq_If
(Tag_Typ
, Discriminant_Specifications
(Def
)));
5162 Append_List_To
(Stmts
, Make_Eq_Case
(Tag_Typ
, Comps
));
5164 Make_Return_Statement
(Loc
,
5165 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
5169 Make_Return_Statement
(Loc
,
5171 Expand_Record_Equality
(Tag_Typ
,
5173 Lhs
=> Make_Identifier
(Loc
, Name_X
),
5174 Rhs
=> Make_Identifier
(Loc
, Name_Y
),
5175 Bodies
=> Declarations
(Decl
))));
5178 Set_Handled_Statement_Sequence
(Decl
,
5179 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
5181 Append_To
(Res
, Decl
);
5184 -- Body for dispatching assignment
5186 Decl
:= Predef_Spec_Or_Body
(Loc
,
5188 Name
=> Name_uAssign
,
5189 Profile
=> New_List
(
5190 Make_Parameter_Specification
(Loc
,
5191 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
5192 Out_Present
=> True,
5193 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)),
5195 Make_Parameter_Specification
(Loc
,
5196 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
5197 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
5200 Set_Handled_Statement_Sequence
(Decl
,
5201 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5202 Make_Assignment_Statement
(Loc
,
5203 Name
=> Make_Identifier
(Loc
, Name_X
),
5204 Expression
=> Make_Identifier
(Loc
, Name_Y
)))));
5206 Append_To
(Res
, Decl
);
5209 -- Generate dummy bodies for finalization actions of types that have
5210 -- no controlled components.
5212 -- Skip this processing if we are in the finalization routine in the
5213 -- runtime itself, otherwise we get hopelessly circularly confused!
5215 if In_Finalization_Root
(Tag_Typ
) then
5218 -- Skip this in no run time mode (where finalization is never allowed)
5220 elsif No_Run_Time
then
5223 elsif (Etype
(Tag_Typ
) = Tag_Typ
or else Is_Controlled
(Tag_Typ
))
5224 and then not Has_Controlled_Component
(Tag_Typ
)
5226 if not Is_Limited_Type
(Tag_Typ
) then
5227 Decl
:= Predef_Deep_Spec
(Loc
, Tag_Typ
, Name_uDeep_Adjust
, True);
5229 if Is_Controlled
(Tag_Typ
) then
5230 Set_Handled_Statement_Sequence
(Decl
,
5231 Make_Handled_Sequence_Of_Statements
(Loc
,
5233 Ref
=> Make_Identifier
(Loc
, Name_V
),
5235 Flist_Ref
=> Make_Identifier
(Loc
, Name_L
),
5236 With_Attach
=> Make_Identifier
(Loc
, Name_B
))));
5239 Set_Handled_Statement_Sequence
(Decl
,
5240 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5241 Make_Null_Statement
(Loc
))));
5244 Append_To
(Res
, Decl
);
5247 Decl
:= Predef_Deep_Spec
(Loc
, Tag_Typ
, Name_uDeep_Finalize
, True);
5249 if Is_Controlled
(Tag_Typ
) then
5250 Set_Handled_Statement_Sequence
(Decl
,
5251 Make_Handled_Sequence_Of_Statements
(Loc
,
5253 Ref
=> Make_Identifier
(Loc
, Name_V
),
5255 With_Detach
=> Make_Identifier
(Loc
, Name_B
))));
5258 Set_Handled_Statement_Sequence
(Decl
,
5259 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5260 Make_Null_Statement
(Loc
))));
5263 Append_To
(Res
, Decl
);
5267 end Predefined_Primitive_Bodies
;
5269 ---------------------------------
5270 -- Predefined_Primitive_Freeze --
5271 ---------------------------------
5273 function Predefined_Primitive_Freeze
5274 (Tag_Typ
: Entity_Id
)
5277 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
5278 Res
: List_Id
:= New_List
;
5283 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
5284 while Present
(Prim
) loop
5285 if Is_Internal
(Node
(Prim
)) then
5286 Frnodes
:= Freeze_Entity
(Node
(Prim
), Loc
);
5288 if Present
(Frnodes
) then
5289 Append_List_To
(Res
, Frnodes
);
5297 end Predefined_Primitive_Freeze
;