1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 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 Rident
; use Rident
;
50 with Rtsfind
; use Rtsfind
;
52 with Sem_Ch3
; use Sem_Ch3
;
53 with Sem_Ch8
; use Sem_Ch8
;
54 with Sem_Eval
; use Sem_Eval
;
55 with Sem_Mech
; use Sem_Mech
;
56 with Sem_Res
; use Sem_Res
;
57 with Sem_Util
; use Sem_Util
;
58 with Sinfo
; use Sinfo
;
59 with Stand
; use Stand
;
60 with Snames
; use Snames
;
61 with Tbuild
; use Tbuild
;
62 with Ttypes
; use Ttypes
;
63 with Uintp
; use Uintp
;
64 with Validsw
; use Validsw
;
66 package body Exp_Ch3
is
68 -----------------------
69 -- Local Subprograms --
70 -----------------------
72 procedure Adjust_Discriminants
(Rtype
: Entity_Id
);
73 -- This is used when freezing a record type. It attempts to construct
74 -- more restrictive subtypes for discriminants so that the max size of
75 -- the record can be calculated more accurately. See the body of this
76 -- procedure for details.
78 procedure Build_Array_Init_Proc
(A_Type
: Entity_Id
; Nod
: Node_Id
);
79 -- Build initialization procedure for given array type. Nod is a node
80 -- used for attachment of any actions required in its construction.
81 -- It also supplies the source location used for the procedure.
83 procedure Build_Class_Wide_Master
(T
: Entity_Id
);
84 -- for access to class-wide limited types we must build a task master
85 -- because some subsequent extension may add a task component. To avoid
86 -- bringing in the tasking run-time whenever an access-to-class-wide
87 -- limited type is used, we use the soft-link mechanism and add a level
88 -- of indirection to calls to routines that manipulate Master_Ids.
90 function Build_Discriminant_Formals
92 Use_Dl
: Boolean) return List_Id
;
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_Slice_Assignment
(Typ
: Entity_Id
);
117 -- Build assignment procedure for one-dimensional arrays of controlled
118 -- types. Other array and slice assignments are expanded in-line, but
119 -- the code expansion for controlled components (when control actions
120 -- are active) can lead to very large blocks that GCC3 handles poorly.
122 procedure Build_Variant_Record_Equality
(Typ
: Entity_Id
);
123 -- Create An Equality function for the non-tagged variant record 'Typ'
124 -- and attach it to the TSS list
126 procedure Check_Stream_Attributes
(Typ
: Entity_Id
);
127 -- Check that if a limited extension has a parent with user-defined
128 -- stream attributes, any limited component of the extension also has
129 -- the corresponding user-defined stream attributes.
131 procedure Expand_Tagged_Root
(T
: Entity_Id
);
132 -- Add a field _Tag at the beginning of the record. This field carries
133 -- the value of the access to the Dispatch table. This procedure is only
134 -- called on root (non CPP_Class) types, the _Tag field being inherited
135 -- by the descendants.
137 procedure Expand_Record_Controller
(T
: Entity_Id
);
138 -- T must be a record type that Has_Controlled_Component. Add a field
139 -- _controller of type Record_Controller or Limited_Record_Controller
142 procedure Freeze_Array_Type
(N
: Node_Id
);
143 -- Freeze an array type. Deals with building the initialization procedure,
144 -- creating the packed array type for a packed array and also with the
145 -- creation of the controlling procedures for the controlled case. The
146 -- argument N is the N_Freeze_Entity node for the type.
148 procedure Freeze_Enumeration_Type
(N
: Node_Id
);
149 -- Freeze enumeration type with non-standard representation. Builds the
150 -- array and function needed to convert between enumeration pos and
151 -- enumeration representation values. N is the N_Freeze_Entity node
154 procedure Freeze_Record_Type
(N
: Node_Id
);
155 -- Freeze record type. Builds all necessary discriminant checking
156 -- and other ancillary functions, and builds dispatch tables where
157 -- needed. The argument N is the N_Freeze_Entity node. This processing
158 -- applies only to E_Record_Type entities, not to class wide types,
159 -- record subtypes, or private types.
161 procedure Freeze_Stream_Operations
(N
: Node_Id
; Typ
: Entity_Id
);
162 -- Treat user-defined stream operations as renaming_as_body if the
163 -- subprogram they rename is not frozen when the type is frozen.
165 function Init_Formals
(Typ
: Entity_Id
) return List_Id
;
166 -- This function builds the list of formals for an initialization routine.
167 -- The first formal is always _Init with the given type. For task value
168 -- record types and types containing tasks, three additional formals are
171 -- _Master : Master_Id
172 -- _Chain : in out Activation_Chain
173 -- _Task_Name : String
175 -- The caller must append additional entries for discriminants if required.
177 function In_Runtime
(E
: Entity_Id
) return Boolean;
178 -- Check if E is defined in the RTL (in a child of Ada or System). Used
179 -- to avoid to bring in the overhead of _Input, _Output for tagged types.
181 function Make_Eq_Case
184 Discr
: Entity_Id
:= Empty
) return List_Id
;
185 -- Building block for variant record equality. Defined to share the
186 -- code between the tagged and non-tagged case. Given a Component_List
187 -- node CL, it generates an 'if' followed by a 'case' statement that
188 -- compares all components of local temporaries named X and Y (that
189 -- are declared as formals at some upper level). E provides the Sloc to be
190 -- used for the generated code. Discr is used as the case statement switch
191 -- in the case of Unchecked_Union equality.
195 L
: List_Id
) return Node_Id
;
196 -- Building block for variant record equality. Defined to share the
197 -- code between the tagged and non-tagged case. Given the list of
198 -- components (or discriminants) L, it generates a return statement
199 -- that compares all components of local temporaries named X and Y
200 -- (that are declared as formals at some upper level). E provides the Sloc
201 -- to be used for the generated code.
203 procedure Make_Predefined_Primitive_Specs
204 (Tag_Typ
: Entity_Id
;
205 Predef_List
: out List_Id
;
206 Renamed_Eq
: out Node_Id
);
207 -- Create a list with the specs of the predefined primitive operations.
208 -- The following entries are present for all tagged types, and provide
209 -- the results of the corresponding attribute applied to the object.
210 -- Dispatching is required in general, since the result of the attribute
211 -- will vary with the actual object subtype.
213 -- _alignment provides result of 'Alignment attribute
214 -- _size provides result of 'Size attribute
215 -- typSR provides result of 'Read attribute
216 -- typSW provides result of 'Write attribute
217 -- typSI provides result of 'Input attribute
218 -- typSO provides result of 'Output attribute
220 -- The following entries are additionally present for non-limited
221 -- tagged types, and implement additional dispatching operations
222 -- for predefined operations:
224 -- _equality implements "=" operator
225 -- _assign implements assignment operation
226 -- typDF implements deep finalization
227 -- typDA implements deep adust
229 -- The latter two are empty procedures unless the type contains some
230 -- controlled components that require finalization actions (the deep
231 -- in the name refers to the fact that the action applies to components).
233 -- The list is returned in Predef_List. The Parameter Renamed_Eq
234 -- either returns the value Empty, or else the defining unit name
235 -- for the predefined equality function in the case where the type
236 -- has a primitive operation that is a renaming of predefined equality
237 -- (but only if there is also an overriding user-defined equality
238 -- function). The returned Renamed_Eq will be passed to the
239 -- corresponding parameter of Predefined_Primitive_Bodies.
241 function Has_New_Non_Standard_Rep
(T
: Entity_Id
) return Boolean;
242 -- returns True if there are representation clauses for type T that
243 -- are not inherited. If the result is false, the init_proc and the
244 -- discriminant_checking functions of the parent can be reused by
247 function Predef_Spec_Or_Body
252 Ret_Type
: Entity_Id
:= Empty
;
253 For_Body
: Boolean := False) return Node_Id
;
254 -- This function generates the appropriate expansion for a predefined
255 -- primitive operation specified by its name, parameter profile and
256 -- return type (Empty means this is a procedure). If For_Body is false,
257 -- then the returned node is a subprogram declaration. If For_Body is
258 -- true, then the returned node is a empty subprogram body containing
259 -- no declarations and no statements.
261 function Predef_Stream_Attr_Spec
264 Name
: TSS_Name_Type
;
265 For_Body
: Boolean := False) return Node_Id
;
266 -- Specialized version of Predef_Spec_Or_Body that apply to read, write,
267 -- input and output attribute whose specs are constructed in Exp_Strm.
269 function Predef_Deep_Spec
272 Name
: TSS_Name_Type
;
273 For_Body
: Boolean := False) return Node_Id
;
274 -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
275 -- and _deep_finalize
277 function Predefined_Primitive_Bodies
278 (Tag_Typ
: Entity_Id
;
279 Renamed_Eq
: Node_Id
) return List_Id
;
280 -- Create the bodies of the predefined primitives that are described in
281 -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
282 -- the defining unit name of the type's predefined equality as returned
283 -- by Make_Predefined_Primitive_Specs.
285 function Predefined_Primitive_Freeze
(Tag_Typ
: Entity_Id
) return List_Id
;
286 -- Freeze entities of all predefined primitive operations. This is needed
287 -- because the bodies of these operations do not normally do any freezeing.
289 function Stream_Operations_OK
(Typ
: Entity_Id
) return Boolean;
290 -- Check whether stream operations must be emitted for a given type.
291 -- Various restrictions prevent the generation of these operations, as
292 -- a useful optimization or for certification purposes.
294 --------------------------
295 -- Adjust_Discriminants --
296 --------------------------
298 -- This procedure attempts to define subtypes for discriminants that
299 -- are more restrictive than those declared. Such a replacement is
300 -- possible if we can demonstrate that values outside the restricted
301 -- range would cause constraint errors in any case. The advantage of
302 -- restricting the discriminant types in this way is tha the maximum
303 -- size of the variant record can be calculated more conservatively.
305 -- An example of a situation in which we can perform this type of
306 -- restriction is the following:
308 -- subtype B is range 1 .. 10;
309 -- type Q is array (B range <>) of Integer;
311 -- type V (N : Natural) is record
315 -- In this situation, we can restrict the upper bound of N to 10, since
316 -- any larger value would cause a constraint error in any case.
318 -- There are many situations in which such restriction is possible, but
319 -- for now, we just look for cases like the above, where the component
320 -- in question is a one dimensional array whose upper bound is one of
321 -- the record discriminants. Also the component must not be part of
322 -- any variant part, since then the component does not always exist.
324 procedure Adjust_Discriminants
(Rtype
: Entity_Id
) is
325 Loc
: constant Source_Ptr
:= Sloc
(Rtype
);
342 Comp
:= First_Component
(Rtype
);
343 while Present
(Comp
) loop
345 -- If our parent is a variant, quit, we do not look at components
346 -- that are in variant parts, because they may not always exist.
348 P
:= Parent
(Comp
); -- component declaration
349 P
:= Parent
(P
); -- component list
351 exit when Nkind
(Parent
(P
)) = N_Variant
;
353 -- We are looking for a one dimensional array type
355 Ctyp
:= Etype
(Comp
);
357 if not Is_Array_Type
(Ctyp
)
358 or else Number_Dimensions
(Ctyp
) > 1
363 -- The lower bound must be constant, and the upper bound is a
364 -- discriminant (which is a discriminant of the current record).
366 Ityp
:= Etype
(First_Index
(Ctyp
));
367 Lo
:= Type_Low_Bound
(Ityp
);
368 Hi
:= Type_High_Bound
(Ityp
);
370 if not Compile_Time_Known_Value
(Lo
)
371 or else Nkind
(Hi
) /= N_Identifier
372 or else No
(Entity
(Hi
))
373 or else Ekind
(Entity
(Hi
)) /= E_Discriminant
378 -- We have an array with appropriate bounds
380 Loval
:= Expr_Value
(Lo
);
381 Discr
:= Entity
(Hi
);
382 Dtyp
:= Etype
(Discr
);
384 -- See if the discriminant has a known upper bound
386 Dhi
:= Type_High_Bound
(Dtyp
);
388 if not Compile_Time_Known_Value
(Dhi
) then
392 Dhiv
:= Expr_Value
(Dhi
);
394 -- See if base type of component array has known upper bound
396 Ahi
:= Type_High_Bound
(Etype
(First_Index
(Base_Type
(Ctyp
))));
398 if not Compile_Time_Known_Value
(Ahi
) then
402 Ahiv
:= Expr_Value
(Ahi
);
404 -- The condition for doing the restriction is that the high bound
405 -- of the discriminant is greater than the low bound of the array,
406 -- and is also greater than the high bound of the base type index.
408 if Dhiv
> Loval
and then Dhiv
> Ahiv
then
410 -- We can reset the upper bound of the discriminant type to
411 -- whichever is larger, the low bound of the component, or
412 -- the high bound of the base type array index.
414 -- We build a subtype that is declared as
416 -- subtype Tnn is discr_type range discr_type'First .. max;
418 -- And insert this declaration into the tree. The type of the
419 -- discriminant is then reset to this more restricted subtype.
421 Tnn
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
423 Insert_Action
(Declaration_Node
(Rtype
),
424 Make_Subtype_Declaration
(Loc
,
425 Defining_Identifier
=> Tnn
,
426 Subtype_Indication
=>
427 Make_Subtype_Indication
(Loc
,
428 Subtype_Mark
=> New_Occurrence_Of
(Dtyp
, Loc
),
430 Make_Range_Constraint
(Loc
,
434 Make_Attribute_Reference
(Loc
,
435 Attribute_Name
=> Name_First
,
436 Prefix
=> New_Occurrence_Of
(Dtyp
, Loc
)),
438 Make_Integer_Literal
(Loc
,
439 Intval
=> UI_Max
(Loval
, Ahiv
)))))));
441 Set_Etype
(Discr
, Tnn
);
445 Next_Component
(Comp
);
447 end Adjust_Discriminants
;
449 ---------------------------
450 -- Build_Array_Init_Proc --
451 ---------------------------
453 procedure Build_Array_Init_Proc
(A_Type
: Entity_Id
; Nod
: Node_Id
) is
454 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
455 Comp_Type
: constant Entity_Id
:= Component_Type
(A_Type
);
456 Index_List
: List_Id
;
458 Body_Stmts
: List_Id
;
460 function Init_Component
return List_Id
;
461 -- Create one statement to initialize one array component, designated
462 -- by a full set of indices.
464 function Init_One_Dimension
(N
: Int
) return List_Id
;
465 -- Create loop to initialize one dimension of the array. The single
466 -- statement in the loop body initializes the inner dimensions if any,
467 -- or else the single component. Note that this procedure is called
468 -- recursively, with N being the dimension to be initialized. A call
469 -- with N greater than the number of dimensions simply generates the
470 -- component initialization, terminating the recursion.
476 function Init_Component
return List_Id
is
481 Make_Indexed_Component
(Loc
,
482 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
483 Expressions
=> Index_List
);
485 if Needs_Simple_Initialization
(Comp_Type
) then
486 Set_Assignment_OK
(Comp
);
488 Make_Assignment_Statement
(Loc
,
490 Expression
=> Get_Simple_Init_Val
(Comp_Type
, Loc
)));
494 Build_Initialization_Call
(Loc
, Comp
, Comp_Type
, True, A_Type
);
498 ------------------------
499 -- Init_One_Dimension --
500 ------------------------
502 function Init_One_Dimension
(N
: Int
) return List_Id
is
506 -- If the component does not need initializing, then there is nothing
507 -- to do here, so we return a null body. This occurs when generating
508 -- the dummy Init_Proc needed for Initialize_Scalars processing.
510 if not Has_Non_Null_Base_Init_Proc
(Comp_Type
)
511 and then not Needs_Simple_Initialization
(Comp_Type
)
512 and then not Has_Task
(Comp_Type
)
514 return New_List
(Make_Null_Statement
(Loc
));
516 -- If all dimensions dealt with, we simply initialize the component
518 elsif N
> Number_Dimensions
(A_Type
) then
519 return Init_Component
;
521 -- Here we generate the required loop
525 Make_Defining_Identifier
(Loc
, New_External_Name
('J', N
));
527 Append
(New_Reference_To
(Index
, Loc
), Index_List
);
530 Make_Implicit_Loop_Statement
(Nod
,
533 Make_Iteration_Scheme
(Loc
,
534 Loop_Parameter_Specification
=>
535 Make_Loop_Parameter_Specification
(Loc
,
536 Defining_Identifier
=> Index
,
537 Discrete_Subtype_Definition
=>
538 Make_Attribute_Reference
(Loc
,
539 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
540 Attribute_Name
=> Name_Range
,
541 Expressions
=> New_List
(
542 Make_Integer_Literal
(Loc
, N
))))),
543 Statements
=> Init_One_Dimension
(N
+ 1)));
545 end Init_One_Dimension
;
547 -- Start of processing for Build_Array_Init_Proc
550 if Suppress_Init_Proc
(A_Type
) then
554 Index_List
:= New_List
;
556 -- We need an initialization procedure if any of the following is true:
558 -- 1. The component type has an initialization procedure
559 -- 2. The component type needs simple initialization
560 -- 3. Tasks are present
561 -- 4. The type is marked as a publc entity
563 -- The reason for the public entity test is to deal properly with the
564 -- Initialize_Scalars pragma. This pragma can be set in the client and
565 -- not in the declaring package, this means the client will make a call
566 -- to the initialization procedure (because one of conditions 1-3 must
567 -- apply in this case), and we must generate a procedure (even if it is
568 -- null) to satisfy the call in this case.
570 -- Exception: do not build an array init_proc for a type whose root type
571 -- is Standard.String or Standard.Wide_String, since there is no place
572 -- to put the code, and in any case we handle initialization of such
573 -- types (in the Initialize_Scalars case, that's the only time the issue
574 -- arises) in a special manner anyway which does not need an init_proc.
576 if Has_Non_Null_Base_Init_Proc
(Comp_Type
)
577 or else Needs_Simple_Initialization
(Comp_Type
)
578 or else Has_Task
(Comp_Type
)
579 or else (not Restriction_Active
(No_Initialize_Scalars
)
580 and then Is_Public
(A_Type
)
581 and then Root_Type
(A_Type
) /= Standard_String
582 and then Root_Type
(A_Type
) /= Standard_Wide_String
)
585 Make_Defining_Identifier
(Loc
, Make_Init_Proc_Name
(A_Type
));
587 Body_Stmts
:= Init_One_Dimension
(1);
590 Make_Subprogram_Body
(Loc
,
592 Make_Procedure_Specification
(Loc
,
593 Defining_Unit_Name
=> Proc_Id
,
594 Parameter_Specifications
=> Init_Formals
(A_Type
)),
595 Declarations
=> New_List
,
596 Handled_Statement_Sequence
=>
597 Make_Handled_Sequence_Of_Statements
(Loc
,
598 Statements
=> Body_Stmts
)));
600 Set_Ekind
(Proc_Id
, E_Procedure
);
601 Set_Is_Public
(Proc_Id
, Is_Public
(A_Type
));
602 Set_Is_Internal
(Proc_Id
);
603 Set_Has_Completion
(Proc_Id
);
605 if not Debug_Generated_Code
then
606 Set_Debug_Info_Off
(Proc_Id
);
609 -- Set inlined unless controlled stuff or tasks around, in which
610 -- case we do not want to inline, because nested stuff may cause
611 -- difficulties in interunit inlining, and furthermore there is
612 -- in any case no point in inlining such complex init procs.
614 if not Has_Task
(Proc_Id
)
615 and then not Controlled_Type
(Proc_Id
)
617 Set_Is_Inlined
(Proc_Id
);
620 -- Associate Init_Proc with type, and determine if the procedure
621 -- is null (happens because of the Initialize_Scalars pragma case,
622 -- where we have to generate a null procedure in case it is called
623 -- by a client with Initialize_Scalars set). Such procedures have
624 -- to be generated, but do not have to be called, so we mark them
625 -- as null to suppress the call.
627 Set_Init_Proc
(A_Type
, Proc_Id
);
629 if List_Length
(Body_Stmts
) = 1
630 and then Nkind
(First
(Body_Stmts
)) = N_Null_Statement
632 Set_Is_Null_Init_Proc
(Proc_Id
);
635 end Build_Array_Init_Proc
;
637 -----------------------------
638 -- Build_Class_Wide_Master --
639 -----------------------------
641 procedure Build_Class_Wide_Master
(T
: Entity_Id
) is
642 Loc
: constant Source_Ptr
:= Sloc
(T
);
648 -- Nothing to do if there is no task hierarchy
650 if Restriction_Active
(No_Task_Hierarchy
) then
654 -- Nothing to do if we already built a master entity for this scope
656 if not Has_Master_Entity
(Scope
(T
)) then
657 -- first build the master entity
658 -- _Master : constant Master_Id := Current_Master.all;
659 -- and insert it just before the current declaration
662 Make_Object_Declaration
(Loc
,
663 Defining_Identifier
=>
664 Make_Defining_Identifier
(Loc
, Name_uMaster
),
665 Constant_Present
=> True,
666 Object_Definition
=> New_Reference_To
(Standard_Integer
, Loc
),
668 Make_Explicit_Dereference
(Loc
,
669 New_Reference_To
(RTE
(RE_Current_Master
), Loc
)));
672 Insert_Before
(P
, Decl
);
674 Set_Has_Master_Entity
(Scope
(T
));
676 -- Now mark the containing scope as a task master
678 while Nkind
(P
) /= N_Compilation_Unit
loop
681 -- If we fall off the top, we are at the outer level, and the
682 -- environment task is our effective master, so nothing to mark.
684 if Nkind
(P
) = N_Task_Body
685 or else Nkind
(P
) = N_Block_Statement
686 or else Nkind
(P
) = N_Subprogram_Body
688 Set_Is_Task_Master
(P
, True);
694 -- Now define the renaming of the master_id
697 Make_Defining_Identifier
(Loc
,
698 New_External_Name
(Chars
(T
), 'M'));
701 Make_Object_Renaming_Declaration
(Loc
,
702 Defining_Identifier
=> M_Id
,
703 Subtype_Mark
=> New_Reference_To
(Standard_Integer
, Loc
),
704 Name
=> Make_Identifier
(Loc
, Name_uMaster
));
705 Insert_Before
(Parent
(T
), Decl
);
708 Set_Master_Id
(T
, M_Id
);
711 when RE_Not_Available
=>
713 end Build_Class_Wide_Master
;
715 --------------------------------
716 -- Build_Discr_Checking_Funcs --
717 --------------------------------
719 procedure Build_Discr_Checking_Funcs
(N
: Node_Id
) is
722 Enclosing_Func_Id
: Entity_Id
;
727 function Build_Case_Statement
728 (Case_Id
: Entity_Id
;
729 Variant
: Node_Id
) return Node_Id
;
730 -- Build a case statement containing only two alternatives. The
731 -- first alternative corresponds exactly to the discrete choices
732 -- given on the variant with contains the components that we are
733 -- generating the checks for. If the discriminant is one of these
734 -- return False. The second alternative is an OTHERS choice that
735 -- will return True indicating the discriminant did not match.
737 function Build_Dcheck_Function
738 (Case_Id
: Entity_Id
;
739 Variant
: Node_Id
) return Entity_Id
;
740 -- Build the discriminant checking function for a given variant
742 procedure Build_Dcheck_Functions
(Variant_Part_Node
: Node_Id
);
743 -- Builds the discriminant checking function for each variant of the
744 -- given variant part of the record type.
746 --------------------------
747 -- Build_Case_Statement --
748 --------------------------
750 function Build_Case_Statement
751 (Case_Id
: Entity_Id
;
752 Variant
: Node_Id
) return Node_Id
754 Alt_List
: constant List_Id
:= New_List
;
755 Actuals_List
: List_Id
;
757 Case_Alt_Node
: Node_Id
;
759 Choice_List
: List_Id
;
761 Return_Node
: Node_Id
;
764 Case_Node
:= New_Node
(N_Case_Statement
, Loc
);
766 -- Replace the discriminant which controls the variant, with the
767 -- name of the formal of the checking function.
769 Set_Expression
(Case_Node
,
770 Make_Identifier
(Loc
, Chars
(Case_Id
)));
772 Choice
:= First
(Discrete_Choices
(Variant
));
774 if Nkind
(Choice
) = N_Others_Choice
then
775 Choice_List
:= New_Copy_List
(Others_Discrete_Choices
(Choice
));
777 Choice_List
:= New_Copy_List
(Discrete_Choices
(Variant
));
780 if not Is_Empty_List
(Choice_List
) then
781 Case_Alt_Node
:= New_Node
(N_Case_Statement_Alternative
, Loc
);
782 Set_Discrete_Choices
(Case_Alt_Node
, Choice_List
);
784 -- In case this is a nested variant, we need to return the result
785 -- of the discriminant checking function for the immediately
786 -- enclosing variant.
788 if Present
(Enclosing_Func_Id
) then
789 Actuals_List
:= New_List
;
791 D
:= First_Discriminant
(Rec_Id
);
792 while Present
(D
) loop
793 Append
(Make_Identifier
(Loc
, Chars
(D
)), Actuals_List
);
794 Next_Discriminant
(D
);
798 Make_Return_Statement
(Loc
,
800 Make_Function_Call
(Loc
,
802 New_Reference_To
(Enclosing_Func_Id
, Loc
),
803 Parameter_Associations
=>
808 Make_Return_Statement
(Loc
,
810 New_Reference_To
(Standard_False
, Loc
));
813 Set_Statements
(Case_Alt_Node
, New_List
(Return_Node
));
814 Append
(Case_Alt_Node
, Alt_List
);
817 Case_Alt_Node
:= New_Node
(N_Case_Statement_Alternative
, Loc
);
818 Choice_List
:= New_List
(New_Node
(N_Others_Choice
, Loc
));
819 Set_Discrete_Choices
(Case_Alt_Node
, Choice_List
);
822 Make_Return_Statement
(Loc
,
824 New_Reference_To
(Standard_True
, Loc
));
826 Set_Statements
(Case_Alt_Node
, New_List
(Return_Node
));
827 Append
(Case_Alt_Node
, Alt_List
);
829 Set_Alternatives
(Case_Node
, Alt_List
);
831 end Build_Case_Statement
;
833 ---------------------------
834 -- Build_Dcheck_Function --
835 ---------------------------
837 function Build_Dcheck_Function
838 (Case_Id
: Entity_Id
;
839 Variant
: Node_Id
) return Entity_Id
843 Parameter_List
: List_Id
;
847 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
848 Sequence
:= Sequence
+ 1;
851 Make_Defining_Identifier
(Loc
,
852 Chars
=> New_External_Name
(Chars
(Rec_Id
), 'D', Sequence
));
854 Spec_Node
:= New_Node
(N_Function_Specification
, Loc
);
855 Set_Defining_Unit_Name
(Spec_Node
, Func_Id
);
857 Parameter_List
:= Build_Discriminant_Formals
(Rec_Id
, False);
859 Set_Parameter_Specifications
(Spec_Node
, Parameter_List
);
860 Set_Subtype_Mark
(Spec_Node
,
861 New_Reference_To
(Standard_Boolean
, Loc
));
862 Set_Specification
(Body_Node
, Spec_Node
);
863 Set_Declarations
(Body_Node
, New_List
);
865 Set_Handled_Statement_Sequence
(Body_Node
,
866 Make_Handled_Sequence_Of_Statements
(Loc
,
867 Statements
=> New_List
(
868 Build_Case_Statement
(Case_Id
, Variant
))));
870 Set_Ekind
(Func_Id
, E_Function
);
871 Set_Mechanism
(Func_Id
, Default_Mechanism
);
872 Set_Is_Inlined
(Func_Id
, True);
873 Set_Is_Pure
(Func_Id
, True);
874 Set_Is_Public
(Func_Id
, Is_Public
(Rec_Id
));
875 Set_Is_Internal
(Func_Id
, True);
877 if not Debug_Generated_Code
then
878 Set_Debug_Info_Off
(Func_Id
);
883 Append_Freeze_Action
(Rec_Id
, Body_Node
);
884 Set_Dcheck_Function
(Variant
, Func_Id
);
886 end Build_Dcheck_Function
;
888 ----------------------------
889 -- Build_Dcheck_Functions --
890 ----------------------------
892 procedure Build_Dcheck_Functions
(Variant_Part_Node
: Node_Id
) is
893 Component_List_Node
: Node_Id
;
895 Discr_Name
: Entity_Id
;
898 Saved_Enclosing_Func_Id
: Entity_Id
;
901 -- Build the discriminant checking function for each variant, label
902 -- all components of that variant with the function's name.
904 Discr_Name
:= Entity
(Name
(Variant_Part_Node
));
905 Variant
:= First_Non_Pragma
(Variants
(Variant_Part_Node
));
907 while Present
(Variant
) loop
908 Func_Id
:= Build_Dcheck_Function
(Discr_Name
, Variant
);
909 Component_List_Node
:= Component_List
(Variant
);
911 if not Null_Present
(Component_List_Node
) then
913 First_Non_Pragma
(Component_Items
(Component_List_Node
));
915 while Present
(Decl
) loop
916 Set_Discriminant_Checking_Func
917 (Defining_Identifier
(Decl
), Func_Id
);
919 Next_Non_Pragma
(Decl
);
922 if Present
(Variant_Part
(Component_List_Node
)) then
923 Saved_Enclosing_Func_Id
:= Enclosing_Func_Id
;
924 Enclosing_Func_Id
:= Func_Id
;
925 Build_Dcheck_Functions
(Variant_Part
(Component_List_Node
));
926 Enclosing_Func_Id
:= Saved_Enclosing_Func_Id
;
930 Next_Non_Pragma
(Variant
);
932 end Build_Dcheck_Functions
;
934 -- Start of processing for Build_Discr_Checking_Funcs
937 -- Only build if not done already
939 if not Discr_Check_Funcs_Built
(N
) then
940 Type_Def
:= Type_Definition
(N
);
942 if Nkind
(Type_Def
) = N_Record_Definition
then
943 if No
(Component_List
(Type_Def
)) then -- null record.
946 V
:= Variant_Part
(Component_List
(Type_Def
));
949 else pragma Assert
(Nkind
(Type_Def
) = N_Derived_Type_Definition
);
950 if No
(Component_List
(Record_Extension_Part
(Type_Def
))) then
954 (Component_List
(Record_Extension_Part
(Type_Def
)));
958 Rec_Id
:= Defining_Identifier
(N
);
960 if Present
(V
) and then not Is_Unchecked_Union
(Rec_Id
) then
962 Enclosing_Func_Id
:= Empty
;
963 Build_Dcheck_Functions
(V
);
966 Set_Discr_Check_Funcs_Built
(N
);
968 end Build_Discr_Checking_Funcs
;
970 --------------------------------
971 -- Build_Discriminant_Formals --
972 --------------------------------
974 function Build_Discriminant_Formals
976 Use_Dl
: Boolean) return List_Id
978 Loc
: Source_Ptr
:= Sloc
(Rec_Id
);
979 Parameter_List
: constant List_Id
:= New_List
;
982 Param_Spec_Node
: Node_Id
;
985 if Has_Discriminants
(Rec_Id
) then
986 D
:= First_Discriminant
(Rec_Id
);
987 while Present
(D
) loop
991 Formal
:= Discriminal
(D
);
993 Formal
:= Make_Defining_Identifier
(Loc
, Chars
(D
));
997 Make_Parameter_Specification
(Loc
,
998 Defining_Identifier
=> Formal
,
1000 New_Reference_To
(Etype
(D
), Loc
));
1001 Append
(Param_Spec_Node
, Parameter_List
);
1002 Next_Discriminant
(D
);
1006 return Parameter_List
;
1007 end Build_Discriminant_Formals
;
1009 -------------------------------
1010 -- Build_Initialization_Call --
1011 -------------------------------
1013 -- References to a discriminant inside the record type declaration
1014 -- can appear either in the subtype_indication to constrain a
1015 -- record or an array, or as part of a larger expression given for
1016 -- the initial value of a component. In both of these cases N appears
1017 -- in the record initialization procedure and needs to be replaced by
1018 -- the formal parameter of the initialization procedure which
1019 -- corresponds to that discriminant.
1021 -- In the example below, references to discriminants D1 and D2 in proc_1
1022 -- are replaced by references to formals with the same name
1025 -- A similar replacement is done for calls to any record
1026 -- initialization procedure for any components that are themselves
1027 -- of a record type.
1029 -- type R (D1, D2 : Integer) is record
1030 -- X : Integer := F * D1;
1031 -- Y : Integer := F * D2;
1034 -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is
1038 -- Out_2.X := F * D1;
1039 -- Out_2.Y := F * D2;
1042 function Build_Initialization_Call
1046 In_Init_Proc
: Boolean := False;
1047 Enclos_Type
: Entity_Id
:= Empty
;
1048 Discr_Map
: Elist_Id
:= New_Elmt_List
;
1049 With_Default_Init
: Boolean := False) return List_Id
1051 First_Arg
: Node_Id
;
1057 Proc
: constant Entity_Id
:= Base_Init_Proc
(Typ
);
1058 Init_Type
: constant Entity_Id
:= Etype
(First_Formal
(Proc
));
1059 Full_Init_Type
: constant Entity_Id
:= Underlying_Type
(Init_Type
);
1060 Res
: constant List_Id
:= New_List
;
1061 Full_Type
: Entity_Id
:= Typ
;
1062 Controller_Typ
: Entity_Id
;
1065 -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars
1066 -- is active (in which case we make the call anyway, since in the
1067 -- actual compiled client it may be non null).
1069 if Is_Null_Init_Proc
(Proc
) and then not Init_Or_Norm_Scalars
then
1073 -- Go to full view if private type. In the case of successive
1074 -- private derivations, this can require more than one step.
1076 while Is_Private_Type
(Full_Type
)
1077 and then Present
(Full_View
(Full_Type
))
1079 Full_Type
:= Full_View
(Full_Type
);
1082 -- If Typ is derived, the procedure is the initialization procedure for
1083 -- the root type. Wrap the argument in an conversion to make it type
1084 -- honest. Actually it isn't quite type honest, because there can be
1085 -- conflicts of views in the private type case. That is why we set
1086 -- Conversion_OK in the conversion node.
1087 if (Is_Record_Type
(Typ
)
1088 or else Is_Array_Type
(Typ
)
1089 or else Is_Private_Type
(Typ
))
1090 and then Init_Type
/= Base_Type
(Typ
)
1092 First_Arg
:= OK_Convert_To
(Etype
(Init_Type
), Id_Ref
);
1093 Set_Etype
(First_Arg
, Init_Type
);
1096 First_Arg
:= Id_Ref
;
1099 Args
:= New_List
(Convert_Concurrent
(First_Arg
, Typ
));
1101 -- In the tasks case, add _Master as the value of the _Master parameter
1102 -- and _Chain as the value of the _Chain parameter. At the outer level,
1103 -- these will be variables holding the corresponding values obtained
1104 -- from GNARL. At inner levels, they will be the parameters passed down
1105 -- through the outer routines.
1107 if Has_Task
(Full_Type
) then
1108 if Restriction_Active
(No_Task_Hierarchy
) then
1110 -- See comments in System.Tasking.Initialization.Init_RTS
1111 -- for the value 3 (should be rtsfindable constant ???)
1113 Append_To
(Args
, Make_Integer_Literal
(Loc
, 3));
1115 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
1118 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
1120 -- Ada 2005 (AI-287): In case of default initialized components
1121 -- with tasks, we generate a null string actual parameter.
1122 -- This is just a workaround that must be improved later???
1124 if With_Default_Init
then
1126 Make_String_Literal
(Loc
,
1130 Decls
:= Build_Task_Image_Decls
(Loc
, Id_Ref
, Enclos_Type
);
1131 Decl
:= Last
(Decls
);
1134 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
1135 Append_List
(Decls
, Res
);
1143 -- Add discriminant values if discriminants are present
1145 if Has_Discriminants
(Full_Init_Type
) then
1146 Discr
:= First_Discriminant
(Full_Init_Type
);
1148 while Present
(Discr
) loop
1150 -- If this is a discriminated concurrent type, the init_proc
1151 -- for the corresponding record is being called. Use that
1152 -- type directly to find the discriminant value, to handle
1153 -- properly intervening renamed discriminants.
1156 T
: Entity_Id
:= Full_Type
;
1159 if Is_Protected_Type
(T
) then
1160 T
:= Corresponding_Record_Type
(T
);
1162 elsif Is_Private_Type
(T
)
1163 and then Present
(Underlying_Full_View
(T
))
1164 and then Is_Protected_Type
(Underlying_Full_View
(T
))
1166 T
:= Corresponding_Record_Type
(Underlying_Full_View
(T
));
1170 Get_Discriminant_Value
(
1173 Discriminant_Constraint
(Full_Type
));
1176 if In_Init_Proc
then
1178 -- Replace any possible references to the discriminant in the
1179 -- call to the record initialization procedure with references
1180 -- to the appropriate formal parameter.
1182 if Nkind
(Arg
) = N_Identifier
1183 and then Ekind
(Entity
(Arg
)) = E_Discriminant
1185 Arg
:= New_Reference_To
(Discriminal
(Entity
(Arg
)), Loc
);
1187 -- Case of access discriminants. We replace the reference
1188 -- to the type by a reference to the actual object
1190 elsif Nkind
(Arg
) = N_Attribute_Reference
1191 and then Is_Access_Type
(Etype
(Arg
))
1192 and then Is_Entity_Name
(Prefix
(Arg
))
1193 and then Is_Type
(Entity
(Prefix
(Arg
)))
1196 Make_Attribute_Reference
(Loc
,
1197 Prefix
=> New_Copy
(Prefix
(Id_Ref
)),
1198 Attribute_Name
=> Name_Unrestricted_Access
);
1200 -- Otherwise make a copy of the default expression. Note
1201 -- that we use the current Sloc for this, because we do not
1202 -- want the call to appear to be at the declaration point.
1203 -- Within the expression, replace discriminants with their
1208 New_Copy_Tree
(Arg
, Map
=> Discr_Map
, New_Sloc
=> Loc
);
1212 if Is_Constrained
(Full_Type
) then
1213 Arg
:= Duplicate_Subexpr_No_Checks
(Arg
);
1215 -- The constraints come from the discriminant default
1216 -- exps, they must be reevaluated, so we use New_Copy_Tree
1217 -- but we ensure the proper Sloc (for any embedded calls).
1219 Arg
:= New_Copy_Tree
(Arg
, New_Sloc
=> Loc
);
1223 -- Ada 2005 (AI-287) In case of default initialized components,
1224 -- we need to generate the corresponding selected component node
1225 -- to access the discriminant value. In other cases this is not
1226 -- required because we are inside the init proc and we use the
1227 -- corresponding formal.
1229 if With_Default_Init
1230 and then Nkind
(Id_Ref
) = N_Selected_Component
1233 Make_Selected_Component
(Loc
,
1234 Prefix
=> New_Copy_Tree
(Prefix
(Id_Ref
)),
1235 Selector_Name
=> Arg
));
1237 Append_To
(Args
, Arg
);
1240 Next_Discriminant
(Discr
);
1244 -- If this is a call to initialize the parent component of a derived
1245 -- tagged type, indicate that the tag should not be set in the parent.
1247 if Is_Tagged_Type
(Full_Init_Type
)
1248 and then not Is_CPP_Class
(Full_Init_Type
)
1249 and then Nkind
(Id_Ref
) = N_Selected_Component
1250 and then Chars
(Selector_Name
(Id_Ref
)) = Name_uParent
1252 Append_To
(Args
, New_Occurrence_Of
(Standard_False
, Loc
));
1256 Make_Procedure_Call_Statement
(Loc
,
1257 Name
=> New_Occurrence_Of
(Proc
, Loc
),
1258 Parameter_Associations
=> Args
));
1260 if Controlled_Type
(Typ
)
1261 and then Nkind
(Id_Ref
) = N_Selected_Component
1263 if Chars
(Selector_Name
(Id_Ref
)) /= Name_uParent
then
1264 Append_List_To
(Res
,
1266 Ref
=> New_Copy_Tree
(First_Arg
),
1269 Find_Final_List
(Typ
, New_Copy_Tree
(First_Arg
)),
1270 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
1272 -- If the enclosing type is an extension with new controlled
1273 -- components, it has his own record controller. If the parent
1274 -- also had a record controller, attach it to the new one.
1275 -- Build_Init_Statements relies on the fact that in this specific
1276 -- case the last statement of the result is the attach call to
1277 -- the controller. If this is changed, it must be synchronized.
1279 elsif Present
(Enclos_Type
)
1280 and then Has_New_Controlled_Component
(Enclos_Type
)
1281 and then Has_Controlled_Component
(Typ
)
1283 if Is_Return_By_Reference_Type
(Typ
) then
1284 Controller_Typ
:= RTE
(RE_Limited_Record_Controller
);
1286 Controller_Typ
:= RTE
(RE_Record_Controller
);
1289 Append_List_To
(Res
,
1292 Make_Selected_Component
(Loc
,
1293 Prefix
=> New_Copy_Tree
(First_Arg
),
1294 Selector_Name
=> Make_Identifier
(Loc
, Name_uController
)),
1295 Typ
=> Controller_Typ
,
1296 Flist_Ref
=> Find_Final_List
(Typ
, New_Copy_Tree
(First_Arg
)),
1297 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
1304 when RE_Not_Available
=>
1306 end Build_Initialization_Call
;
1308 ---------------------------
1309 -- Build_Master_Renaming --
1310 ---------------------------
1312 procedure Build_Master_Renaming
(N
: Node_Id
; T
: Entity_Id
) is
1313 Loc
: constant Source_Ptr
:= Sloc
(N
);
1318 -- Nothing to do if there is no task hierarchy
1320 if Restriction_Active
(No_Task_Hierarchy
) then
1325 Make_Defining_Identifier
(Loc
,
1326 New_External_Name
(Chars
(T
), 'M'));
1329 Make_Object_Renaming_Declaration
(Loc
,
1330 Defining_Identifier
=> M_Id
,
1331 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Master_Id
), Loc
),
1332 Name
=> Make_Identifier
(Loc
, Name_uMaster
));
1333 Insert_Before
(N
, Decl
);
1336 Set_Master_Id
(T
, M_Id
);
1339 when RE_Not_Available
=>
1341 end Build_Master_Renaming
;
1343 ----------------------------
1344 -- Build_Record_Init_Proc --
1345 ----------------------------
1347 procedure Build_Record_Init_Proc
(N
: Node_Id
; Pe
: Entity_Id
) is
1348 Loc
: Source_Ptr
:= Sloc
(N
);
1349 Discr_Map
: constant Elist_Id
:= New_Elmt_List
;
1350 Proc_Id
: Entity_Id
;
1351 Rec_Type
: Entity_Id
;
1352 Set_Tag
: Entity_Id
:= Empty
;
1354 function Build_Assignment
(Id
: Entity_Id
; N
: Node_Id
) return List_Id
;
1355 -- Build a assignment statement node which assigns to record
1356 -- component its default expression if defined. The left hand side
1357 -- of the assignment is marked Assignment_OK so that initialization
1358 -- of limited private records works correctly, Return also the
1359 -- adjustment call for controlled objects
1361 procedure Build_Discriminant_Assignments
(Statement_List
: List_Id
);
1362 -- If the record has discriminants, adds assignment statements to
1363 -- statement list to initialize the discriminant values from the
1364 -- arguments of the initialization procedure.
1366 function Build_Init_Statements
(Comp_List
: Node_Id
) return List_Id
;
1367 -- Build a list representing a sequence of statements which initialize
1368 -- components of the given component list. This may involve building
1369 -- case statements for the variant parts.
1371 function Build_Init_Call_Thru
(Parameters
: List_Id
) return List_Id
;
1372 -- Given a non-tagged type-derivation that declares discriminants,
1375 -- type R (R1, R2 : Integer) is record ... end record;
1377 -- type D (D1 : Integer) is new R (1, D1);
1379 -- we make the _init_proc of D be
1381 -- procedure _init_proc(X : D; D1 : Integer) is
1383 -- _init_proc( R(X), 1, D1);
1386 -- This function builds the call statement in this _init_proc.
1388 procedure Build_Init_Procedure
;
1389 -- Build the tree corresponding to the procedure specification and body
1390 -- of the initialization procedure (by calling all the preceding
1391 -- auxiliary routines), and install it as the _init TSS.
1393 procedure Build_Record_Checks
(S
: Node_Id
; Check_List
: List_Id
);
1394 -- Add range checks to components of disciminated records. S is a
1395 -- subtype indication of a record component. Check_List is a list
1396 -- to which the check actions are appended.
1398 function Component_Needs_Simple_Initialization
1399 (T
: Entity_Id
) return Boolean;
1400 -- Determines if a component needs simple initialization, given its
1401 -- type T. This is the same as Needs_Simple_Initialization except
1402 -- for the following difference: the types Tag and Vtable_Ptr, which
1403 -- are access types which would normally require simple initialization
1404 -- to null, do not require initialization as components, since they
1405 -- are explicitly initialized by other means.
1407 procedure Constrain_Array
1409 Check_List
: List_Id
);
1410 -- Called from Build_Record_Checks.
1411 -- Apply a list of index constraints to an unconstrained array type.
1412 -- The first parameter is the entity for the resulting subtype.
1413 -- Check_List is a list to which the check actions are appended.
1415 procedure Constrain_Index
1418 Check_List
: List_Id
);
1419 -- Called from Build_Record_Checks.
1420 -- Process an index constraint in a constrained array declaration.
1421 -- The constraint can be a subtype name, or a range with or without
1422 -- an explicit subtype mark. The index is the corresponding index of the
1423 -- unconstrained array. S is the range expression. Check_List is a list
1424 -- to which the check actions are appended.
1426 function Parent_Subtype_Renaming_Discrims
return Boolean;
1427 -- Returns True for base types N that rename discriminants, else False
1429 function Requires_Init_Proc
(Rec_Id
: Entity_Id
) return Boolean;
1430 -- Determines whether a record initialization procedure needs to be
1431 -- generated for the given record type.
1433 ----------------------
1434 -- Build_Assignment --
1435 ----------------------
1437 function Build_Assignment
(Id
: Entity_Id
; N
: Node_Id
) return List_Id
is
1440 Typ
: constant Entity_Id
:= Underlying_Type
(Etype
(Id
));
1441 Kind
: Node_Kind
:= Nkind
(N
);
1447 Make_Selected_Component
(Loc
,
1448 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
1449 Selector_Name
=> New_Occurrence_Of
(Id
, Loc
));
1450 Set_Assignment_OK
(Lhs
);
1452 -- Case of an access attribute applied to the current instance.
1453 -- Replace the reference to the type by a reference to the actual
1454 -- object. (Note that this handles the case of the top level of
1455 -- the expression being given by such an attribute, but does not
1456 -- cover uses nested within an initial value expression. Nested
1457 -- uses are unlikely to occur in practice, but are theoretically
1458 -- possible. It is not clear how to handle them without fully
1459 -- traversing the expression. ???
1461 if Kind
= N_Attribute_Reference
1462 and then (Attribute_Name
(N
) = Name_Unchecked_Access
1464 Attribute_Name
(N
) = Name_Unrestricted_Access
)
1465 and then Is_Entity_Name
(Prefix
(N
))
1466 and then Is_Type
(Entity
(Prefix
(N
)))
1467 and then Entity
(Prefix
(N
)) = Rec_Type
1470 Make_Attribute_Reference
(Loc
,
1471 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
1472 Attribute_Name
=> Name_Unrestricted_Access
);
1475 -- Ada 2005 (AI-231): Generate conversion to the null-excluding
1476 -- type to force the corresponding run-time check.
1478 if Ada_Version
>= Ada_05
1479 and then Can_Never_Be_Null
(Etype
(Id
)) -- Lhs
1480 and then Present
(Etype
(Exp
))
1481 and then not Can_Never_Be_Null
(Etype
(Exp
))
1483 Rewrite
(Exp
, Convert_To
(Etype
(Id
), Relocate_Node
(Exp
)));
1484 Analyze_And_Resolve
(Exp
, Etype
(Id
));
1487 -- Take a copy of Exp to ensure that later copies of this
1488 -- component_declaration in derived types see the original tree,
1489 -- not a node rewritten during expansion of the init_proc.
1491 Exp
:= New_Copy_Tree
(Exp
);
1494 Make_Assignment_Statement
(Loc
,
1496 Expression
=> Exp
));
1498 Set_No_Ctrl_Actions
(First
(Res
));
1500 -- Adjust the tag if tagged (because of possible view conversions).
1501 -- Suppress the tag adjustment when Java_VM because JVM tags are
1502 -- represented implicitly in objects.
1504 if Is_Tagged_Type
(Typ
) and then not Java_VM
then
1506 Make_Assignment_Statement
(Loc
,
1508 Make_Selected_Component
(Loc
,
1509 Prefix
=> New_Copy_Tree
(Lhs
),
1511 New_Reference_To
(Tag_Component
(Typ
), Loc
)),
1514 Unchecked_Convert_To
(RTE
(RE_Tag
),
1515 New_Reference_To
(Access_Disp_Table
(Typ
), Loc
))));
1518 -- Adjust the component if controlled except if it is an
1519 -- aggregate that will be expanded inline
1521 if Kind
= N_Qualified_Expression
then
1522 Kind
:= Nkind
(Expression
(N
));
1525 if Controlled_Type
(Typ
)
1526 and then not (Kind
= N_Aggregate
or else Kind
= N_Extension_Aggregate
)
1528 Append_List_To
(Res
,
1530 Ref
=> New_Copy_Tree
(Lhs
),
1533 Find_Final_List
(Etype
(Id
), New_Copy_Tree
(Lhs
)),
1534 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
1540 when RE_Not_Available
=>
1542 end Build_Assignment
;
1544 ------------------------------------
1545 -- Build_Discriminant_Assignments --
1546 ------------------------------------
1548 procedure Build_Discriminant_Assignments
(Statement_List
: List_Id
) is
1550 Is_Tagged
: constant Boolean := Is_Tagged_Type
(Rec_Type
);
1553 if Has_Discriminants
(Rec_Type
)
1554 and then not Is_Unchecked_Union
(Rec_Type
)
1556 D
:= First_Discriminant
(Rec_Type
);
1558 while Present
(D
) loop
1559 -- Don't generate the assignment for discriminants in derived
1560 -- tagged types if the discriminant is a renaming of some
1561 -- ancestor discriminant. This initialization will be done
1562 -- when initializing the _parent field of the derived record.
1564 if Is_Tagged
and then
1565 Present
(Corresponding_Discriminant
(D
))
1571 Append_List_To
(Statement_List
,
1572 Build_Assignment
(D
,
1573 New_Reference_To
(Discriminal
(D
), Loc
)));
1576 Next_Discriminant
(D
);
1579 end Build_Discriminant_Assignments
;
1581 --------------------------
1582 -- Build_Init_Call_Thru --
1583 --------------------------
1585 function Build_Init_Call_Thru
(Parameters
: List_Id
) return List_Id
is
1586 Parent_Proc
: constant Entity_Id
:=
1587 Base_Init_Proc
(Etype
(Rec_Type
));
1589 Parent_Type
: constant Entity_Id
:=
1590 Etype
(First_Formal
(Parent_Proc
));
1592 Uparent_Type
: constant Entity_Id
:=
1593 Underlying_Type
(Parent_Type
);
1595 First_Discr_Param
: Node_Id
;
1597 Parent_Discr
: Entity_Id
;
1598 First_Arg
: Node_Id
;
1604 -- First argument (_Init) is the object to be initialized.
1605 -- ??? not sure where to get a reasonable Loc for First_Arg
1608 OK_Convert_To
(Parent_Type
,
1609 New_Reference_To
(Defining_Identifier
(First
(Parameters
)), Loc
));
1611 Set_Etype
(First_Arg
, Parent_Type
);
1613 Args
:= New_List
(Convert_Concurrent
(First_Arg
, Rec_Type
));
1615 -- In the tasks case,
1616 -- add _Master as the value of the _Master parameter
1617 -- add _Chain as the value of the _Chain parameter.
1618 -- add _Task_Name as the value of the _Task_Name parameter.
1619 -- At the outer level, these will be variables holding the
1620 -- corresponding values obtained from GNARL or the expander.
1622 -- At inner levels, they will be the parameters passed down through
1623 -- the outer routines.
1625 First_Discr_Param
:= Next
(First
(Parameters
));
1627 if Has_Task
(Rec_Type
) then
1628 if Restriction_Active
(No_Task_Hierarchy
) then
1630 -- See comments in System.Tasking.Initialization.Init_RTS
1633 Append_To
(Args
, Make_Integer_Literal
(Loc
, 3));
1635 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
1638 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
1639 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Name
));
1640 First_Discr_Param
:= Next
(Next
(Next
(First_Discr_Param
)));
1643 -- Append discriminant values
1645 if Has_Discriminants
(Uparent_Type
) then
1646 pragma Assert
(not Is_Tagged_Type
(Uparent_Type
));
1648 Parent_Discr
:= First_Discriminant
(Uparent_Type
);
1649 while Present
(Parent_Discr
) loop
1651 -- Get the initial value for this discriminant
1652 -- ??? needs to be cleaned up to use parent_Discr_Constr
1656 Discr_Value
: Elmt_Id
:=
1658 (Stored_Constraint
(Rec_Type
));
1660 Discr
: Entity_Id
:=
1661 First_Stored_Discriminant
(Uparent_Type
);
1663 while Original_Record_Component
(Parent_Discr
) /= Discr
loop
1664 Next_Stored_Discriminant
(Discr
);
1665 Next_Elmt
(Discr_Value
);
1668 Arg
:= Node
(Discr_Value
);
1671 -- Append it to the list
1673 if Nkind
(Arg
) = N_Identifier
1674 and then Ekind
(Entity
(Arg
)) = E_Discriminant
1677 New_Reference_To
(Discriminal
(Entity
(Arg
)), Loc
));
1679 -- Case of access discriminants. We replace the reference
1680 -- to the type by a reference to the actual object
1682 -- ??? why is this code deleted without comment
1684 -- elsif Nkind (Arg) = N_Attribute_Reference
1685 -- and then Is_Entity_Name (Prefix (Arg))
1686 -- and then Is_Type (Entity (Prefix (Arg)))
1689 -- Make_Attribute_Reference (Loc,
1690 -- Prefix => New_Copy (Prefix (Id_Ref)),
1691 -- Attribute_Name => Name_Unrestricted_Access));
1694 Append_To
(Args
, New_Copy
(Arg
));
1697 Next_Discriminant
(Parent_Discr
);
1703 Make_Procedure_Call_Statement
(Loc
,
1704 Name
=> New_Occurrence_Of
(Parent_Proc
, Loc
),
1705 Parameter_Associations
=> Args
));
1708 end Build_Init_Call_Thru
;
1710 --------------------------
1711 -- Build_Init_Procedure --
1712 --------------------------
1714 procedure Build_Init_Procedure
is
1715 Body_Node
: Node_Id
;
1716 Handled_Stmt_Node
: Node_Id
;
1717 Parameters
: List_Id
;
1718 Proc_Spec_Node
: Node_Id
;
1719 Body_Stmts
: List_Id
;
1720 Record_Extension_Node
: Node_Id
;
1724 Body_Stmts
:= New_List
;
1725 Body_Node
:= New_Node
(N_Subprogram_Body
, Loc
);
1728 Make_Defining_Identifier
(Loc
,
1729 Chars
=> Make_Init_Proc_Name
(Rec_Type
));
1730 Set_Ekind
(Proc_Id
, E_Procedure
);
1732 Proc_Spec_Node
:= New_Node
(N_Procedure_Specification
, Loc
);
1733 Set_Defining_Unit_Name
(Proc_Spec_Node
, Proc_Id
);
1735 Parameters
:= Init_Formals
(Rec_Type
);
1736 Append_List_To
(Parameters
,
1737 Build_Discriminant_Formals
(Rec_Type
, True));
1739 -- For tagged types, we add a flag to indicate whether the routine
1740 -- is called to initialize a parent component in the init_proc of
1741 -- a type extension. If the flag is false, we do not set the tag
1742 -- because it has been set already in the extension.
1744 if Is_Tagged_Type
(Rec_Type
)
1745 and then not Is_CPP_Class
(Rec_Type
)
1748 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
1750 Append_To
(Parameters
,
1751 Make_Parameter_Specification
(Loc
,
1752 Defining_Identifier
=> Set_Tag
,
1753 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
1754 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
1757 Set_Parameter_Specifications
(Proc_Spec_Node
, Parameters
);
1758 Set_Specification
(Body_Node
, Proc_Spec_Node
);
1759 Set_Declarations
(Body_Node
, New_List
);
1761 if Parent_Subtype_Renaming_Discrims
then
1763 -- N is a Derived_Type_Definition that renames the parameters
1764 -- of the ancestor type. We init it by expanding our discrims
1765 -- and call the ancestor _init_proc with a type-converted object
1767 Append_List_To
(Body_Stmts
,
1768 Build_Init_Call_Thru
(Parameters
));
1770 elsif Nkind
(Type_Definition
(N
)) = N_Record_Definition
then
1771 Build_Discriminant_Assignments
(Body_Stmts
);
1773 if not Null_Present
(Type_Definition
(N
)) then
1774 Append_List_To
(Body_Stmts
,
1775 Build_Init_Statements
(
1776 Component_List
(Type_Definition
(N
))));
1780 -- N is a Derived_Type_Definition with a possible non-empty
1781 -- extension. The initialization of a type extension consists
1782 -- in the initialization of the components in the extension.
1784 Build_Discriminant_Assignments
(Body_Stmts
);
1786 Record_Extension_Node
:=
1787 Record_Extension_Part
(Type_Definition
(N
));
1789 if not Null_Present
(Record_Extension_Node
) then
1791 Stmts
: constant List_Id
:=
1792 Build_Init_Statements
(
1793 Component_List
(Record_Extension_Node
));
1796 -- The parent field must be initialized first because
1797 -- the offset of the new discriminants may depend on it
1799 Prepend_To
(Body_Stmts
, Remove_Head
(Stmts
));
1800 Append_List_To
(Body_Stmts
, Stmts
);
1805 -- Add here the assignment to instantiate the Tag
1807 -- The assignement corresponds to the code:
1809 -- _Init._Tag := Typ'Tag;
1811 -- Suppress the tag assignment when Java_VM because JVM tags are
1812 -- represented implicitly in objects.
1814 if Is_Tagged_Type
(Rec_Type
)
1815 and then not Is_CPP_Class
(Rec_Type
)
1816 and then not Java_VM
1819 Make_Assignment_Statement
(Loc
,
1821 Make_Selected_Component
(Loc
,
1822 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
1824 New_Reference_To
(Tag_Component
(Rec_Type
), Loc
)),
1827 New_Reference_To
(Access_Disp_Table
(Rec_Type
), Loc
));
1829 -- The tag must be inserted before the assignments to other
1830 -- components, because the initial value of the component may
1831 -- depend ot the tag (eg. through a dispatching operation on
1832 -- an access to the current type). The tag assignment is not done
1833 -- when initializing the parent component of a type extension,
1834 -- because in that case the tag is set in the extension.
1835 -- Extensions of imported C++ classes add a final complication,
1836 -- because we cannot inhibit tag setting in the constructor for
1837 -- the parent. In that case we insert the tag initialization
1838 -- after the calls to initialize the parent.
1841 Make_If_Statement
(Loc
,
1842 Condition
=> New_Occurrence_Of
(Set_Tag
, Loc
),
1843 Then_Statements
=> New_List
(Init_Tag
));
1845 if not Is_CPP_Class
(Etype
(Rec_Type
)) then
1846 Prepend_To
(Body_Stmts
, Init_Tag
);
1850 Nod
: Node_Id
:= First
(Body_Stmts
);
1853 -- We assume the first init_proc call is for the parent
1855 while Present
(Next
(Nod
))
1856 and then (Nkind
(Nod
) /= N_Procedure_Call_Statement
1857 or else not Is_Init_Proc
(Name
(Nod
)))
1862 Insert_After
(Nod
, Init_Tag
);
1867 Handled_Stmt_Node
:= New_Node
(N_Handled_Sequence_Of_Statements
, Loc
);
1868 Set_Statements
(Handled_Stmt_Node
, Body_Stmts
);
1869 Set_Exception_Handlers
(Handled_Stmt_Node
, No_List
);
1870 Set_Handled_Statement_Sequence
(Body_Node
, Handled_Stmt_Node
);
1872 if not Debug_Generated_Code
then
1873 Set_Debug_Info_Off
(Proc_Id
);
1876 -- Associate Init_Proc with type, and determine if the procedure
1877 -- is null (happens because of the Initialize_Scalars pragma case,
1878 -- where we have to generate a null procedure in case it is called
1879 -- by a client with Initialize_Scalars set). Such procedures have
1880 -- to be generated, but do not have to be called, so we mark them
1881 -- as null to suppress the call.
1883 Set_Init_Proc
(Rec_Type
, Proc_Id
);
1885 if List_Length
(Body_Stmts
) = 1
1886 and then Nkind
(First
(Body_Stmts
)) = N_Null_Statement
1888 Set_Is_Null_Init_Proc
(Proc_Id
);
1890 end Build_Init_Procedure
;
1892 ---------------------------
1893 -- Build_Init_Statements --
1894 ---------------------------
1896 function Build_Init_Statements
(Comp_List
: Node_Id
) return List_Id
is
1897 Check_List
: constant List_Id
:= New_List
;
1899 Statement_List
: List_Id
;
1902 Per_Object_Constraint_Components
: Boolean;
1910 function Has_Access_Constraint
(E
: Entity_Id
) return Boolean;
1911 -- Components with access discriminants that depend on the current
1912 -- instance must be initialized after all other components.
1914 ---------------------------
1915 -- Has_Access_Constraint --
1916 ---------------------------
1918 function Has_Access_Constraint
(E
: Entity_Id
) return Boolean is
1920 T
: constant Entity_Id
:= Etype
(E
);
1923 if Has_Per_Object_Constraint
(E
)
1924 and then Has_Discriminants
(T
)
1926 Disc
:= First_Discriminant
(T
);
1927 while Present
(Disc
) loop
1928 if Is_Access_Type
(Etype
(Disc
)) then
1932 Next_Discriminant
(Disc
);
1939 end Has_Access_Constraint
;
1941 -- Start of processing for Build_Init_Statements
1944 if Null_Present
(Comp_List
) then
1945 return New_List
(Make_Null_Statement
(Loc
));
1948 Statement_List
:= New_List
;
1950 -- Loop through components, skipping pragmas, in 2 steps. The first
1951 -- step deals with regular components. The second step deals with
1952 -- components have per object constraints, and no explicit initia-
1955 Per_Object_Constraint_Components
:= False;
1957 -- First step : regular components
1959 Decl
:= First_Non_Pragma
(Component_Items
(Comp_List
));
1960 while Present
(Decl
) loop
1963 (Subtype_Indication
(Component_Definition
(Decl
)), Check_List
);
1965 Id
:= Defining_Identifier
(Decl
);
1968 if Has_Access_Constraint
(Id
)
1969 and then No
(Expression
(Decl
))
1971 -- Skip processing for now and ask for a second pass
1973 Per_Object_Constraint_Components
:= True;
1976 -- Case of explicit initialization
1978 if Present
(Expression
(Decl
)) then
1979 Stmts
:= Build_Assignment
(Id
, Expression
(Decl
));
1981 -- Case of composite component with its own Init_Proc
1983 elsif Has_Non_Null_Base_Init_Proc
(Typ
) then
1985 Build_Initialization_Call
1987 Make_Selected_Component
(Loc
,
1988 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
1989 Selector_Name
=> New_Occurrence_Of
(Id
, Loc
)),
1993 Discr_Map
=> Discr_Map
);
1995 -- Case of component needing simple initialization
1997 elsif Component_Needs_Simple_Initialization
(Typ
) then
1999 Build_Assignment
(Id
, Get_Simple_Init_Val
(Typ
, Loc
));
2001 -- Nothing needed for this case
2007 if Present
(Check_List
) then
2008 Append_List_To
(Statement_List
, Check_List
);
2011 if Present
(Stmts
) then
2013 -- Add the initialization of the record controller before
2014 -- the _Parent field is attached to it when the attachment
2015 -- can occur. It does not work to simply initialize the
2016 -- controller first: it must be initialized after the parent
2017 -- if the parent holds discriminants that can be used
2018 -- to compute the offset of the controller. We assume here
2019 -- that the last statement of the initialization call is the
2020 -- attachement of the parent (see Build_Initialization_Call)
2022 if Chars
(Id
) = Name_uController
2023 and then Rec_Type
/= Etype
(Rec_Type
)
2024 and then Has_Controlled_Component
(Etype
(Rec_Type
))
2025 and then Has_New_Controlled_Component
(Rec_Type
)
2027 Insert_List_Before
(Last
(Statement_List
), Stmts
);
2029 Append_List_To
(Statement_List
, Stmts
);
2034 Next_Non_Pragma
(Decl
);
2037 if Per_Object_Constraint_Components
then
2039 -- Second pass: components with per-object constraints
2041 Decl
:= First_Non_Pragma
(Component_Items
(Comp_List
));
2043 while Present
(Decl
) loop
2045 Id
:= Defining_Identifier
(Decl
);
2048 if Has_Access_Constraint
(Id
)
2049 and then No
(Expression
(Decl
))
2051 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2052 Append_List_To
(Statement_List
,
2053 Build_Initialization_Call
(Loc
,
2054 Make_Selected_Component
(Loc
,
2055 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2056 Selector_Name
=> New_Occurrence_Of
(Id
, Loc
)),
2057 Typ
, True, Rec_Type
, Discr_Map
=> Discr_Map
));
2059 elsif Component_Needs_Simple_Initialization
(Typ
) then
2060 Append_List_To
(Statement_List
,
2061 Build_Assignment
(Id
, Get_Simple_Init_Val
(Typ
, Loc
)));
2065 Next_Non_Pragma
(Decl
);
2069 -- Process the variant part
2071 if Present
(Variant_Part
(Comp_List
)) then
2072 Alt_List
:= New_List
;
2073 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
2075 while Present
(Variant
) loop
2076 Loc
:= Sloc
(Variant
);
2077 Append_To
(Alt_List
,
2078 Make_Case_Statement_Alternative
(Loc
,
2080 New_Copy_List
(Discrete_Choices
(Variant
)),
2082 Build_Init_Statements
(Component_List
(Variant
))));
2084 Next_Non_Pragma
(Variant
);
2087 -- The expression of the case statement which is a reference
2088 -- to one of the discriminants is replaced by the appropriate
2089 -- formal parameter of the initialization procedure.
2091 Append_To
(Statement_List
,
2092 Make_Case_Statement
(Loc
,
2094 New_Reference_To
(Discriminal
(
2095 Entity
(Name
(Variant_Part
(Comp_List
)))), Loc
),
2096 Alternatives
=> Alt_List
));
2099 -- For a task record type, add the task create call and calls
2100 -- to bind any interrupt (signal) entries.
2102 if Is_Task_Record_Type
(Rec_Type
) then
2104 -- In the case of the restricted run time the ATCB has already
2105 -- been preallocated.
2107 if Restricted_Profile
then
2108 Append_To
(Statement_List
,
2109 Make_Assignment_Statement
(Loc
,
2110 Name
=> Make_Selected_Component
(Loc
,
2111 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2112 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
2113 Expression
=> Make_Attribute_Reference
(Loc
,
2115 Make_Selected_Component
(Loc
,
2116 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2118 Make_Identifier
(Loc
, Name_uATCB
)),
2119 Attribute_Name
=> Name_Unchecked_Access
)));
2122 Append_To
(Statement_List
, Make_Task_Create_Call
(Rec_Type
));
2125 Task_Type
: constant Entity_Id
:=
2126 Corresponding_Concurrent_Type
(Rec_Type
);
2127 Task_Decl
: constant Node_Id
:= Parent
(Task_Type
);
2128 Task_Def
: constant Node_Id
:= Task_Definition
(Task_Decl
);
2133 if Present
(Task_Def
) then
2134 Vis_Decl
:= First
(Visible_Declarations
(Task_Def
));
2135 while Present
(Vis_Decl
) loop
2136 Loc
:= Sloc
(Vis_Decl
);
2138 if Nkind
(Vis_Decl
) = N_Attribute_Definition_Clause
then
2139 if Get_Attribute_Id
(Chars
(Vis_Decl
)) =
2142 Ent
:= Entity
(Name
(Vis_Decl
));
2144 if Ekind
(Ent
) = E_Entry
then
2145 Append_To
(Statement_List
,
2146 Make_Procedure_Call_Statement
(Loc
,
2147 Name
=> New_Reference_To
(
2148 RTE
(RE_Bind_Interrupt_To_Entry
), Loc
),
2149 Parameter_Associations
=> New_List
(
2150 Make_Selected_Component
(Loc
,
2152 Make_Identifier
(Loc
, Name_uInit
),
2154 Make_Identifier
(Loc
, Name_uTask_Id
)),
2155 Entry_Index_Expression
(
2156 Loc
, Ent
, Empty
, Task_Type
),
2157 Expression
(Vis_Decl
))));
2168 -- For a protected type, add statements generated by
2169 -- Make_Initialize_Protection.
2171 if Is_Protected_Record_Type
(Rec_Type
) then
2172 Append_List_To
(Statement_List
,
2173 Make_Initialize_Protection
(Rec_Type
));
2176 -- If no initializations when generated for component declarations
2177 -- corresponding to this Statement_List, append a null statement
2178 -- to the Statement_List to make it a valid Ada tree.
2180 if Is_Empty_List
(Statement_List
) then
2181 Append
(New_Node
(N_Null_Statement
, Loc
), Statement_List
);
2184 return Statement_List
;
2187 when RE_Not_Available
=>
2189 end Build_Init_Statements
;
2191 -------------------------
2192 -- Build_Record_Checks --
2193 -------------------------
2195 procedure Build_Record_Checks
(S
: Node_Id
; Check_List
: List_Id
) is
2196 Subtype_Mark_Id
: Entity_Id
;
2199 if Nkind
(S
) = N_Subtype_Indication
then
2200 Find_Type
(Subtype_Mark
(S
));
2201 Subtype_Mark_Id
:= Entity
(Subtype_Mark
(S
));
2203 -- Remaining processing depends on type
2205 case Ekind
(Subtype_Mark_Id
) is
2208 Constrain_Array
(S
, Check_List
);
2214 end Build_Record_Checks
;
2216 -------------------------------------------
2217 -- Component_Needs_Simple_Initialization --
2218 -------------------------------------------
2220 function Component_Needs_Simple_Initialization
2221 (T
: Entity_Id
) return Boolean
2225 Needs_Simple_Initialization
(T
)
2226 and then not Is_RTE
(T
, RE_Tag
)
2227 and then not Is_RTE
(T
, RE_Vtable_Ptr
);
2228 end Component_Needs_Simple_Initialization
;
2230 ---------------------
2231 -- Constrain_Array --
2232 ---------------------
2234 procedure Constrain_Array
2236 Check_List
: List_Id
)
2238 C
: constant Node_Id
:= Constraint
(SI
);
2239 Number_Of_Constraints
: Nat
:= 0;
2244 T
:= Entity
(Subtype_Mark
(SI
));
2246 if Ekind
(T
) in Access_Kind
then
2247 T
:= Designated_Type
(T
);
2250 S
:= First
(Constraints
(C
));
2252 while Present
(S
) loop
2253 Number_Of_Constraints
:= Number_Of_Constraints
+ 1;
2257 -- In either case, the index constraint must provide a discrete
2258 -- range for each index of the array type and the type of each
2259 -- discrete range must be the same as that of the corresponding
2260 -- index. (RM 3.6.1)
2262 S
:= First
(Constraints
(C
));
2263 Index
:= First_Index
(T
);
2266 -- Apply constraints to each index type
2268 for J
in 1 .. Number_Of_Constraints
loop
2269 Constrain_Index
(Index
, S
, Check_List
);
2274 end Constrain_Array
;
2276 ---------------------
2277 -- Constrain_Index --
2278 ---------------------
2280 procedure Constrain_Index
2283 Check_List
: List_Id
)
2285 T
: constant Entity_Id
:= Etype
(Index
);
2288 if Nkind
(S
) = N_Range
then
2289 Process_Range_Expr_In_Decl
(S
, T
, Check_List
);
2291 end Constrain_Index
;
2293 --------------------------------------
2294 -- Parent_Subtype_Renaming_Discrims --
2295 --------------------------------------
2297 function Parent_Subtype_Renaming_Discrims
return Boolean is
2302 if Base_Type
(Pe
) /= Pe
then
2307 or else not Has_Discriminants
(Pe
)
2308 or else Is_Constrained
(Pe
)
2309 or else Is_Tagged_Type
(Pe
)
2314 -- If there are no explicit stored discriminants we have inherited
2315 -- the root type discriminants so far, so no renamings occurred.
2317 if First_Discriminant
(Pe
) = First_Stored_Discriminant
(Pe
) then
2321 -- Check if we have done some trivial renaming of the parent
2322 -- discriminants, i.e. someting like
2324 -- type DT (X1,X2: int) is new PT (X1,X2);
2326 De
:= First_Discriminant
(Pe
);
2327 Dp
:= First_Discriminant
(Etype
(Pe
));
2329 while Present
(De
) loop
2330 pragma Assert
(Present
(Dp
));
2332 if Corresponding_Discriminant
(De
) /= Dp
then
2336 Next_Discriminant
(De
);
2337 Next_Discriminant
(Dp
);
2340 return Present
(Dp
);
2341 end Parent_Subtype_Renaming_Discrims
;
2343 ------------------------
2344 -- Requires_Init_Proc --
2345 ------------------------
2347 function Requires_Init_Proc
(Rec_Id
: Entity_Id
) return Boolean is
2348 Comp_Decl
: Node_Id
;
2353 -- Definitely do not need one if specifically suppressed
2355 if Suppress_Init_Proc
(Rec_Id
) then
2359 -- Otherwise we need to generate an initialization procedure if
2360 -- Is_CPP_Class is False and at least one of the following applies:
2362 -- 1. Discriminants are present, since they need to be initialized
2363 -- with the appropriate discriminant constraint expressions.
2364 -- However, the discriminant of an unchecked union does not
2365 -- count, since the discriminant is not present.
2367 -- 2. The type is a tagged type, since the implicit Tag component
2368 -- needs to be initialized with a pointer to the dispatch table.
2370 -- 3. The type contains tasks
2372 -- 4. One or more components has an initial value
2374 -- 5. One or more components is for a type which itself requires
2375 -- an initialization procedure.
2377 -- 6. One or more components is a type that requires simple
2378 -- initialization (see Needs_Simple_Initialization), except
2379 -- that types Tag and Vtable_Ptr are excluded, since fields
2380 -- of these types are initialized by other means.
2382 -- 7. The type is the record type built for a task type (since at
2383 -- the very least, Create_Task must be called)
2385 -- 8. The type is the record type built for a protected type (since
2386 -- at least Initialize_Protection must be called)
2388 -- 9. The type is marked as a public entity. The reason we add this
2389 -- case (even if none of the above apply) is to properly handle
2390 -- Initialize_Scalars. If a package is compiled without an IS
2391 -- pragma, and the client is compiled with an IS pragma, then
2392 -- the client will think an initialization procedure is present
2393 -- and call it, when in fact no such procedure is required, but
2394 -- since the call is generated, there had better be a routine
2395 -- at the other end of the call, even if it does nothing!)
2397 -- Note: the reason we exclude the CPP_Class case is ???
2399 if Is_CPP_Class
(Rec_Id
) then
2402 elsif not Restriction_Active
(No_Initialize_Scalars
)
2403 and then Is_Public
(Rec_Id
)
2407 elsif (Has_Discriminants
(Rec_Id
)
2408 and then not Is_Unchecked_Union
(Rec_Id
))
2409 or else Is_Tagged_Type
(Rec_Id
)
2410 or else Is_Concurrent_Record_Type
(Rec_Id
)
2411 or else Has_Task
(Rec_Id
)
2416 Id
:= First_Component
(Rec_Id
);
2418 while Present
(Id
) loop
2419 Comp_Decl
:= Parent
(Id
);
2422 if Present
(Expression
(Comp_Decl
))
2423 or else Has_Non_Null_Base_Init_Proc
(Typ
)
2424 or else Component_Needs_Simple_Initialization
(Typ
)
2429 Next_Component
(Id
);
2433 end Requires_Init_Proc
;
2435 -- Start of processing for Build_Record_Init_Proc
2438 Rec_Type
:= Defining_Identifier
(N
);
2440 -- This may be full declaration of a private type, in which case
2441 -- the visible entity is a record, and the private entity has been
2442 -- exchanged with it in the private part of the current package.
2443 -- The initialization procedure is built for the record type, which
2444 -- is retrievable from the private entity.
2446 if Is_Incomplete_Or_Private_Type
(Rec_Type
) then
2447 Rec_Type
:= Underlying_Type
(Rec_Type
);
2450 -- If there are discriminants, build the discriminant map to replace
2451 -- discriminants by their discriminals in complex bound expressions.
2452 -- These only arise for the corresponding records of protected types.
2454 if Is_Concurrent_Record_Type
(Rec_Type
)
2455 and then Has_Discriminants
(Rec_Type
)
2461 Disc
:= First_Discriminant
(Rec_Type
);
2463 while Present
(Disc
) loop
2464 Append_Elmt
(Disc
, Discr_Map
);
2465 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
2466 Next_Discriminant
(Disc
);
2471 -- Derived types that have no type extension can use the initialization
2472 -- procedure of their parent and do not need a procedure of their own.
2473 -- This is only correct if there are no representation clauses for the
2474 -- type or its parent, and if the parent has in fact been frozen so
2475 -- that its initialization procedure exists.
2477 if Is_Derived_Type
(Rec_Type
)
2478 and then not Is_Tagged_Type
(Rec_Type
)
2479 and then not Is_Unchecked_Union
(Rec_Type
)
2480 and then not Has_New_Non_Standard_Rep
(Rec_Type
)
2481 and then not Parent_Subtype_Renaming_Discrims
2482 and then Has_Non_Null_Base_Init_Proc
(Etype
(Rec_Type
))
2484 Copy_TSS
(Base_Init_Proc
(Etype
(Rec_Type
)), Rec_Type
);
2486 -- Otherwise if we need an initialization procedure, then build one,
2487 -- mark it as public and inlinable and as having a completion.
2489 elsif Requires_Init_Proc
(Rec_Type
)
2490 or else Is_Unchecked_Union
(Rec_Type
)
2492 Build_Init_Procedure
;
2493 Set_Is_Public
(Proc_Id
, Is_Public
(Pe
));
2495 -- The initialization of protected records is not worth inlining.
2496 -- In addition, when compiled for another unit for inlining purposes,
2497 -- it may make reference to entities that have not been elaborated
2498 -- yet. The initialization of controlled records contains a nested
2499 -- clean-up procedure that makes it impractical to inline as well,
2500 -- and leads to undefined symbols if inlined in a different unit.
2501 -- Similar considerations apply to task types.
2503 if not Is_Concurrent_Type
(Rec_Type
)
2504 and then not Has_Task
(Rec_Type
)
2505 and then not Controlled_Type
(Rec_Type
)
2507 Set_Is_Inlined
(Proc_Id
);
2510 Set_Is_Internal
(Proc_Id
);
2511 Set_Has_Completion
(Proc_Id
);
2513 if not Debug_Generated_Code
then
2514 Set_Debug_Info_Off
(Proc_Id
);
2517 end Build_Record_Init_Proc
;
2519 ----------------------------
2520 -- Build_Slice_Assignment --
2521 ----------------------------
2523 -- Generates the following subprogram:
2526 -- (Source, Target : Array_Type,
2527 -- Left_Lo, Left_Hi, Right_Lo, Right_Hi : Index;
2544 -- exit when Li1 < Left_Lo;
2546 -- exit when Li1 > Left_Hi;
2549 -- Target (Li1) := Source (Ri1);
2552 -- Li1 := Index'pred (Li1);
2553 -- Ri1 := Index'pred (Ri1);
2555 -- Li1 := Index'succ (Li1);
2556 -- Ri1 := Index'succ (Ri1);
2561 procedure Build_Slice_Assignment
(Typ
: Entity_Id
) is
2562 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2563 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
2565 -- Build formal parameters of procedure
2567 Larray
: constant Entity_Id
:=
2568 Make_Defining_Identifier
2569 (Loc
, Chars
=> New_Internal_Name
('A'));
2570 Rarray
: constant Entity_Id
:=
2571 Make_Defining_Identifier
2572 (Loc
, Chars
=> New_Internal_Name
('R'));
2573 Left_Lo
: constant Entity_Id
:=
2574 Make_Defining_Identifier
2575 (Loc
, Chars
=> New_Internal_Name
('L'));
2576 Left_Hi
: constant Entity_Id
:=
2577 Make_Defining_Identifier
2578 (Loc
, Chars
=> New_Internal_Name
('L'));
2579 Right_Lo
: constant Entity_Id
:=
2580 Make_Defining_Identifier
2581 (Loc
, Chars
=> New_Internal_Name
('R'));
2582 Right_Hi
: constant Entity_Id
:=
2583 Make_Defining_Identifier
2584 (Loc
, Chars
=> New_Internal_Name
('R'));
2585 Rev
: constant Entity_Id
:=
2586 Make_Defining_Identifier
2587 (Loc
, Chars
=> New_Internal_Name
('D'));
2588 Proc_Name
: constant Entity_Id
:=
2589 Make_Defining_Identifier
(Loc
,
2590 Chars
=> Make_TSS_Name
(Typ
, TSS_Slice_Assign
));
2592 Lnn
: constant Entity_Id
:=
2593 Make_Defining_Identifier
(Loc
, New_Internal_Name
('L'));
2594 Rnn
: constant Entity_Id
:=
2595 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
2596 -- Subscripts for left and right sides
2603 -- Build declarations for indices
2608 Make_Object_Declaration
(Loc
,
2609 Defining_Identifier
=> Lnn
,
2610 Object_Definition
=>
2611 New_Occurrence_Of
(Index
, Loc
)));
2614 Make_Object_Declaration
(Loc
,
2615 Defining_Identifier
=> Rnn
,
2616 Object_Definition
=>
2617 New_Occurrence_Of
(Index
, Loc
)));
2621 -- Build initializations for indices
2624 F_Init
: constant List_Id
:= New_List
;
2625 B_Init
: constant List_Id
:= New_List
;
2629 Make_Assignment_Statement
(Loc
,
2630 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
2631 Expression
=> New_Occurrence_Of
(Left_Lo
, Loc
)));
2634 Make_Assignment_Statement
(Loc
,
2635 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
2636 Expression
=> New_Occurrence_Of
(Right_Lo
, Loc
)));
2639 Make_Assignment_Statement
(Loc
,
2640 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
2641 Expression
=> New_Occurrence_Of
(Left_Hi
, Loc
)));
2644 Make_Assignment_Statement
(Loc
,
2645 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
2646 Expression
=> New_Occurrence_Of
(Right_Hi
, Loc
)));
2649 Make_If_Statement
(Loc
,
2650 Condition
=> New_Occurrence_Of
(Rev
, Loc
),
2651 Then_Statements
=> B_Init
,
2652 Else_Statements
=> F_Init
));
2655 -- Now construct the assignment statement
2658 Make_Loop_Statement
(Loc
,
2659 Statements
=> New_List
(
2660 Make_Assignment_Statement
(Loc
,
2662 Make_Indexed_Component
(Loc
,
2663 Prefix
=> New_Occurrence_Of
(Larray
, Loc
),
2664 Expressions
=> New_List
(New_Occurrence_Of
(Lnn
, Loc
))),
2666 Make_Indexed_Component
(Loc
,
2667 Prefix
=> New_Occurrence_Of
(Rarray
, Loc
),
2668 Expressions
=> New_List
(New_Occurrence_Of
(Rnn
, Loc
))))),
2669 End_Label
=> Empty
);
2671 -- Build exit condition
2674 F_Ass
: constant List_Id
:= New_List
;
2675 B_Ass
: constant List_Id
:= New_List
;
2679 Make_Exit_Statement
(Loc
,
2682 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
2683 Right_Opnd
=> New_Occurrence_Of
(Left_Hi
, Loc
))));
2686 Make_Exit_Statement
(Loc
,
2689 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
2690 Right_Opnd
=> New_Occurrence_Of
(Left_Lo
, Loc
))));
2692 Prepend_To
(Statements
(Loops
),
2693 Make_If_Statement
(Loc
,
2694 Condition
=> New_Occurrence_Of
(Rev
, Loc
),
2695 Then_Statements
=> B_Ass
,
2696 Else_Statements
=> F_Ass
));
2699 -- Build the increment/decrement statements
2702 F_Ass
: constant List_Id
:= New_List
;
2703 B_Ass
: constant List_Id
:= New_List
;
2707 Make_Assignment_Statement
(Loc
,
2708 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
2710 Make_Attribute_Reference
(Loc
,
2712 New_Occurrence_Of
(Index
, Loc
),
2713 Attribute_Name
=> Name_Succ
,
2714 Expressions
=> New_List
(
2715 New_Occurrence_Of
(Lnn
, Loc
)))));
2718 Make_Assignment_Statement
(Loc
,
2719 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
2721 Make_Attribute_Reference
(Loc
,
2723 New_Occurrence_Of
(Index
, Loc
),
2724 Attribute_Name
=> Name_Succ
,
2725 Expressions
=> New_List
(
2726 New_Occurrence_Of
(Rnn
, Loc
)))));
2729 Make_Assignment_Statement
(Loc
,
2730 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
2732 Make_Attribute_Reference
(Loc
,
2734 New_Occurrence_Of
(Index
, Loc
),
2735 Attribute_Name
=> Name_Pred
,
2736 Expressions
=> New_List
(
2737 New_Occurrence_Of
(Lnn
, Loc
)))));
2740 Make_Assignment_Statement
(Loc
,
2741 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
2743 Make_Attribute_Reference
(Loc
,
2745 New_Occurrence_Of
(Index
, Loc
),
2746 Attribute_Name
=> Name_Pred
,
2747 Expressions
=> New_List
(
2748 New_Occurrence_Of
(Rnn
, Loc
)))));
2750 Append_To
(Statements
(Loops
),
2751 Make_If_Statement
(Loc
,
2752 Condition
=> New_Occurrence_Of
(Rev
, Loc
),
2753 Then_Statements
=> B_Ass
,
2754 Else_Statements
=> F_Ass
));
2757 Append_To
(Stats
, Loops
);
2761 Formals
: List_Id
:= New_List
;
2764 Formals
:= New_List
(
2765 Make_Parameter_Specification
(Loc
,
2766 Defining_Identifier
=> Larray
,
2767 Out_Present
=> True,
2769 New_Reference_To
(Base_Type
(Typ
), Loc
)),
2771 Make_Parameter_Specification
(Loc
,
2772 Defining_Identifier
=> Rarray
,
2774 New_Reference_To
(Base_Type
(Typ
), Loc
)),
2776 Make_Parameter_Specification
(Loc
,
2777 Defining_Identifier
=> Left_Lo
,
2779 New_Reference_To
(Index
, Loc
)),
2781 Make_Parameter_Specification
(Loc
,
2782 Defining_Identifier
=> Left_Hi
,
2784 New_Reference_To
(Index
, Loc
)),
2786 Make_Parameter_Specification
(Loc
,
2787 Defining_Identifier
=> Right_Lo
,
2789 New_Reference_To
(Index
, Loc
)),
2791 Make_Parameter_Specification
(Loc
,
2792 Defining_Identifier
=> Right_Hi
,
2794 New_Reference_To
(Index
, Loc
)));
2797 Make_Parameter_Specification
(Loc
,
2798 Defining_Identifier
=> Rev
,
2800 New_Reference_To
(Standard_Boolean
, Loc
)));
2803 Make_Procedure_Specification
(Loc
,
2804 Defining_Unit_Name
=> Proc_Name
,
2805 Parameter_Specifications
=> Formals
);
2808 Make_Subprogram_Body
(Loc
,
2809 Specification
=> Spec
,
2810 Declarations
=> Decls
,
2811 Handled_Statement_Sequence
=>
2812 Make_Handled_Sequence_Of_Statements
(Loc
,
2813 Statements
=> Stats
)));
2816 Set_TSS
(Typ
, Proc_Name
);
2817 Set_Is_Pure
(Proc_Name
);
2818 end Build_Slice_Assignment
;
2820 ------------------------------------
2821 -- Build_Variant_Record_Equality --
2822 ------------------------------------
2826 -- function _Equality (X, Y : T) return Boolean is
2828 -- -- Compare discriminants
2830 -- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then
2834 -- -- Compare components
2836 -- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then
2840 -- -- Compare variant part
2844 -- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then
2849 -- if False or else X.Cn /= Y.Cn then
2856 procedure Build_Variant_Record_Equality
(Typ
: Entity_Id
) is
2857 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2859 F
: constant Entity_Id
:=
2860 Make_Defining_Identifier
(Loc
,
2861 Chars
=> Make_TSS_Name
(Typ
, TSS_Composite_Equality
));
2863 X
: constant Entity_Id
:=
2864 Make_Defining_Identifier
(Loc
,
2867 Y
: constant Entity_Id
:=
2868 Make_Defining_Identifier
(Loc
,
2871 Def
: constant Node_Id
:= Parent
(Typ
);
2872 Comps
: constant Node_Id
:= Component_List
(Type_Definition
(Def
));
2873 Stmts
: constant List_Id
:= New_List
;
2874 Pspecs
: constant List_Id
:= New_List
;
2877 -- Derived Unchecked_Union types no longer inherit the equality function
2880 if Is_Derived_Type
(Typ
)
2881 and then not Is_Unchecked_Union
(Typ
)
2882 and then not Has_New_Non_Standard_Rep
(Typ
)
2885 Parent_Eq
: constant Entity_Id
:=
2886 TSS
(Root_Type
(Typ
), TSS_Composite_Equality
);
2889 if Present
(Parent_Eq
) then
2890 Copy_TSS
(Parent_Eq
, Typ
);
2897 Make_Subprogram_Body
(Loc
,
2899 Make_Function_Specification
(Loc
,
2900 Defining_Unit_Name
=> F
,
2901 Parameter_Specifications
=> Pspecs
,
2902 Subtype_Mark
=> New_Reference_To
(Standard_Boolean
, Loc
)),
2903 Declarations
=> New_List
,
2904 Handled_Statement_Sequence
=>
2905 Make_Handled_Sequence_Of_Statements
(Loc
,
2906 Statements
=> Stmts
)));
2909 Make_Parameter_Specification
(Loc
,
2910 Defining_Identifier
=> X
,
2911 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
2914 Make_Parameter_Specification
(Loc
,
2915 Defining_Identifier
=> Y
,
2916 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
2918 -- Unchecked_Unions require additional machinery to support equality.
2919 -- Two extra parameters (A and B) are added to the equality function
2920 -- parameter list in order to capture the inferred values of the
2921 -- discriminants in later calls.
2923 if Is_Unchecked_Union
(Typ
) then
2925 Discr_Type
: constant Node_Id
:= Etype
(First_Discriminant
(Typ
));
2927 A
: constant Node_Id
:=
2928 Make_Defining_Identifier
(Loc
,
2931 B
: constant Node_Id
:=
2932 Make_Defining_Identifier
(Loc
,
2936 -- Add A and B to the parameter list
2939 Make_Parameter_Specification
(Loc
,
2940 Defining_Identifier
=> A
,
2941 Parameter_Type
=> New_Reference_To
(Discr_Type
, Loc
)));
2944 Make_Parameter_Specification
(Loc
,
2945 Defining_Identifier
=> B
,
2946 Parameter_Type
=> New_Reference_To
(Discr_Type
, Loc
)));
2948 -- Generate the following header code to compare the inferred
2956 Make_If_Statement
(Loc
,
2959 Left_Opnd
=> New_Reference_To
(A
, Loc
),
2960 Right_Opnd
=> New_Reference_To
(B
, Loc
)),
2961 Then_Statements
=> New_List
(
2962 Make_Return_Statement
(Loc
,
2963 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
2965 -- Generate component-by-component comparison. Note that we must
2966 -- propagate one of the inferred discriminant formals to act as
2967 -- the case statement switch.
2969 Append_List_To
(Stmts
,
2970 Make_Eq_Case
(Typ
, Comps
, A
));
2974 -- Normal case (not unchecked union)
2979 Discriminant_Specifications
(Def
)));
2981 Append_List_To
(Stmts
,
2982 Make_Eq_Case
(Typ
, Comps
));
2986 Make_Return_Statement
(Loc
,
2987 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
2992 if not Debug_Generated_Code
then
2993 Set_Debug_Info_Off
(F
);
2995 end Build_Variant_Record_Equality
;
2997 -----------------------------
2998 -- Check_Stream_Attributes --
2999 -----------------------------
3001 procedure Check_Stream_Attributes
(Typ
: Entity_Id
) is
3003 Par
: constant Entity_Id
:= Root_Type
(Base_Type
(Typ
));
3004 Par_Read
: constant Boolean := Present
(TSS
(Par
, TSS_Stream_Read
));
3005 Par_Write
: constant Boolean := Present
(TSS
(Par
, TSS_Stream_Write
));
3008 if Par_Read
or else Par_Write
then
3009 Comp
:= First_Component
(Typ
);
3010 while Present
(Comp
) loop
3011 if Comes_From_Source
(Comp
)
3012 and then Original_Record_Component
(Comp
) = Comp
3013 and then Is_Limited_Type
(Etype
(Comp
))
3015 if (Par_Read
and then
3016 No
(TSS
(Base_Type
(Etype
(Comp
)), TSS_Stream_Read
)))
3019 No
(TSS
(Base_Type
(Etype
(Comp
)), TSS_Stream_Write
)))
3022 ("|component must have Stream attribute",
3027 Next_Component
(Comp
);
3030 end Check_Stream_Attributes
;
3032 -----------------------------
3033 -- Expand_Record_Extension --
3034 -----------------------------
3036 -- Add a field _parent at the beginning of the record extension. This is
3037 -- used to implement inheritance. Here are some examples of expansion:
3039 -- 1. no discriminants
3040 -- type T2 is new T1 with null record;
3042 -- type T2 is new T1 with record
3046 -- 2. renamed discriminants
3047 -- type T2 (B, C : Int) is new T1 (A => B) with record
3048 -- _Parent : T1 (A => B);
3052 -- 3. inherited discriminants
3053 -- type T2 is new T1 with record -- discriminant A inherited
3054 -- _Parent : T1 (A);
3058 procedure Expand_Record_Extension
(T
: Entity_Id
; Def
: Node_Id
) is
3059 Indic
: constant Node_Id
:= Subtype_Indication
(Def
);
3060 Loc
: constant Source_Ptr
:= Sloc
(Def
);
3061 Rec_Ext_Part
: Node_Id
:= Record_Extension_Part
(Def
);
3062 Par_Subtype
: Entity_Id
;
3063 Comp_List
: Node_Id
;
3064 Comp_Decl
: Node_Id
;
3067 List_Constr
: constant List_Id
:= New_List
;
3070 -- Expand_Record_Extension is called directly from the semantics, so
3071 -- we must check to see whether expansion is active before proceeding
3073 if not Expander_Active
then
3077 -- This may be a derivation of an untagged private type whose full
3078 -- view is tagged, in which case the Derived_Type_Definition has no
3079 -- extension part. Build an empty one now.
3081 if No
(Rec_Ext_Part
) then
3083 Make_Record_Definition
(Loc
,
3085 Component_List
=> Empty
,
3086 Null_Present
=> True);
3088 Set_Record_Extension_Part
(Def
, Rec_Ext_Part
);
3089 Mark_Rewrite_Insertion
(Rec_Ext_Part
);
3092 Comp_List
:= Component_List
(Rec_Ext_Part
);
3094 Parent_N
:= Make_Defining_Identifier
(Loc
, Name_uParent
);
3096 -- If the derived type inherits its discriminants the type of the
3097 -- _parent field must be constrained by the inherited discriminants
3099 if Has_Discriminants
(T
)
3100 and then Nkind
(Indic
) /= N_Subtype_Indication
3101 and then not Is_Constrained
(Entity
(Indic
))
3103 D
:= First_Discriminant
(T
);
3104 while Present
(D
) loop
3105 Append_To
(List_Constr
, New_Occurrence_Of
(D
, Loc
));
3106 Next_Discriminant
(D
);
3111 Make_Subtype_Indication
(Loc
,
3112 Subtype_Mark
=> New_Reference_To
(Entity
(Indic
), Loc
),
3114 Make_Index_Or_Discriminant_Constraint
(Loc
,
3115 Constraints
=> List_Constr
)),
3118 -- Otherwise the original subtype_indication is just what is needed
3121 Par_Subtype
:= Process_Subtype
(New_Copy_Tree
(Indic
), Def
);
3124 Set_Parent_Subtype
(T
, Par_Subtype
);
3127 Make_Component_Declaration
(Loc
,
3128 Defining_Identifier
=> Parent_N
,
3129 Component_Definition
=>
3130 Make_Component_Definition
(Loc
,
3131 Aliased_Present
=> False,
3132 Subtype_Indication
=> New_Reference_To
(Par_Subtype
, Loc
)));
3134 if Null_Present
(Rec_Ext_Part
) then
3135 Set_Component_List
(Rec_Ext_Part
,
3136 Make_Component_List
(Loc
,
3137 Component_Items
=> New_List
(Comp_Decl
),
3138 Variant_Part
=> Empty
,
3139 Null_Present
=> False));
3140 Set_Null_Present
(Rec_Ext_Part
, False);
3142 elsif Null_Present
(Comp_List
)
3143 or else Is_Empty_List
(Component_Items
(Comp_List
))
3145 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
3146 Set_Null_Present
(Comp_List
, False);
3149 Insert_Before
(First
(Component_Items
(Comp_List
)), Comp_Decl
);
3152 Analyze
(Comp_Decl
);
3153 end Expand_Record_Extension
;
3155 ------------------------------------
3156 -- Expand_N_Full_Type_Declaration --
3157 ------------------------------------
3159 procedure Expand_N_Full_Type_Declaration
(N
: Node_Id
) is
3160 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
3161 B_Id
: constant Entity_Id
:= Base_Type
(Def_Id
);
3166 if Is_Access_Type
(Def_Id
) then
3168 -- Anonymous access types are created for the components of the
3169 -- record parameter for an entry declaration. No master is created
3172 if Has_Task
(Designated_Type
(Def_Id
))
3173 and then Comes_From_Source
(N
)
3175 Build_Master_Entity
(Def_Id
);
3176 Build_Master_Renaming
(Parent
(Def_Id
), Def_Id
);
3178 -- Create a class-wide master because a Master_Id must be generated
3179 -- for access-to-limited-class-wide types, whose root may be extended
3180 -- with task components.
3182 elsif Is_Class_Wide_Type
(Designated_Type
(Def_Id
))
3183 and then Is_Limited_Type
(Designated_Type
(Def_Id
))
3184 and then Tasking_Allowed
3186 -- Don't create a class-wide master for types whose convention is
3187 -- Java since these types cannot embed Ada tasks anyway. Note that
3188 -- the following test cannot catch the following case:
3190 -- package java.lang.Object is
3191 -- type Typ is tagged limited private;
3192 -- type Ref is access all Typ'Class;
3194 -- type Typ is tagged limited ...;
3195 -- pragma Convention (Typ, Java)
3198 -- Because the convention appears after we have done the
3199 -- processing for type Ref.
3201 and then Convention
(Designated_Type
(Def_Id
)) /= Convention_Java
3203 Build_Class_Wide_Master
(Def_Id
);
3205 elsif Ekind
(Def_Id
) = E_Access_Protected_Subprogram_Type
then
3206 Expand_Access_Protected_Subprogram_Type
(N
);
3209 elsif Has_Task
(Def_Id
) then
3210 Expand_Previous_Access_Type
(Def_Id
);
3213 Par_Id
:= Etype
(B_Id
);
3215 -- The parent type is private then we need to inherit
3216 -- any TSS operations from the full view.
3218 if Ekind
(Par_Id
) in Private_Kind
3219 and then Present
(Full_View
(Par_Id
))
3221 Par_Id
:= Base_Type
(Full_View
(Par_Id
));
3224 if Nkind
(Type_Definition
(Original_Node
(N
)))
3225 = N_Derived_Type_Definition
3226 and then not Is_Tagged_Type
(Def_Id
)
3227 and then Present
(Freeze_Node
(Par_Id
))
3228 and then Present
(TSS_Elist
(Freeze_Node
(Par_Id
)))
3230 Ensure_Freeze_Node
(B_Id
);
3231 FN
:= Freeze_Node
(B_Id
);
3233 if No
(TSS_Elist
(FN
)) then
3234 Set_TSS_Elist
(FN
, New_Elmt_List
);
3238 T_E
: constant Elist_Id
:= TSS_Elist
(FN
);
3242 Elmt
:= First_Elmt
(TSS_Elist
(Freeze_Node
(Par_Id
)));
3244 while Present
(Elmt
) loop
3245 if Chars
(Node
(Elmt
)) /= Name_uInit
then
3246 Append_Elmt
(Node
(Elmt
), T_E
);
3252 -- If the derived type itself is private with a full view, then
3253 -- associate the full view with the inherited TSS_Elist as well.
3255 if Ekind
(B_Id
) in Private_Kind
3256 and then Present
(Full_View
(B_Id
))
3258 Ensure_Freeze_Node
(Base_Type
(Full_View
(B_Id
)));
3260 (Freeze_Node
(Base_Type
(Full_View
(B_Id
))), TSS_Elist
(FN
));
3264 end Expand_N_Full_Type_Declaration
;
3266 ---------------------------------
3267 -- Expand_N_Object_Declaration --
3268 ---------------------------------
3270 -- First we do special processing for objects of a tagged type where this
3271 -- is the point at which the type is frozen. The creation of the dispatch
3272 -- table and the initialization procedure have to be deferred to this
3273 -- point, since we reference previously declared primitive subprograms.
3275 -- For all types, we call an initialization procedure if there is one
3277 procedure Expand_N_Object_Declaration
(N
: Node_Id
) is
3278 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
3279 Typ
: constant Entity_Id
:= Etype
(Def_Id
);
3280 Loc
: constant Source_Ptr
:= Sloc
(N
);
3281 Expr
: constant Node_Id
:= Expression
(N
);
3287 -- Don't do anything for deferred constants. All proper actions will
3288 -- be expanded during the full declaration.
3290 if No
(Expr
) and Constant_Present
(N
) then
3294 -- Make shared memory routines for shared passive variable
3296 if Is_Shared_Passive
(Def_Id
) then
3297 Make_Shared_Var_Procs
(N
);
3300 -- If tasks being declared, make sure we have an activation chain
3301 -- defined for the tasks (has no effect if we already have one), and
3302 -- also that a Master variable is established and that the appropriate
3303 -- enclosing construct is established as a task master.
3305 if Has_Task
(Typ
) then
3306 Build_Activation_Chain_Entity
(N
);
3307 Build_Master_Entity
(Def_Id
);
3310 -- Default initialization required, and no expression present
3314 -- Expand Initialize call for controlled objects. One may wonder why
3315 -- the Initialize Call is not done in the regular Init procedure
3316 -- attached to the record type. That's because the init procedure is
3317 -- recursively called on each component, including _Parent, thus the
3318 -- Init call for a controlled object would generate not only one
3319 -- Initialize call as it is required but one for each ancestor of
3320 -- its type. This processing is suppressed if No_Initialization set.
3322 if not Controlled_Type
(Typ
)
3323 or else No_Initialization
(N
)
3327 elsif not Abort_Allowed
3328 or else not Comes_From_Source
(N
)
3330 Insert_Actions_After
(N
,
3332 Ref
=> New_Occurrence_Of
(Def_Id
, Loc
),
3333 Typ
=> Base_Type
(Typ
),
3334 Flist_Ref
=> Find_Final_List
(Def_Id
),
3335 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
3340 -- We need to protect the initialize call
3344 -- Initialize (...);
3346 -- Undefer_Abort.all;
3349 -- ??? this won't protect the initialize call for controlled
3350 -- components which are part of the init proc, so this block
3351 -- should probably also contain the call to _init_proc but this
3352 -- requires some code reorganization...
3355 L
: constant List_Id
:=
3357 Ref
=> New_Occurrence_Of
(Def_Id
, Loc
),
3358 Typ
=> Base_Type
(Typ
),
3359 Flist_Ref
=> Find_Final_List
(Def_Id
),
3360 With_Attach
=> Make_Integer_Literal
(Loc
, 1));
3362 Blk
: constant Node_Id
:=
3363 Make_Block_Statement
(Loc
,
3364 Handled_Statement_Sequence
=>
3365 Make_Handled_Sequence_Of_Statements
(Loc
, L
));
3368 Prepend_To
(L
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
3369 Set_At_End_Proc
(Handled_Statement_Sequence
(Blk
),
3370 New_Occurrence_Of
(RTE
(RE_Abort_Undefer_Direct
), Loc
));
3371 Insert_Actions_After
(N
, New_List
(Blk
));
3372 Expand_At_End_Handler
3373 (Handled_Statement_Sequence
(Blk
), Entity
(Identifier
(Blk
)));
3377 -- Call type initialization procedure if there is one. We build the
3378 -- call and put it immediately after the object declaration, so that
3379 -- it will be expanded in the usual manner. Note that this will
3380 -- result in proper handling of defaulted discriminants. The call
3381 -- to the Init_Proc is suppressed if No_Initialization is set.
3383 if Has_Non_Null_Base_Init_Proc
(Typ
)
3384 and then not No_Initialization
(N
)
3386 -- The call to the initialization procedure does NOT freeze
3387 -- the object being initialized. This is because the call is
3388 -- not a source level call. This works fine, because the only
3389 -- possible statements depending on freeze status that can
3390 -- appear after the _Init call are rep clauses which can
3391 -- safely appear after actual references to the object.
3393 Id_Ref
:= New_Reference_To
(Def_Id
, Loc
);
3394 Set_Must_Not_Freeze
(Id_Ref
);
3395 Set_Assignment_OK
(Id_Ref
);
3397 Insert_Actions_After
(N
,
3398 Build_Initialization_Call
(Loc
, Id_Ref
, Typ
));
3400 -- If simple initialization is required, then set an appropriate
3401 -- simple initialization expression in place. This special
3402 -- initialization is required even though No_Init_Flag is present.
3404 elsif Needs_Simple_Initialization
(Typ
) then
3405 Set_No_Initialization
(N
, False);
3406 Set_Expression
(N
, Get_Simple_Init_Val
(Typ
, Loc
));
3407 Analyze_And_Resolve
(Expression
(N
), Typ
);
3410 -- Explicit initialization present
3413 -- Obtain actual expression from qualified expression
3415 if Nkind
(Expr
) = N_Qualified_Expression
then
3416 Expr_Q
:= Expression
(Expr
);
3421 -- When we have the appropriate type of aggregate in the
3422 -- expression (it has been determined during analysis of the
3423 -- aggregate by setting the delay flag), let's perform in
3424 -- place assignment and thus avoid creating a temporary.
3426 if Is_Delayed_Aggregate
(Expr_Q
) then
3427 Convert_Aggr_In_Object_Decl
(N
);
3430 -- In most cases, we must check that the initial value meets
3431 -- any constraint imposed by the declared type. However, there
3432 -- is one very important exception to this rule. If the entity
3433 -- has an unconstrained nominal subtype, then it acquired its
3434 -- constraints from the expression in the first place, and not
3435 -- only does this mean that the constraint check is not needed,
3436 -- but an attempt to perform the constraint check can
3437 -- cause order of elaboration problems.
3439 if not Is_Constr_Subt_For_U_Nominal
(Typ
) then
3441 -- If this is an allocator for an aggregate that has been
3442 -- allocated in place, delay checks until assignments are
3443 -- made, because the discriminants are not initialized.
3445 if Nkind
(Expr
) = N_Allocator
3446 and then No_Initialization
(Expr
)
3450 Apply_Constraint_Check
(Expr
, Typ
);
3454 -- If the type is controlled we attach the object to the final
3455 -- list and adjust the target after the copy. This
3457 if Controlled_Type
(Typ
) then
3463 -- Attach the result to a dummy final list which will never
3464 -- be finalized if Delay_Finalize_Attachis set. It is
3465 -- important to attach to a dummy final list rather than
3466 -- not attaching at all in order to reset the pointers
3467 -- coming from the initial value. Equivalent code exists
3468 -- in the sec-stack case in Exp_Ch4.Expand_N_Allocator.
3470 if Delay_Finalize_Attach
(N
) then
3472 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F'));
3474 Make_Object_Declaration
(Loc
,
3475 Defining_Identifier
=> F
,
3476 Object_Definition
=>
3477 New_Reference_To
(RTE
(RE_Finalizable_Ptr
), Loc
)));
3479 Flist
:= New_Reference_To
(F
, Loc
);
3482 Flist
:= Find_Final_List
(Def_Id
);
3485 Insert_Actions_After
(N
,
3487 Ref
=> New_Reference_To
(Def_Id
, Loc
),
3488 Typ
=> Base_Type
(Typ
),
3490 With_Attach
=> Make_Integer_Literal
(Loc
, 1)));
3494 -- For tagged types, when an init value is given, the tag has
3495 -- to be re-initialized separately in order to avoid the
3496 -- propagation of a wrong tag coming from a view conversion
3497 -- unless the type is class wide (in this case the tag comes
3498 -- from the init value). Suppress the tag assignment when
3499 -- Java_VM because JVM tags are represented implicitly
3500 -- in objects. Ditto for types that are CPP_CLASS.
3502 if Is_Tagged_Type
(Typ
)
3503 and then not Is_Class_Wide_Type
(Typ
)
3504 and then not Is_CPP_Class
(Typ
)
3505 and then not Java_VM
3507 -- The re-assignment of the tag has to be done even if
3508 -- the object is a constant
3511 Make_Selected_Component
(Loc
,
3512 Prefix
=> New_Reference_To
(Def_Id
, Loc
),
3514 New_Reference_To
(Tag_Component
(Typ
), Loc
));
3516 Set_Assignment_OK
(New_Ref
);
3519 Make_Assignment_Statement
(Loc
,
3522 Unchecked_Convert_To
(RTE
(RE_Tag
),
3524 (Access_Disp_Table
(Base_Type
(Typ
)), Loc
))));
3526 -- For discrete types, set the Is_Known_Valid flag if the
3527 -- initializing value is known to be valid.
3529 elsif Is_Discrete_Type
(Typ
)
3530 and then Expr_Known_Valid
(Expr
)
3532 Set_Is_Known_Valid
(Def_Id
);
3534 elsif Is_Access_Type
(Typ
) then
3536 -- Ada 2005 (AI-231): Generate conversion to the null-excluding
3537 -- type to force the corresponding run-time check
3539 if Ada_Version
>= Ada_05
3540 and then (Can_Never_Be_Null
(Def_Id
)
3541 or else Can_Never_Be_Null
(Typ
))
3545 Convert_To
(Etype
(Def_Id
), Relocate_Node
(Expr_Q
)));
3546 Analyze_And_Resolve
(Expr_Q
, Etype
(Def_Id
));
3549 -- For access types set the Is_Known_Non_Null flag if the
3550 -- initializing value is known to be non-null. We can also
3551 -- set Can_Never_Be_Null if this is a constant.
3553 if Known_Non_Null
(Expr
) then
3554 Set_Is_Known_Non_Null
(Def_Id
);
3556 if Constant_Present
(N
) then
3557 Set_Can_Never_Be_Null
(Def_Id
);
3562 -- If validity checking on copies, validate initial expression
3564 if Validity_Checks_On
3565 and then Validity_Check_Copies
3567 Ensure_Valid
(Expr
);
3568 Set_Is_Known_Valid
(Def_Id
);
3572 if Is_Possibly_Unaligned_Slice
(Expr
) then
3574 -- Make a separate assignment that will be expanded into a
3575 -- loop, to bypass back-end problems with misaligned arrays.
3578 Stat
: constant Node_Id
:=
3579 Make_Assignment_Statement
(Loc
,
3580 Name
=> New_Reference_To
(Def_Id
, Loc
),
3581 Expression
=> Relocate_Node
(Expr
));
3584 Set_Expression
(N
, Empty
);
3585 Set_No_Initialization
(N
);
3586 Set_Assignment_OK
(Name
(Stat
));
3587 Insert_After
(N
, Stat
);
3593 -- For array type, check for size too large
3594 -- We really need this for record types too???
3596 if Is_Array_Type
(Typ
) then
3597 Apply_Array_Size_Check
(N
, Typ
);
3601 when RE_Not_Available
=>
3603 end Expand_N_Object_Declaration
;
3605 ---------------------------------
3606 -- Expand_N_Subtype_Indication --
3607 ---------------------------------
3609 -- Add a check on the range of the subtype. The static case is
3610 -- partially duplicated by Process_Range_Expr_In_Decl in Sem_Ch3,
3611 -- but we still need to check here for the static case in order to
3612 -- avoid generating extraneous expanded code.
3614 procedure Expand_N_Subtype_Indication
(N
: Node_Id
) is
3615 Ran
: constant Node_Id
:= Range_Expression
(Constraint
(N
));
3616 Typ
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
3619 if Nkind
(Parent
(N
)) = N_Constrained_Array_Definition
or else
3620 Nkind
(Parent
(N
)) = N_Slice
3623 Apply_Range_Check
(Ran
, Typ
);
3625 end Expand_N_Subtype_Indication
;
3627 ---------------------------
3628 -- Expand_N_Variant_Part --
3629 ---------------------------
3631 -- If the last variant does not contain the Others choice, replace
3632 -- it with an N_Others_Choice node since Gigi always wants an Others.
3633 -- Note that we do not bother to call Analyze on the modified variant
3634 -- part, since it's only effect would be to compute the contents of
3635 -- the Others_Discrete_Choices node laboriously, and of course we
3636 -- already know the list of choices that corresponds to the others
3637 -- choice (it's the list we are replacing!)
3639 procedure Expand_N_Variant_Part
(N
: Node_Id
) is
3640 Last_Var
: constant Node_Id
:= Last_Non_Pragma
(Variants
(N
));
3641 Others_Node
: Node_Id
;
3644 if Nkind
(First
(Discrete_Choices
(Last_Var
))) /= N_Others_Choice
then
3645 Others_Node
:= Make_Others_Choice
(Sloc
(Last_Var
));
3646 Set_Others_Discrete_Choices
3647 (Others_Node
, Discrete_Choices
(Last_Var
));
3648 Set_Discrete_Choices
(Last_Var
, New_List
(Others_Node
));
3650 end Expand_N_Variant_Part
;
3652 ---------------------------------
3653 -- Expand_Previous_Access_Type --
3654 ---------------------------------
3656 procedure Expand_Previous_Access_Type
(Def_Id
: Entity_Id
) is
3657 T
: Entity_Id
:= First_Entity
(Current_Scope
);
3660 -- Find all access types declared in the current scope, whose
3661 -- designated type is Def_Id.
3663 while Present
(T
) loop
3664 if Is_Access_Type
(T
)
3665 and then Designated_Type
(T
) = Def_Id
3667 Build_Master_Entity
(Def_Id
);
3668 Build_Master_Renaming
(Parent
(Def_Id
), T
);
3673 end Expand_Previous_Access_Type
;
3675 ------------------------------
3676 -- Expand_Record_Controller --
3677 ------------------------------
3679 procedure Expand_Record_Controller
(T
: Entity_Id
) is
3680 Def
: Node_Id
:= Type_Definition
(Parent
(T
));
3681 Comp_List
: Node_Id
;
3682 Comp_Decl
: Node_Id
;
3684 First_Comp
: Node_Id
;
3685 Controller_Type
: Entity_Id
;
3689 if Nkind
(Def
) = N_Derived_Type_Definition
then
3690 Def
:= Record_Extension_Part
(Def
);
3693 if Null_Present
(Def
) then
3694 Set_Component_List
(Def
,
3695 Make_Component_List
(Sloc
(Def
),
3696 Component_Items
=> Empty_List
,
3697 Variant_Part
=> Empty
,
3698 Null_Present
=> True));
3701 Comp_List
:= Component_List
(Def
);
3703 if Null_Present
(Comp_List
)
3704 or else Is_Empty_List
(Component_Items
(Comp_List
))
3706 Loc
:= Sloc
(Comp_List
);
3708 Loc
:= Sloc
(First
(Component_Items
(Comp_List
)));
3711 if Is_Return_By_Reference_Type
(T
) then
3712 Controller_Type
:= RTE
(RE_Limited_Record_Controller
);
3714 Controller_Type
:= RTE
(RE_Record_Controller
);
3717 Ent
:= Make_Defining_Identifier
(Loc
, Name_uController
);
3720 Make_Component_Declaration
(Loc
,
3721 Defining_Identifier
=> Ent
,
3722 Component_Definition
=>
3723 Make_Component_Definition
(Loc
,
3724 Aliased_Present
=> False,
3725 Subtype_Indication
=> New_Reference_To
(Controller_Type
, Loc
)));
3727 if Null_Present
(Comp_List
)
3728 or else Is_Empty_List
(Component_Items
(Comp_List
))
3730 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
3731 Set_Null_Present
(Comp_List
, False);
3734 -- The controller cannot be placed before the _Parent field
3735 -- since gigi lays out field in order and _parent must be
3736 -- first to preserve the polymorphism of tagged types.
3738 First_Comp
:= First
(Component_Items
(Comp_List
));
3740 if Chars
(Defining_Identifier
(First_Comp
)) /= Name_uParent
3741 and then Chars
(Defining_Identifier
(First_Comp
)) /= Name_uTag
3743 Insert_Before
(First_Comp
, Comp_Decl
);
3745 Insert_After
(First_Comp
, Comp_Decl
);
3750 Analyze
(Comp_Decl
);
3751 Set_Ekind
(Ent
, E_Component
);
3752 Init_Component_Location
(Ent
);
3754 -- Move the _controller entity ahead in the list of internal
3755 -- entities of the enclosing record so that it is selected
3756 -- instead of a potentially inherited one.
3759 E
: constant Entity_Id
:= Last_Entity
(T
);
3763 pragma Assert
(Chars
(E
) = Name_uController
);
3765 Set_Next_Entity
(E
, First_Entity
(T
));
3766 Set_First_Entity
(T
, E
);
3768 Comp
:= Next_Entity
(E
);
3769 while Next_Entity
(Comp
) /= E
loop
3773 Set_Next_Entity
(Comp
, Empty
);
3774 Set_Last_Entity
(T
, Comp
);
3780 when RE_Not_Available
=>
3782 end Expand_Record_Controller
;
3784 ------------------------
3785 -- Expand_Tagged_Root --
3786 ------------------------
3788 procedure Expand_Tagged_Root
(T
: Entity_Id
) is
3789 Def
: constant Node_Id
:= Type_Definition
(Parent
(T
));
3790 Comp_List
: Node_Id
;
3791 Comp_Decl
: Node_Id
;
3792 Sloc_N
: Source_Ptr
;
3795 if Null_Present
(Def
) then
3796 Set_Component_List
(Def
,
3797 Make_Component_List
(Sloc
(Def
),
3798 Component_Items
=> Empty_List
,
3799 Variant_Part
=> Empty
,
3800 Null_Present
=> True));
3803 Comp_List
:= Component_List
(Def
);
3805 if Null_Present
(Comp_List
)
3806 or else Is_Empty_List
(Component_Items
(Comp_List
))
3808 Sloc_N
:= Sloc
(Comp_List
);
3810 Sloc_N
:= Sloc
(First
(Component_Items
(Comp_List
)));
3814 Make_Component_Declaration
(Sloc_N
,
3815 Defining_Identifier
=> Tag_Component
(T
),
3816 Component_Definition
=>
3817 Make_Component_Definition
(Sloc_N
,
3818 Aliased_Present
=> False,
3819 Subtype_Indication
=> New_Reference_To
(RTE
(RE_Tag
), Sloc_N
)));
3821 if Null_Present
(Comp_List
)
3822 or else Is_Empty_List
(Component_Items
(Comp_List
))
3824 Set_Component_Items
(Comp_List
, New_List
(Comp_Decl
));
3825 Set_Null_Present
(Comp_List
, False);
3828 Insert_Before
(First
(Component_Items
(Comp_List
)), Comp_Decl
);
3831 -- We don't Analyze the whole expansion because the tag component has
3832 -- already been analyzed previously. Here we just insure that the
3833 -- tree is coherent with the semantic decoration
3835 Find_Type
(Subtype_Indication
(Component_Definition
(Comp_Decl
)));
3838 when RE_Not_Available
=>
3840 end Expand_Tagged_Root
;
3842 -----------------------
3843 -- Freeze_Array_Type --
3844 -----------------------
3846 procedure Freeze_Array_Type
(N
: Node_Id
) is
3847 Typ
: constant Entity_Id
:= Entity
(N
);
3848 Base
: constant Entity_Id
:= Base_Type
(Typ
);
3851 if not Is_Bit_Packed_Array
(Typ
) then
3853 -- If the component contains tasks, so does the array type.
3854 -- This may not be indicated in the array type because the
3855 -- component may have been a private type at the point of
3856 -- definition. Same if component type is controlled.
3858 Set_Has_Task
(Base
, Has_Task
(Component_Type
(Typ
)));
3859 Set_Has_Controlled_Component
(Base
,
3860 Has_Controlled_Component
(Component_Type
(Typ
))
3861 or else Is_Controlled
(Component_Type
(Typ
)));
3863 if No
(Init_Proc
(Base
)) then
3865 -- If this is an anonymous array created for a declaration
3866 -- with an initial value, its init_proc will never be called.
3867 -- The initial value itself may have been expanded into assign-
3868 -- ments, in which case the object declaration is carries the
3869 -- No_Initialization flag.
3872 and then Nkind
(Associated_Node_For_Itype
(Base
)) =
3873 N_Object_Declaration
3874 and then (Present
(Expression
(Associated_Node_For_Itype
(Base
)))
3876 No_Initialization
(Associated_Node_For_Itype
(Base
)))
3880 -- We do not need an init proc for string or wide string, since
3881 -- the only time these need initialization in normalize or
3882 -- initialize scalars mode, and these types are treated specially
3883 -- and do not need initialization procedures.
3885 elsif Root_Type
(Base
) = Standard_String
3886 or else Root_Type
(Base
) = Standard_Wide_String
3890 -- Otherwise we have to build an init proc for the subtype
3893 Build_Array_Init_Proc
(Base
, N
);
3897 if Typ
= Base
and then Has_Controlled_Component
(Base
) then
3898 Build_Controlling_Procs
(Base
);
3900 if not Is_Limited_Type
(Component_Type
(Typ
))
3901 and then Number_Dimensions
(Typ
) = 1
3903 Build_Slice_Assignment
(Typ
);
3907 -- For packed case, there is a default initialization, except
3908 -- if the component type is itself a packed structure with an
3909 -- initialization procedure.
3911 elsif Present
(Init_Proc
(Component_Type
(Base
)))
3912 and then No
(Base_Init_Proc
(Base
))
3914 Build_Array_Init_Proc
(Base
, N
);
3916 end Freeze_Array_Type
;
3918 -----------------------------
3919 -- Freeze_Enumeration_Type --
3920 -----------------------------
3922 procedure Freeze_Enumeration_Type
(N
: Node_Id
) is
3923 Typ
: constant Entity_Id
:= Entity
(N
);
3924 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3931 Is_Contiguous
: Boolean;
3936 pragma Warnings
(Off
, Func
);
3939 -- Various optimization are possible if the given representation
3942 Is_Contiguous
:= True;
3943 Ent
:= First_Literal
(Typ
);
3944 Last_Repval
:= Enumeration_Rep
(Ent
);
3947 while Present
(Ent
) loop
3948 if Enumeration_Rep
(Ent
) - Last_Repval
/= 1 then
3949 Is_Contiguous
:= False;
3952 Last_Repval
:= Enumeration_Rep
(Ent
);
3958 if Is_Contiguous
then
3959 Set_Has_Contiguous_Rep
(Typ
);
3960 Ent
:= First_Literal
(Typ
);
3962 Lst
:= New_List
(New_Reference_To
(Ent
, Sloc
(Ent
)));
3965 -- Build list of literal references
3970 Ent
:= First_Literal
(Typ
);
3971 while Present
(Ent
) loop
3972 Append_To
(Lst
, New_Reference_To
(Ent
, Sloc
(Ent
)));
3978 -- Now build an array declaration
3980 -- typA : array (Natural range 0 .. num - 1) of ctype :=
3981 -- (v, v, v, v, v, ....)
3983 -- where ctype is the corresponding integer type. If the
3984 -- representation is contiguous, we only keep the first literal,
3985 -- which provides the offset for Pos_To_Rep computations.
3988 Make_Defining_Identifier
(Loc
,
3989 Chars
=> New_External_Name
(Chars
(Typ
), 'A'));
3991 Append_Freeze_Action
(Typ
,
3992 Make_Object_Declaration
(Loc
,
3993 Defining_Identifier
=> Arr
,
3994 Constant_Present
=> True,
3996 Object_Definition
=>
3997 Make_Constrained_Array_Definition
(Loc
,
3998 Discrete_Subtype_Definitions
=> New_List
(
3999 Make_Subtype_Indication
(Loc
,
4000 Subtype_Mark
=> New_Reference_To
(Standard_Natural
, Loc
),
4002 Make_Range_Constraint
(Loc
,
4006 Make_Integer_Literal
(Loc
, 0),
4008 Make_Integer_Literal
(Loc
, Num
- 1))))),
4010 Component_Definition
=>
4011 Make_Component_Definition
(Loc
,
4012 Aliased_Present
=> False,
4013 Subtype_Indication
=> New_Reference_To
(Typ
, Loc
))),
4016 Make_Aggregate
(Loc
,
4017 Expressions
=> Lst
)));
4019 Set_Enum_Pos_To_Rep
(Typ
, Arr
);
4021 -- Now we build the function that converts representation values to
4022 -- position values. This function has the form:
4024 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
4027 -- when enum-lit'Enum_Rep => return posval;
4028 -- when enum-lit'Enum_Rep => return posval;
4031 -- [raise Constraint_Error when F "invalid data"]
4036 -- Note: the F parameter determines whether the others case (no valid
4037 -- representation) raises Constraint_Error or returns a unique value
4038 -- of minus one. The latter case is used, e.g. in 'Valid code.
4040 -- Note: the reason we use Enum_Rep values in the case here is to
4041 -- avoid the code generator making inappropriate assumptions about
4042 -- the range of the values in the case where the value is invalid.
4043 -- ityp is a signed or unsigned integer type of appropriate width.
4045 -- Note: if exceptions are not supported, then we suppress the raise
4046 -- and return -1 unconditionally (this is an erroneous program in any
4047 -- case and there is no obligation to raise Constraint_Error here!)
4048 -- We also do this if pragma Restrictions (No_Exceptions) is active.
4050 -- Representations are signed
4052 if Enumeration_Rep
(First_Literal
(Typ
)) < 0 then
4054 -- The underlying type is signed. Reset the Is_Unsigned_Type
4055 -- explicitly, because it might have been inherited from a
4058 Set_Is_Unsigned_Type
(Typ
, False);
4060 if Esize
(Typ
) <= Standard_Integer_Size
then
4061 Ityp
:= Standard_Integer
;
4063 Ityp
:= Universal_Integer
;
4066 -- Representations are unsigned
4069 if Esize
(Typ
) <= Standard_Integer_Size
then
4070 Ityp
:= RTE
(RE_Unsigned
);
4072 Ityp
:= RTE
(RE_Long_Long_Unsigned
);
4076 -- The body of the function is a case statement. First collect
4077 -- case alternatives, or optimize the contiguous case.
4081 -- If representation is contiguous, Pos is computed by subtracting
4082 -- the representation of the first literal.
4084 if Is_Contiguous
then
4085 Ent
:= First_Literal
(Typ
);
4087 if Enumeration_Rep
(Ent
) = Last_Repval
then
4089 -- Another special case: for a single literal, Pos is zero
4091 Pos_Expr
:= Make_Integer_Literal
(Loc
, Uint_0
);
4095 Convert_To
(Standard_Integer
,
4096 Make_Op_Subtract
(Loc
,
4098 Unchecked_Convert_To
(Ityp
,
4099 Make_Identifier
(Loc
, Name_uA
)),
4101 Make_Integer_Literal
(Loc
,
4103 Enumeration_Rep
(First_Literal
(Typ
)))));
4107 Make_Case_Statement_Alternative
(Loc
,
4108 Discrete_Choices
=> New_List
(
4109 Make_Range
(Sloc
(Enumeration_Rep_Expr
(Ent
)),
4111 Make_Integer_Literal
(Loc
,
4112 Intval
=> Enumeration_Rep
(Ent
)),
4114 Make_Integer_Literal
(Loc
, Intval
=> Last_Repval
))),
4116 Statements
=> New_List
(
4117 Make_Return_Statement
(Loc
,
4118 Expression
=> Pos_Expr
))));
4121 Ent
:= First_Literal
(Typ
);
4123 while Present
(Ent
) loop
4125 Make_Case_Statement_Alternative
(Loc
,
4126 Discrete_Choices
=> New_List
(
4127 Make_Integer_Literal
(Sloc
(Enumeration_Rep_Expr
(Ent
)),
4128 Intval
=> Enumeration_Rep
(Ent
))),
4130 Statements
=> New_List
(
4131 Make_Return_Statement
(Loc
,
4133 Make_Integer_Literal
(Loc
,
4134 Intval
=> Enumeration_Pos
(Ent
))))));
4140 -- In normal mode, add the others clause with the test
4142 if not Restriction_Active
(No_Exception_Handlers
) then
4144 Make_Case_Statement_Alternative
(Loc
,
4145 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
4146 Statements
=> New_List
(
4147 Make_Raise_Constraint_Error
(Loc
,
4148 Condition
=> Make_Identifier
(Loc
, Name_uF
),
4149 Reason
=> CE_Invalid_Data
),
4150 Make_Return_Statement
(Loc
,
4152 Make_Integer_Literal
(Loc
, -1)))));
4154 -- If Restriction (No_Exceptions_Handlers) is active then we always
4155 -- return -1 (since we cannot usefully raise Constraint_Error in
4156 -- this case). See description above for further details.
4160 Make_Case_Statement_Alternative
(Loc
,
4161 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
4162 Statements
=> New_List
(
4163 Make_Return_Statement
(Loc
,
4165 Make_Integer_Literal
(Loc
, -1)))));
4168 -- Now we can build the function body
4171 Make_Defining_Identifier
(Loc
, Make_TSS_Name
(Typ
, TSS_Rep_To_Pos
));
4174 Make_Subprogram_Body
(Loc
,
4176 Make_Function_Specification
(Loc
,
4177 Defining_Unit_Name
=> Fent
,
4178 Parameter_Specifications
=> New_List
(
4179 Make_Parameter_Specification
(Loc
,
4180 Defining_Identifier
=>
4181 Make_Defining_Identifier
(Loc
, Name_uA
),
4182 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
4183 Make_Parameter_Specification
(Loc
,
4184 Defining_Identifier
=>
4185 Make_Defining_Identifier
(Loc
, Name_uF
),
4186 Parameter_Type
=> New_Reference_To
(Standard_Boolean
, Loc
))),
4188 Subtype_Mark
=> New_Reference_To
(Standard_Integer
, Loc
)),
4190 Declarations
=> Empty_List
,
4192 Handled_Statement_Sequence
=>
4193 Make_Handled_Sequence_Of_Statements
(Loc
,
4194 Statements
=> New_List
(
4195 Make_Case_Statement
(Loc
,
4197 Unchecked_Convert_To
(Ityp
,
4198 Make_Identifier
(Loc
, Name_uA
)),
4199 Alternatives
=> Lst
))));
4201 Set_TSS
(Typ
, Fent
);
4204 if not Debug_Generated_Code
then
4205 Set_Debug_Info_Off
(Fent
);
4209 when RE_Not_Available
=>
4211 end Freeze_Enumeration_Type
;
4213 ------------------------
4214 -- Freeze_Record_Type --
4215 ------------------------
4217 procedure Freeze_Record_Type
(N
: Node_Id
) is
4218 Def_Id
: constant Node_Id
:= Entity
(N
);
4220 Type_Decl
: constant Node_Id
:= Parent
(Def_Id
);
4221 Predef_List
: List_Id
;
4223 Renamed_Eq
: Node_Id
:= Empty
;
4224 -- Could use some comments ???
4227 -- Build discriminant checking functions if not a derived type (for
4228 -- derived types that are not tagged types, we always use the
4229 -- discriminant checking functions of the parent type). However, for
4230 -- untagged types the derivation may have taken place before the
4231 -- parent was frozen, so we copy explicitly the discriminant checking
4232 -- functions from the parent into the components of the derived type.
4234 if not Is_Derived_Type
(Def_Id
)
4235 or else Has_New_Non_Standard_Rep
(Def_Id
)
4236 or else Is_Tagged_Type
(Def_Id
)
4238 Build_Discr_Checking_Funcs
(Type_Decl
);
4240 elsif Is_Derived_Type
(Def_Id
)
4241 and then not Is_Tagged_Type
(Def_Id
)
4243 -- If we have a derived Unchecked_Union, we do not inherit the
4244 -- discriminant checking functions from the parent type since the
4245 -- discriminants are non existent.
4247 and then not Is_Unchecked_Union
(Def_Id
)
4248 and then Has_Discriminants
(Def_Id
)
4251 Old_Comp
: Entity_Id
;
4255 First_Component
(Base_Type
(Underlying_Type
(Etype
(Def_Id
))));
4256 Comp
:= First_Component
(Def_Id
);
4257 while Present
(Comp
) loop
4258 if Ekind
(Comp
) = E_Component
4259 and then Chars
(Comp
) = Chars
(Old_Comp
)
4261 Set_Discriminant_Checking_Func
(Comp
,
4262 Discriminant_Checking_Func
(Old_Comp
));
4265 Next_Component
(Old_Comp
);
4266 Next_Component
(Comp
);
4271 if Is_Derived_Type
(Def_Id
)
4272 and then Is_Limited_Type
(Def_Id
)
4273 and then Is_Tagged_Type
(Def_Id
)
4275 Check_Stream_Attributes
(Def_Id
);
4278 -- Update task and controlled component flags, because some of the
4279 -- component types may have been private at the point of the record
4282 Comp
:= First_Component
(Def_Id
);
4284 while Present
(Comp
) loop
4285 if Has_Task
(Etype
(Comp
)) then
4286 Set_Has_Task
(Def_Id
);
4288 elsif Has_Controlled_Component
(Etype
(Comp
))
4289 or else (Chars
(Comp
) /= Name_uParent
4290 and then Is_Controlled
(Etype
(Comp
)))
4292 Set_Has_Controlled_Component
(Def_Id
);
4295 Next_Component
(Comp
);
4298 -- Creation of the Dispatch Table. Note that a Dispatch Table is
4299 -- created for regular tagged types as well as for Ada types
4300 -- deriving from a C++ Class, but not for tagged types directly
4301 -- corresponding to the C++ classes. In the later case we assume
4302 -- that the Vtable is created in the C++ side and we just use it.
4304 if Is_Tagged_Type
(Def_Id
) then
4305 if Is_CPP_Class
(Def_Id
) then
4306 Set_All_DT_Position
(Def_Id
);
4307 Set_Default_Constructor
(Def_Id
);
4310 -- Usually inherited primitives are not delayed but the first
4311 -- Ada extension of a CPP_Class is an exception since the
4312 -- address of the inherited subprogram has to be inserted in
4313 -- the new Ada Dispatch Table and this is a freezing action
4314 -- (usually the inherited primitive address is inserted in the
4315 -- DT by Inherit_DT)
4317 -- Similarly, if this is an inherited operation whose parent
4318 -- is not frozen yet, it is not in the DT of the parent, and
4319 -- we generate an explicit freeze node for the inherited
4320 -- operation, so that it is properly inserted in the DT of the
4324 Elmt
: Elmt_Id
:= First_Elmt
(Primitive_Operations
(Def_Id
));
4328 while Present
(Elmt
) loop
4329 Subp
:= Node
(Elmt
);
4331 if Present
(Alias
(Subp
)) then
4332 if Is_CPP_Class
(Etype
(Def_Id
)) then
4333 Set_Has_Delayed_Freeze
(Subp
);
4335 elsif Has_Delayed_Freeze
(Alias
(Subp
))
4336 and then not Is_Frozen
(Alias
(Subp
))
4338 Set_Is_Frozen
(Subp
, False);
4339 Set_Has_Delayed_Freeze
(Subp
);
4347 if Underlying_Type
(Etype
(Def_Id
)) = Def_Id
then
4348 Expand_Tagged_Root
(Def_Id
);
4351 -- Unfreeze momentarily the type to add the predefined
4352 -- primitives operations. The reason we unfreeze is so
4353 -- that these predefined operations will indeed end up
4354 -- as primitive operations (which must be before the
4357 Set_Is_Frozen
(Def_Id
, False);
4358 Make_Predefined_Primitive_Specs
4359 (Def_Id
, Predef_List
, Renamed_Eq
);
4360 Insert_List_Before_And_Analyze
(N
, Predef_List
);
4361 Set_Is_Frozen
(Def_Id
, True);
4362 Set_All_DT_Position
(Def_Id
);
4364 -- Add the controlled component before the freezing actions
4365 -- it is referenced in those actions.
4367 if Has_New_Controlled_Component
(Def_Id
) then
4368 Expand_Record_Controller
(Def_Id
);
4371 -- Suppress creation of a dispatch table when Java_VM because
4372 -- the dispatching mechanism is handled internally by the JVM.
4375 Append_Freeze_Actions
(Def_Id
, Make_DT
(Def_Id
));
4378 -- Make sure that the primitives Initialize, Adjust and
4379 -- Finalize are Frozen before other TSS subprograms. We
4380 -- don't want them Frozen inside.
4382 if Is_Controlled
(Def_Id
) then
4383 if not Is_Limited_Type
(Def_Id
) then
4384 Append_Freeze_Actions
(Def_Id
,
4386 (Find_Prim_Op
(Def_Id
, Name_Adjust
), Sloc
(Def_Id
)));
4389 Append_Freeze_Actions
(Def_Id
,
4391 (Find_Prim_Op
(Def_Id
, Name_Initialize
), Sloc
(Def_Id
)));
4393 Append_Freeze_Actions
(Def_Id
,
4395 (Find_Prim_Op
(Def_Id
, Name_Finalize
), Sloc
(Def_Id
)));
4398 -- Freeze rest of primitive operations
4400 Append_Freeze_Actions
4401 (Def_Id
, Predefined_Primitive_Freeze
(Def_Id
));
4404 -- In the non-tagged case, an equality function is provided only
4405 -- for variant records (that are not unchecked unions).
4407 elsif Has_Discriminants
(Def_Id
)
4408 and then not Is_Limited_Type
(Def_Id
)
4411 Comps
: constant Node_Id
:=
4412 Component_List
(Type_Definition
(Type_Decl
));
4416 and then Present
(Variant_Part
(Comps
))
4418 Build_Variant_Record_Equality
(Def_Id
);
4423 -- Before building the record initialization procedure, if we are
4424 -- dealing with a concurrent record value type, then we must go
4425 -- through the discriminants, exchanging discriminals between the
4426 -- concurrent type and the concurrent record value type. See the
4427 -- section "Handling of Discriminants" in the Einfo spec for details.
4429 if Is_Concurrent_Record_Type
(Def_Id
)
4430 and then Has_Discriminants
(Def_Id
)
4433 Ctyp
: constant Entity_Id
:=
4434 Corresponding_Concurrent_Type
(Def_Id
);
4435 Conc_Discr
: Entity_Id
;
4436 Rec_Discr
: Entity_Id
;
4440 Conc_Discr
:= First_Discriminant
(Ctyp
);
4441 Rec_Discr
:= First_Discriminant
(Def_Id
);
4443 while Present
(Conc_Discr
) loop
4444 Temp
:= Discriminal
(Conc_Discr
);
4445 Set_Discriminal
(Conc_Discr
, Discriminal
(Rec_Discr
));
4446 Set_Discriminal
(Rec_Discr
, Temp
);
4448 Set_Discriminal_Link
(Discriminal
(Conc_Discr
), Conc_Discr
);
4449 Set_Discriminal_Link
(Discriminal
(Rec_Discr
), Rec_Discr
);
4451 Next_Discriminant
(Conc_Discr
);
4452 Next_Discriminant
(Rec_Discr
);
4457 if Has_Controlled_Component
(Def_Id
) then
4458 if No
(Controller_Component
(Def_Id
)) then
4459 Expand_Record_Controller
(Def_Id
);
4462 Build_Controlling_Procs
(Def_Id
);
4465 Adjust_Discriminants
(Def_Id
);
4466 Build_Record_Init_Proc
(Type_Decl
, Def_Id
);
4468 -- For tagged type, build bodies of primitive operations. Note
4469 -- that we do this after building the record initialization
4470 -- experiment, since the primitive operations may need the
4471 -- initialization routine
4473 if Is_Tagged_Type
(Def_Id
) then
4474 Predef_List
:= Predefined_Primitive_Bodies
(Def_Id
, Renamed_Eq
);
4475 Append_Freeze_Actions
(Def_Id
, Predef_List
);
4478 end Freeze_Record_Type
;
4480 ------------------------------
4481 -- Freeze_Stream_Operations --
4482 ------------------------------
4484 procedure Freeze_Stream_Operations
(N
: Node_Id
; Typ
: Entity_Id
) is
4485 Names
: constant array (1 .. 4) of TSS_Name_Type
:=
4490 Stream_Op
: Entity_Id
;
4493 -- Primitive operations of tagged types are frozen when the dispatch
4494 -- table is constructed.
4496 if not Comes_From_Source
(Typ
)
4497 or else Is_Tagged_Type
(Typ
)
4502 for J
in Names
'Range loop
4503 Stream_Op
:= TSS
(Typ
, Names
(J
));
4505 if Present
(Stream_Op
)
4506 and then Is_Subprogram
(Stream_Op
)
4507 and then Nkind
(Unit_Declaration_Node
(Stream_Op
)) =
4508 N_Subprogram_Declaration
4509 and then not Is_Frozen
(Stream_Op
)
4511 Append_Freeze_Actions
4512 (Typ
, Freeze_Entity
(Stream_Op
, Sloc
(N
)));
4515 end Freeze_Stream_Operations
;
4521 -- Full type declarations are expanded at the point at which the type
4522 -- is frozen. The formal N is the Freeze_Node for the type. Any statements
4523 -- or declarations generated by the freezing (e.g. the procedure generated
4524 -- for initialization) are chained in the Acions field list of the freeze
4525 -- node using Append_Freeze_Actions.
4527 procedure Freeze_Type
(N
: Node_Id
) is
4528 Def_Id
: constant Entity_Id
:= Entity
(N
);
4529 RACW_Seen
: Boolean := False;
4532 -- Process associated access types needing special processing
4534 if Present
(Access_Types_To_Process
(N
)) then
4536 E
: Elmt_Id
:= First_Elmt
(Access_Types_To_Process
(N
));
4538 while Present
(E
) loop
4540 if Is_Remote_Access_To_Class_Wide_Type
(Node
(E
)) then
4550 -- If there are RACWs designating this type, make stubs now
4552 Remote_Types_Tagged_Full_View_Encountered
(Def_Id
);
4556 -- Freeze processing for record types
4558 if Is_Record_Type
(Def_Id
) then
4559 if Ekind
(Def_Id
) = E_Record_Type
then
4560 Freeze_Record_Type
(N
);
4562 -- The subtype may have been declared before the type was frozen.
4563 -- If the type has controlled components it is necessary to create
4564 -- the entity for the controller explicitly because it did not
4565 -- exist at the point of the subtype declaration. Only the entity is
4566 -- needed, the back-end will obtain the layout from the type.
4567 -- This is only necessary if this is constrained subtype whose
4568 -- component list is not shared with the base type.
4570 elsif Ekind
(Def_Id
) = E_Record_Subtype
4571 and then Has_Discriminants
(Def_Id
)
4572 and then Last_Entity
(Def_Id
) /= Last_Entity
(Base_Type
(Def_Id
))
4573 and then Present
(Controller_Component
(Def_Id
))
4576 Old_C
: constant Entity_Id
:= Controller_Component
(Def_Id
);
4580 if Scope
(Old_C
) = Base_Type
(Def_Id
) then
4582 -- The entity is the one in the parent. Create new one
4584 New_C
:= New_Copy
(Old_C
);
4585 Set_Parent
(New_C
, Parent
(Old_C
));
4592 -- Similar process if the controller of the subtype is not
4593 -- present but the parent has it. This can happen with constrained
4594 -- record components where the subtype is an itype.
4596 elsif Ekind
(Def_Id
) = E_Record_Subtype
4597 and then Is_Itype
(Def_Id
)
4598 and then No
(Controller_Component
(Def_Id
))
4599 and then Present
(Controller_Component
(Etype
(Def_Id
)))
4602 Old_C
: constant Entity_Id
:=
4603 Controller_Component
(Etype
(Def_Id
));
4604 New_C
: constant Entity_Id
:= New_Copy
(Old_C
);
4607 Set_Next_Entity
(New_C
, First_Entity
(Def_Id
));
4608 Set_First_Entity
(Def_Id
, New_C
);
4610 -- The freeze node is only used to introduce the controller,
4611 -- the back-end has no use for it for a discriminated
4614 Set_Freeze_Node
(Def_Id
, Empty
);
4615 Set_Has_Delayed_Freeze
(Def_Id
, False);
4620 -- Freeze processing for array types
4622 elsif Is_Array_Type
(Def_Id
) then
4623 Freeze_Array_Type
(N
);
4625 -- Freeze processing for access types
4627 -- For pool-specific access types, find out the pool object used for
4628 -- this type, needs actual expansion of it in some cases. Here are the
4629 -- different cases :
4631 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;"
4632 -- ---> don't use any storage pool
4634 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr.
4636 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment);
4638 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
4639 -- ---> Storage Pool is the specified one
4641 -- See GNAT Pool packages in the Run-Time for more details
4643 elsif Ekind
(Def_Id
) = E_Access_Type
4644 or else Ekind
(Def_Id
) = E_General_Access_Type
4647 Loc
: constant Source_Ptr
:= Sloc
(N
);
4648 Desig_Type
: constant Entity_Id
:= Designated_Type
(Def_Id
);
4649 Pool_Object
: Entity_Id
;
4652 Freeze_Action_Typ
: Entity_Id
;
4655 if Has_Storage_Size_Clause
(Def_Id
) then
4656 Siz_Exp
:= Expression
(Parent
(Storage_Size_Variable
(Def_Id
)));
4663 -- Rep Clause "for Def_Id'Storage_Size use 0;"
4664 -- ---> don't use any storage pool
4666 if Has_Storage_Size_Clause
(Def_Id
)
4667 and then Compile_Time_Known_Value
(Siz_Exp
)
4668 and then Expr_Value
(Siz_Exp
) = 0
4674 -- Rep Clause : for Def_Id'Storage_Size use Expr.
4676 -- Def_Id__Pool : Stack_Bounded_Pool
4677 -- (Expr, DT'Size, DT'Alignment);
4679 elsif Has_Storage_Size_Clause
(Def_Id
) then
4685 -- For unconstrained composite types we give a size of
4686 -- zero so that the pool knows that it needs a special
4687 -- algorithm for variable size object allocation.
4689 if Is_Composite_Type
(Desig_Type
)
4690 and then not Is_Constrained
(Desig_Type
)
4693 Make_Integer_Literal
(Loc
, 0);
4696 Make_Integer_Literal
(Loc
, Maximum_Alignment
);
4700 Make_Attribute_Reference
(Loc
,
4701 Prefix
=> New_Reference_To
(Desig_Type
, Loc
),
4702 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
);
4705 Make_Attribute_Reference
(Loc
,
4706 Prefix
=> New_Reference_To
(Desig_Type
, Loc
),
4707 Attribute_Name
=> Name_Alignment
);
4711 Make_Defining_Identifier
(Loc
,
4712 Chars
=> New_External_Name
(Chars
(Def_Id
), 'P'));
4714 -- We put the code associated with the pools in the
4715 -- entity that has the later freeze node, usually the
4716 -- acces type but it can also be the designated_type;
4717 -- because the pool code requires both those types to be
4720 if Is_Frozen
(Desig_Type
)
4721 and then (not Present
(Freeze_Node
(Desig_Type
))
4722 or else Analyzed
(Freeze_Node
(Desig_Type
)))
4724 Freeze_Action_Typ
:= Def_Id
;
4726 -- A Taft amendment type cannot get the freeze actions
4727 -- since the full view is not there.
4729 elsif Is_Incomplete_Or_Private_Type
(Desig_Type
)
4730 and then No
(Full_View
(Desig_Type
))
4732 Freeze_Action_Typ
:= Def_Id
;
4735 Freeze_Action_Typ
:= Desig_Type
;
4738 Append_Freeze_Action
(Freeze_Action_Typ
,
4739 Make_Object_Declaration
(Loc
,
4740 Defining_Identifier
=> Pool_Object
,
4741 Object_Definition
=>
4742 Make_Subtype_Indication
(Loc
,
4745 (RTE
(RE_Stack_Bounded_Pool
), Loc
),
4748 Make_Index_Or_Discriminant_Constraint
(Loc
,
4749 Constraints
=> New_List
(
4751 -- First discriminant is the Pool Size
4754 Storage_Size_Variable
(Def_Id
), Loc
),
4756 -- Second discriminant is the element size
4760 -- Third discriminant is the alignment
4765 Set_Associated_Storage_Pool
(Def_Id
, Pool_Object
);
4769 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
4770 -- ---> Storage Pool is the specified one
4772 elsif Present
(Associated_Storage_Pool
(Def_Id
)) then
4774 -- Nothing to do the associated storage pool has been attached
4775 -- when analyzing the rep. clause
4780 -- For access-to-controlled types (including class-wide types
4781 -- and Taft-amendment types which potentially have controlled
4782 -- components), expand the list controller object that will
4783 -- store the dynamically allocated objects. Do not do this
4784 -- transformation for expander-generated access types, but do it
4785 -- for types that are the full view of types derived from other
4786 -- private types. Also suppress the list controller in the case
4787 -- of a designated type with convention Java, since this is used
4788 -- when binding to Java API specs, where there's no equivalent
4789 -- of a finalization list and we don't want to pull in the
4790 -- finalization support if not needed.
4792 if not Comes_From_Source
(Def_Id
)
4793 and then not Has_Private_Declaration
(Def_Id
)
4797 elsif (Controlled_Type
(Desig_Type
)
4798 and then Convention
(Desig_Type
) /= Convention_Java
)
4800 (Is_Incomplete_Or_Private_Type
(Desig_Type
)
4801 and then No
(Full_View
(Desig_Type
))
4803 -- An exception is made for types defined in the run-time
4804 -- because Ada.Tags.Tag itself is such a type and cannot
4805 -- afford this unnecessary overhead that would generates a
4806 -- loop in the expansion scheme...
4808 and then not In_Runtime
(Def_Id
)
4810 -- Another exception is if Restrictions (No_Finalization)
4811 -- is active, since then we know nothing is controlled.
4813 and then not Restriction_Active
(No_Finalization
))
4815 -- If the designated type is not frozen yet, its controlled
4816 -- status must be retrieved explicitly.
4818 or else (Is_Array_Type
(Desig_Type
)
4819 and then not Is_Frozen
(Desig_Type
)
4820 and then Controlled_Type
(Component_Type
(Desig_Type
)))
4822 Set_Associated_Final_Chain
(Def_Id
,
4823 Make_Defining_Identifier
(Loc
,
4824 New_External_Name
(Chars
(Def_Id
), 'L')));
4826 Append_Freeze_Action
(Def_Id
,
4827 Make_Object_Declaration
(Loc
,
4828 Defining_Identifier
=> Associated_Final_Chain
(Def_Id
),
4829 Object_Definition
=>
4830 New_Reference_To
(RTE
(RE_List_Controller
), Loc
)));
4834 -- Freeze processing for enumeration types
4836 elsif Ekind
(Def_Id
) = E_Enumeration_Type
then
4838 -- We only have something to do if we have a non-standard
4839 -- representation (i.e. at least one literal whose pos value
4840 -- is not the same as its representation)
4842 if Has_Non_Standard_Rep
(Def_Id
) then
4843 Freeze_Enumeration_Type
(N
);
4846 -- Private types that are completed by a derivation from a private
4847 -- type have an internally generated full view, that needs to be
4848 -- frozen. This must be done explicitly because the two views share
4849 -- the freeze node, and the underlying full view is not visible when
4850 -- the freeze node is analyzed.
4852 elsif Is_Private_Type
(Def_Id
)
4853 and then Is_Derived_Type
(Def_Id
)
4854 and then Present
(Full_View
(Def_Id
))
4855 and then Is_Itype
(Full_View
(Def_Id
))
4856 and then Has_Private_Declaration
(Full_View
(Def_Id
))
4857 and then Freeze_Node
(Full_View
(Def_Id
)) = N
4859 Set_Entity
(N
, Full_View
(Def_Id
));
4861 Set_Entity
(N
, Def_Id
);
4863 -- All other types require no expander action. There are such
4864 -- cases (e.g. task types and protected types). In such cases,
4865 -- the freeze nodes are there for use by Gigi.
4869 Freeze_Stream_Operations
(N
, Def_Id
);
4872 when RE_Not_Available
=>
4876 -------------------------
4877 -- Get_Simple_Init_Val --
4878 -------------------------
4880 function Get_Simple_Init_Val
4882 Loc
: Source_Ptr
) return Node_Id
4890 -- For a private type, we should always have an underlying type
4891 -- (because this was already checked in Needs_Simple_Initialization).
4892 -- What we do is to get the value for the underlying type and then
4893 -- do an Unchecked_Convert to the private type.
4895 if Is_Private_Type
(T
) then
4896 Val
:= Get_Simple_Init_Val
(Underlying_Type
(T
), Loc
);
4898 -- A special case, if the underlying value is null, then qualify
4899 -- it with the underlying type, so that the null is properly typed
4900 -- Similarly, if it is an aggregate it must be qualified, because
4901 -- an unchecked conversion does not provide a context for it.
4903 if Nkind
(Val
) = N_Null
4904 or else Nkind
(Val
) = N_Aggregate
4907 Make_Qualified_Expression
(Loc
,
4909 New_Occurrence_Of
(Underlying_Type
(T
), Loc
),
4913 Result
:= Unchecked_Convert_To
(T
, Val
);
4915 -- Don't truncate result (important for Initialize/Normalize_Scalars)
4917 if Nkind
(Result
) = N_Unchecked_Type_Conversion
4918 and then Is_Scalar_Type
(Underlying_Type
(T
))
4920 Set_No_Truncation
(Result
);
4925 -- For scalars, we must have normalize/initialize scalars case
4927 elsif Is_Scalar_Type
(T
) then
4928 pragma Assert
(Init_Or_Norm_Scalars
);
4930 -- Processing for Normalize_Scalars case
4932 if Normalize_Scalars
then
4934 -- First prepare a value (out of subtype range if possible)
4936 if Is_Real_Type
(T
) or else Is_Integer_Type
(T
) then
4938 Make_Attribute_Reference
(Loc
,
4939 Prefix
=> New_Occurrence_Of
(Base_Type
(T
), Loc
),
4940 Attribute_Name
=> Name_First
);
4942 elsif Is_Modular_Integer_Type
(T
) then
4944 Make_Attribute_Reference
(Loc
,
4945 Prefix
=> New_Occurrence_Of
(Base_Type
(T
), Loc
),
4946 Attribute_Name
=> Name_Last
);
4949 pragma Assert
(Is_Enumeration_Type
(T
));
4951 if Esize
(T
) <= 8 then
4952 Typ
:= RTE
(RE_Unsigned_8
);
4953 elsif Esize
(T
) <= 16 then
4954 Typ
:= RTE
(RE_Unsigned_16
);
4955 elsif Esize
(T
) <= 32 then
4956 Typ
:= RTE
(RE_Unsigned_32
);
4958 Typ
:= RTE
(RE_Unsigned_64
);
4962 Make_Attribute_Reference
(Loc
,
4963 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4964 Attribute_Name
=> Name_Last
);
4967 -- Here for Initialize_Scalars case
4970 if Is_Floating_Point_Type
(T
) then
4971 if Root_Type
(T
) = Standard_Short_Float
then
4972 Val_RE
:= RE_IS_Isf
;
4973 elsif Root_Type
(T
) = Standard_Float
then
4974 Val_RE
:= RE_IS_Ifl
;
4975 elsif Root_Type
(T
) = Standard_Long_Float
then
4976 Val_RE
:= RE_IS_Ilf
;
4977 else pragma Assert
(Root_Type
(T
) = Standard_Long_Long_Float
);
4978 Val_RE
:= RE_IS_Ill
;
4981 elsif Is_Unsigned_Type
(Base_Type
(T
)) then
4982 if Esize
(T
) = 8 then
4983 Val_RE
:= RE_IS_Iu1
;
4984 elsif Esize
(T
) = 16 then
4985 Val_RE
:= RE_IS_Iu2
;
4986 elsif Esize
(T
) = 32 then
4987 Val_RE
:= RE_IS_Iu4
;
4988 else pragma Assert
(Esize
(T
) = 64);
4989 Val_RE
:= RE_IS_Iu8
;
4993 if Esize
(T
) = 8 then
4994 Val_RE
:= RE_IS_Is1
;
4995 elsif Esize
(T
) = 16 then
4996 Val_RE
:= RE_IS_Is2
;
4997 elsif Esize
(T
) = 32 then
4998 Val_RE
:= RE_IS_Is4
;
4999 else pragma Assert
(Esize
(T
) = 64);
5000 Val_RE
:= RE_IS_Is8
;
5004 Val
:= New_Occurrence_Of
(RTE
(Val_RE
), Loc
);
5007 -- The final expression is obtained by doing an unchecked
5008 -- conversion of this result to the base type of the
5009 -- required subtype. We use the base type to avoid the
5010 -- unchecked conversion from chopping bits, and then we
5011 -- set Kill_Range_Check to preserve the "bad" value.
5013 Result
:= Unchecked_Convert_To
(Base_Type
(T
), Val
);
5015 -- Ensure result is not truncated, since we want the "bad" bits
5016 -- and also kill range check on result.
5018 if Nkind
(Result
) = N_Unchecked_Type_Conversion
then
5019 Set_No_Truncation
(Result
);
5020 Set_Kill_Range_Check
(Result
, True);
5025 -- String or Wide_String (must have Initialize_Scalars set)
5027 elsif Root_Type
(T
) = Standard_String
5029 Root_Type
(T
) = Standard_Wide_String
5031 pragma Assert
(Init_Or_Norm_Scalars
);
5034 Make_Aggregate
(Loc
,
5035 Component_Associations
=> New_List
(
5036 Make_Component_Association
(Loc
,
5037 Choices
=> New_List
(
5038 Make_Others_Choice
(Loc
)),
5040 Get_Simple_Init_Val
(Component_Type
(T
), Loc
))));
5042 -- Access type is initialized to null
5044 elsif Is_Access_Type
(T
) then
5048 -- No other possibilities should arise, since we should only be
5049 -- calling Get_Simple_Init_Val if Needs_Simple_Initialization
5050 -- returned True, indicating one of the above cases held.
5053 raise Program_Error
;
5057 when RE_Not_Available
=>
5059 end Get_Simple_Init_Val
;
5061 ------------------------------
5062 -- Has_New_Non_Standard_Rep --
5063 ------------------------------
5065 function Has_New_Non_Standard_Rep
(T
: Entity_Id
) return Boolean is
5067 if not Is_Derived_Type
(T
) then
5068 return Has_Non_Standard_Rep
(T
)
5069 or else Has_Non_Standard_Rep
(Root_Type
(T
));
5071 -- If Has_Non_Standard_Rep is not set on the derived type, the
5072 -- representation is fully inherited.
5074 elsif not Has_Non_Standard_Rep
(T
) then
5078 return First_Rep_Item
(T
) /= First_Rep_Item
(Root_Type
(T
));
5080 -- May need a more precise check here: the First_Rep_Item may
5081 -- be a stream attribute, which does not affect the representation
5084 end Has_New_Non_Standard_Rep
;
5090 function In_Runtime
(E
: Entity_Id
) return Boolean is
5091 S1
: Entity_Id
:= Scope
(E
);
5094 while Scope
(S1
) /= Standard_Standard
loop
5098 return Chars
(S1
) = Name_System
or else Chars
(S1
) = Name_Ada
;
5105 function Init_Formals
(Typ
: Entity_Id
) return List_Id
is
5106 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5110 -- First parameter is always _Init : in out typ. Note that we need
5111 -- this to be in/out because in the case of the task record value,
5112 -- there are default record fields (_Priority, _Size, -Task_Info)
5113 -- that may be referenced in the generated initialization routine.
5115 Formals
:= New_List
(
5116 Make_Parameter_Specification
(Loc
,
5117 Defining_Identifier
=>
5118 Make_Defining_Identifier
(Loc
, Name_uInit
),
5120 Out_Present
=> True,
5121 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
5123 -- For task record value, or type that contains tasks, add two more
5124 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain
5125 -- We also add these parameters for the task record type case.
5128 or else (Is_Record_Type
(Typ
) and then Is_Task_Record_Type
(Typ
))
5131 Make_Parameter_Specification
(Loc
,
5132 Defining_Identifier
=>
5133 Make_Defining_Identifier
(Loc
, Name_uMaster
),
5134 Parameter_Type
=> New_Reference_To
(RTE
(RE_Master_Id
), Loc
)));
5137 Make_Parameter_Specification
(Loc
,
5138 Defining_Identifier
=>
5139 Make_Defining_Identifier
(Loc
, Name_uChain
),
5141 Out_Present
=> True,
5143 New_Reference_To
(RTE
(RE_Activation_Chain
), Loc
)));
5146 Make_Parameter_Specification
(Loc
,
5147 Defining_Identifier
=>
5148 Make_Defining_Identifier
(Loc
, Name_uTask_Name
),
5151 New_Reference_To
(Standard_String
, Loc
)));
5157 when RE_Not_Available
=>
5165 -- <Make_Eq_if shared components>
5167 -- when V1 => <Make_Eq_Case> on subcomponents
5169 -- when Vn => <Make_Eq_Case> on subcomponents
5172 function Make_Eq_Case
5175 Discr
: Entity_Id
:= Empty
) return List_Id
5177 Loc
: constant Source_Ptr
:= Sloc
(E
);
5178 Result
: constant List_Id
:= New_List
;
5183 Append_To
(Result
, Make_Eq_If
(E
, Component_Items
(CL
)));
5185 if No
(Variant_Part
(CL
)) then
5189 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(CL
)));
5191 if No
(Variant
) then
5195 Alt_List
:= New_List
;
5197 while Present
(Variant
) loop
5198 Append_To
(Alt_List
,
5199 Make_Case_Statement_Alternative
(Loc
,
5200 Discrete_Choices
=> New_Copy_List
(Discrete_Choices
(Variant
)),
5201 Statements
=> Make_Eq_Case
(E
, Component_List
(Variant
))));
5203 Next_Non_Pragma
(Variant
);
5206 -- If we have an Unchecked_Union, use one of the parameters that
5207 -- captures the discriminants.
5209 if Is_Unchecked_Union
(E
) then
5211 Make_Case_Statement
(Loc
,
5212 Expression
=> New_Reference_To
(Discr
, Loc
),
5213 Alternatives
=> Alt_List
));
5217 Make_Case_Statement
(Loc
,
5219 Make_Selected_Component
(Loc
,
5220 Prefix
=> Make_Identifier
(Loc
, Name_X
),
5221 Selector_Name
=> New_Copy
(Name
(Variant_Part
(CL
)))),
5222 Alternatives
=> Alt_List
));
5243 -- or a null statement if the list L is empty
5247 L
: List_Id
) return Node_Id
5249 Loc
: constant Source_Ptr
:= Sloc
(E
);
5251 Field_Name
: Name_Id
;
5256 return Make_Null_Statement
(Loc
);
5261 C
:= First_Non_Pragma
(L
);
5262 while Present
(C
) loop
5263 Field_Name
:= Chars
(Defining_Identifier
(C
));
5265 -- The tags must not be compared they are not part of the value.
5266 -- Note also that in the following, we use Make_Identifier for
5267 -- the component names. Use of New_Reference_To to identify the
5268 -- components would be incorrect because the wrong entities for
5269 -- discriminants could be picked up in the private type case.
5271 if Field_Name
/= Name_uTag
then
5272 Evolve_Or_Else
(Cond
,
5275 Make_Selected_Component
(Loc
,
5276 Prefix
=> Make_Identifier
(Loc
, Name_X
),
5278 Make_Identifier
(Loc
, Field_Name
)),
5281 Make_Selected_Component
(Loc
,
5282 Prefix
=> Make_Identifier
(Loc
, Name_Y
),
5284 Make_Identifier
(Loc
, Field_Name
))));
5287 Next_Non_Pragma
(C
);
5291 return Make_Null_Statement
(Loc
);
5295 Make_Implicit_If_Statement
(E
,
5297 Then_Statements
=> New_List
(
5298 Make_Return_Statement
(Loc
,
5299 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
5304 -------------------------------------
5305 -- Make_Predefined_Primitive_Specs --
5306 -------------------------------------
5308 procedure Make_Predefined_Primitive_Specs
5309 (Tag_Typ
: Entity_Id
;
5310 Predef_List
: out List_Id
;
5311 Renamed_Eq
: out Node_Id
)
5313 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
5314 Res
: constant List_Id
:= New_List
;
5316 Eq_Needed
: Boolean;
5318 Eq_Name
: Name_Id
:= Name_Op_Eq
;
5320 function Is_Predefined_Eq_Renaming
(Prim
: Node_Id
) return Boolean;
5321 -- Returns true if Prim is a renaming of an unresolved predefined
5322 -- equality operation.
5324 -------------------------------
5325 -- Is_Predefined_Eq_Renaming --
5326 -------------------------------
5328 function Is_Predefined_Eq_Renaming
(Prim
: Node_Id
) return Boolean is
5330 return Chars
(Prim
) /= Name_Op_Eq
5331 and then Present
(Alias
(Prim
))
5332 and then Comes_From_Source
(Prim
)
5333 and then Is_Intrinsic_Subprogram
(Alias
(Prim
))
5334 and then Chars
(Alias
(Prim
)) = Name_Op_Eq
;
5335 end Is_Predefined_Eq_Renaming
;
5337 -- Start of processing for Make_Predefined_Primitive_Specs
5340 Renamed_Eq
:= Empty
;
5342 -- Spec of _Alignment
5344 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
5346 Name
=> Name_uAlignment
,
5347 Profile
=> New_List
(
5348 Make_Parameter_Specification
(Loc
,
5349 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
5350 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
5352 Ret_Type
=> Standard_Integer
));
5356 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
5359 Profile
=> New_List
(
5360 Make_Parameter_Specification
(Loc
,
5361 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
5362 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
5364 Ret_Type
=> Standard_Long_Long_Integer
));
5366 -- Specs for dispatching stream attributes. We skip these for limited
5367 -- types, since there is no question of dispatching in the limited case.
5369 -- We also skip these operations if dispatching is not available
5370 -- or if streams are not available (since what's the point?)
5372 if Stream_Operations_OK
(Tag_Typ
) then
5374 Predef_Stream_Attr_Spec
(Loc
, Tag_Typ
, TSS_Stream_Read
));
5376 Predef_Stream_Attr_Spec
(Loc
, Tag_Typ
, TSS_Stream_Write
));
5378 Predef_Stream_Attr_Spec
(Loc
, Tag_Typ
, TSS_Stream_Input
));
5380 Predef_Stream_Attr_Spec
(Loc
, Tag_Typ
, TSS_Stream_Output
));
5383 -- Spec of "=" if expanded if the type is not limited and if a
5384 -- user defined "=" was not already declared for the non-full
5385 -- view of a private extension
5387 if not Is_Limited_Type
(Tag_Typ
) then
5390 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
5391 while Present
(Prim
) loop
5393 -- If a primitive is encountered that renames the predefined
5394 -- equality operator before reaching any explicit equality
5395 -- primitive, then we still need to create a predefined
5396 -- equality function, because calls to it can occur via
5397 -- the renaming. A new name is created for the equality
5398 -- to avoid conflicting with any user-defined equality.
5399 -- (Note that this doesn't account for renamings of
5400 -- equality nested within subpackages???)
5402 if Is_Predefined_Eq_Renaming
(Node
(Prim
)) then
5403 Eq_Name
:= New_External_Name
(Chars
(Node
(Prim
)), 'E');
5405 elsif Chars
(Node
(Prim
)) = Name_Op_Eq
5406 and then (No
(Alias
(Node
(Prim
)))
5407 or else Nkind
(Unit_Declaration_Node
(Node
(Prim
))) =
5408 N_Subprogram_Renaming_Declaration
)
5409 and then Etype
(First_Formal
(Node
(Prim
))) =
5410 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
5411 and then Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
5417 -- If the parent equality is abstract, the inherited equality is
5418 -- abstract as well, and no body can be created for for it.
5420 elsif Chars
(Node
(Prim
)) = Name_Op_Eq
5421 and then Present
(Alias
(Node
(Prim
)))
5422 and then Is_Abstract
(Alias
(Node
(Prim
)))
5431 -- If a renaming of predefined equality was found
5432 -- but there was no user-defined equality (so Eq_Needed
5433 -- is still true), then set the name back to Name_Op_Eq.
5434 -- But in the case where a user-defined equality was
5435 -- located after such a renaming, then the predefined
5436 -- equality function is still needed, so Eq_Needed must
5437 -- be set back to True.
5439 if Eq_Name
/= Name_Op_Eq
then
5441 Eq_Name
:= Name_Op_Eq
;
5448 Eq_Spec
:= Predef_Spec_Or_Body
(Loc
,
5451 Profile
=> New_List
(
5452 Make_Parameter_Specification
(Loc
,
5453 Defining_Identifier
=>
5454 Make_Defining_Identifier
(Loc
, Name_X
),
5455 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)),
5456 Make_Parameter_Specification
(Loc
,
5457 Defining_Identifier
=>
5458 Make_Defining_Identifier
(Loc
, Name_Y
),
5459 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
5460 Ret_Type
=> Standard_Boolean
);
5461 Append_To
(Res
, Eq_Spec
);
5463 if Eq_Name
/= Name_Op_Eq
then
5464 Renamed_Eq
:= Defining_Unit_Name
(Specification
(Eq_Spec
));
5466 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
5467 while Present
(Prim
) loop
5469 -- Any renamings of equality that appeared before an
5470 -- overriding equality must be updated to refer to
5471 -- the entity for the predefined equality, otherwise
5472 -- calls via the renaming would get incorrectly
5473 -- resolved to call the user-defined equality function.
5475 if Is_Predefined_Eq_Renaming
(Node
(Prim
)) then
5476 Set_Alias
(Node
(Prim
), Renamed_Eq
);
5478 -- Exit upon encountering a user-defined equality
5480 elsif Chars
(Node
(Prim
)) = Name_Op_Eq
5481 and then No
(Alias
(Node
(Prim
)))
5491 -- Spec for dispatching assignment
5493 Append_To
(Res
, Predef_Spec_Or_Body
(Loc
,
5495 Name
=> Name_uAssign
,
5496 Profile
=> New_List
(
5497 Make_Parameter_Specification
(Loc
,
5498 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
5499 Out_Present
=> True,
5500 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)),
5502 Make_Parameter_Specification
(Loc
,
5503 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
5504 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)))));
5507 -- Specs for finalization actions that may be required in case a
5508 -- future extension contain a controlled element. We generate those
5509 -- only for root tagged types where they will get dummy bodies or
5510 -- when the type has controlled components and their body must be
5511 -- generated. It is also impossible to provide those for tagged
5512 -- types defined within s-finimp since it would involve circularity
5515 if In_Finalization_Root
(Tag_Typ
) then
5518 -- We also skip these if finalization is not available
5520 elsif Restriction_Active
(No_Finalization
) then
5523 elsif Etype
(Tag_Typ
) = Tag_Typ
or else Controlled_Type
(Tag_Typ
) then
5524 if not Is_Limited_Type
(Tag_Typ
) then
5526 Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Adjust
));
5529 Append_To
(Res
, Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Finalize
));
5533 end Make_Predefined_Primitive_Specs
;
5535 ---------------------------------
5536 -- Needs_Simple_Initialization --
5537 ---------------------------------
5539 function Needs_Simple_Initialization
(T
: Entity_Id
) return Boolean is
5541 -- Check for private type, in which case test applies to the
5542 -- underlying type of the private type.
5544 if Is_Private_Type
(T
) then
5546 RT
: constant Entity_Id
:= Underlying_Type
(T
);
5549 if Present
(RT
) then
5550 return Needs_Simple_Initialization
(RT
);
5556 -- Cases needing simple initialization are access types, and, if pragma
5557 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
5560 elsif Is_Access_Type
(T
)
5561 or else (Init_Or_Norm_Scalars
and then (Is_Scalar_Type
(T
)))
5565 -- If Initialize/Normalize_Scalars is in effect, string objects also
5566 -- need initialization, unless they are created in the course of
5567 -- expanding an aggregate (since in the latter case they will be
5568 -- filled with appropriate initializing values before they are used).
5570 elsif Init_Or_Norm_Scalars
5572 (Root_Type
(T
) = Standard_String
5573 or else Root_Type
(T
) = Standard_Wide_String
)
5576 or else Nkind
(Associated_Node_For_Itype
(T
)) /= N_Aggregate
)
5583 end Needs_Simple_Initialization
;
5585 ----------------------
5586 -- Predef_Deep_Spec --
5587 ----------------------
5589 function Predef_Deep_Spec
5591 Tag_Typ
: Entity_Id
;
5592 Name
: TSS_Name_Type
;
5593 For_Body
: Boolean := False) return Node_Id
5599 if Name
= TSS_Deep_Finalize
then
5601 Type_B
:= Standard_Boolean
;
5605 Make_Parameter_Specification
(Loc
,
5606 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_L
),
5608 Out_Present
=> True,
5610 New_Reference_To
(RTE
(RE_Finalizable_Ptr
), Loc
)));
5611 Type_B
:= Standard_Short_Short_Integer
;
5615 Make_Parameter_Specification
(Loc
,
5616 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
5618 Out_Present
=> True,
5619 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)));
5622 Make_Parameter_Specification
(Loc
,
5623 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_B
),
5624 Parameter_Type
=> New_Reference_To
(Type_B
, Loc
)));
5626 return Predef_Spec_Or_Body
(Loc
,
5627 Name
=> Make_TSS_Name
(Tag_Typ
, Name
),
5630 For_Body
=> For_Body
);
5633 when RE_Not_Available
=>
5635 end Predef_Deep_Spec
;
5637 -------------------------
5638 -- Predef_Spec_Or_Body --
5639 -------------------------
5641 function Predef_Spec_Or_Body
5643 Tag_Typ
: Entity_Id
;
5646 Ret_Type
: Entity_Id
:= Empty
;
5647 For_Body
: Boolean := False) return Node_Id
5649 Id
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name
);
5653 Set_Is_Public
(Id
, Is_Public
(Tag_Typ
));
5655 -- The internal flag is set to mark these declarations because
5656 -- they have specific properties. First they are primitives even
5657 -- if they are not defined in the type scope (the freezing point
5658 -- is not necessarily in the same scope), furthermore the
5659 -- predefined equality can be overridden by a user-defined
5660 -- equality, no body will be generated in this case.
5662 Set_Is_Internal
(Id
);
5664 if not Debug_Generated_Code
then
5665 Set_Debug_Info_Off
(Id
);
5668 if No
(Ret_Type
) then
5670 Make_Procedure_Specification
(Loc
,
5671 Defining_Unit_Name
=> Id
,
5672 Parameter_Specifications
=> Profile
);
5675 Make_Function_Specification
(Loc
,
5676 Defining_Unit_Name
=> Id
,
5677 Parameter_Specifications
=> Profile
,
5679 New_Reference_To
(Ret_Type
, Loc
));
5682 -- If body case, return empty subprogram body. Note that this is
5683 -- ill-formed, because there is not even a null statement, and
5684 -- certainly not a return in the function case. The caller is
5685 -- expected to do surgery on the body to add the appropriate stuff.
5688 return Make_Subprogram_Body
(Loc
, Spec
, Empty_List
, Empty
);
5690 -- For the case of Input/Output attributes applied to an abstract type,
5691 -- generate abstract specifications. These will never be called,
5692 -- but we need the slots allocated in the dispatching table so
5693 -- that typ'Class'Input and typ'Class'Output will work properly.
5695 elsif (Is_TSS
(Name
, TSS_Stream_Input
)
5697 Is_TSS
(Name
, TSS_Stream_Output
))
5698 and then Is_Abstract
(Tag_Typ
)
5700 return Make_Abstract_Subprogram_Declaration
(Loc
, Spec
);
5702 -- Normal spec case, where we return a subprogram declaration
5705 return Make_Subprogram_Declaration
(Loc
, Spec
);
5707 end Predef_Spec_Or_Body
;
5709 -----------------------------
5710 -- Predef_Stream_Attr_Spec --
5711 -----------------------------
5713 function Predef_Stream_Attr_Spec
5715 Tag_Typ
: Entity_Id
;
5716 Name
: TSS_Name_Type
;
5717 For_Body
: Boolean := False) return Node_Id
5719 Ret_Type
: Entity_Id
;
5722 if Name
= TSS_Stream_Input
then
5723 Ret_Type
:= Tag_Typ
;
5728 return Predef_Spec_Or_Body
(Loc
,
5729 Name
=> Make_TSS_Name
(Tag_Typ
, Name
),
5731 Profile
=> Build_Stream_Attr_Profile
(Loc
, Tag_Typ
, Name
),
5732 Ret_Type
=> Ret_Type
,
5733 For_Body
=> For_Body
);
5734 end Predef_Stream_Attr_Spec
;
5736 ---------------------------------
5737 -- Predefined_Primitive_Bodies --
5738 ---------------------------------
5740 function Predefined_Primitive_Bodies
5741 (Tag_Typ
: Entity_Id
;
5742 Renamed_Eq
: Node_Id
) return List_Id
5744 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
5745 Res
: constant List_Id
:= New_List
;
5748 Eq_Needed
: Boolean;
5753 -- See if we have a predefined "=" operator
5755 if Present
(Renamed_Eq
) then
5757 Eq_Name
:= Chars
(Renamed_Eq
);
5763 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
5764 while Present
(Prim
) loop
5765 if Chars
(Node
(Prim
)) = Name_Op_Eq
5766 and then Is_Internal
(Node
(Prim
))
5769 Eq_Name
:= Name_Op_Eq
;
5776 -- Body of _Alignment
5778 Decl
:= Predef_Spec_Or_Body
(Loc
,
5780 Name
=> Name_uAlignment
,
5781 Profile
=> New_List
(
5782 Make_Parameter_Specification
(Loc
,
5783 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
5784 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
5786 Ret_Type
=> Standard_Integer
,
5789 Set_Handled_Statement_Sequence
(Decl
,
5790 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5791 Make_Return_Statement
(Loc
,
5793 Make_Attribute_Reference
(Loc
,
5794 Prefix
=> Make_Identifier
(Loc
, Name_X
),
5795 Attribute_Name
=> Name_Alignment
)))));
5797 Append_To
(Res
, Decl
);
5801 Decl
:= Predef_Spec_Or_Body
(Loc
,
5804 Profile
=> New_List
(
5805 Make_Parameter_Specification
(Loc
,
5806 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
5807 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
5809 Ret_Type
=> Standard_Long_Long_Integer
,
5812 Set_Handled_Statement_Sequence
(Decl
,
5813 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5814 Make_Return_Statement
(Loc
,
5816 Make_Attribute_Reference
(Loc
,
5817 Prefix
=> Make_Identifier
(Loc
, Name_X
),
5818 Attribute_Name
=> Name_Size
)))));
5820 Append_To
(Res
, Decl
);
5822 -- Bodies for Dispatching stream IO routines. We need these only for
5823 -- non-limited types (in the limited case there is no dispatching).
5824 -- We also skip them if dispatching or finalization are not available.
5826 if Stream_Operations_OK
(Tag_Typ
) then
5827 if No
(TSS
(Tag_Typ
, TSS_Stream_Read
)) then
5828 Build_Record_Read_Procedure
(Loc
, Tag_Typ
, Decl
, Ent
);
5829 Append_To
(Res
, Decl
);
5832 if No
(TSS
(Tag_Typ
, TSS_Stream_Write
)) then
5833 Build_Record_Write_Procedure
(Loc
, Tag_Typ
, Decl
, Ent
);
5834 Append_To
(Res
, Decl
);
5837 -- Skip bodies of _Input and _Output for the abstract case, since
5838 -- the corresponding specs are abstract (see Predef_Spec_Or_Body)
5840 if not Is_Abstract
(Tag_Typ
) then
5841 if No
(TSS
(Tag_Typ
, TSS_Stream_Input
)) then
5842 Build_Record_Or_Elementary_Input_Function
5843 (Loc
, Tag_Typ
, Decl
, Ent
);
5844 Append_To
(Res
, Decl
);
5847 if No
(TSS
(Tag_Typ
, TSS_Stream_Output
)) then
5848 Build_Record_Or_Elementary_Output_Procedure
5849 (Loc
, Tag_Typ
, Decl
, Ent
);
5850 Append_To
(Res
, Decl
);
5855 if not Is_Limited_Type
(Tag_Typ
) then
5857 -- Body for equality
5861 Decl
:= Predef_Spec_Or_Body
(Loc
,
5864 Profile
=> New_List
(
5865 Make_Parameter_Specification
(Loc
,
5866 Defining_Identifier
=>
5867 Make_Defining_Identifier
(Loc
, Name_X
),
5868 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)),
5870 Make_Parameter_Specification
(Loc
,
5871 Defining_Identifier
=>
5872 Make_Defining_Identifier
(Loc
, Name_Y
),
5873 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
5875 Ret_Type
=> Standard_Boolean
,
5879 Def
: constant Node_Id
:= Parent
(Tag_Typ
);
5880 Stmts
: constant List_Id
:= New_List
;
5881 Variant_Case
: Boolean := Has_Discriminants
(Tag_Typ
);
5882 Comps
: Node_Id
:= Empty
;
5883 Typ_Def
: Node_Id
:= Type_Definition
(Def
);
5886 if Variant_Case
then
5887 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
5888 Typ_Def
:= Record_Extension_Part
(Typ_Def
);
5891 if Present
(Typ_Def
) then
5892 Comps
:= Component_List
(Typ_Def
);
5895 Variant_Case
:= Present
(Comps
)
5896 and then Present
(Variant_Part
(Comps
));
5899 if Variant_Case
then
5901 Make_Eq_If
(Tag_Typ
, Discriminant_Specifications
(Def
)));
5902 Append_List_To
(Stmts
, Make_Eq_Case
(Tag_Typ
, Comps
));
5904 Make_Return_Statement
(Loc
,
5905 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
5909 Make_Return_Statement
(Loc
,
5911 Expand_Record_Equality
(Tag_Typ
,
5913 Lhs
=> Make_Identifier
(Loc
, Name_X
),
5914 Rhs
=> Make_Identifier
(Loc
, Name_Y
),
5915 Bodies
=> Declarations
(Decl
))));
5918 Set_Handled_Statement_Sequence
(Decl
,
5919 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
5921 Append_To
(Res
, Decl
);
5924 -- Body for dispatching assignment
5926 Decl
:= Predef_Spec_Or_Body
(Loc
,
5928 Name
=> Name_uAssign
,
5929 Profile
=> New_List
(
5930 Make_Parameter_Specification
(Loc
,
5931 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_X
),
5932 Out_Present
=> True,
5933 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
)),
5935 Make_Parameter_Specification
(Loc
,
5936 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_Y
),
5937 Parameter_Type
=> New_Reference_To
(Tag_Typ
, Loc
))),
5940 Set_Handled_Statement_Sequence
(Decl
,
5941 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5942 Make_Assignment_Statement
(Loc
,
5943 Name
=> Make_Identifier
(Loc
, Name_X
),
5944 Expression
=> Make_Identifier
(Loc
, Name_Y
)))));
5946 Append_To
(Res
, Decl
);
5949 -- Generate dummy bodies for finalization actions of types that have
5950 -- no controlled components.
5952 -- Skip this processing if we are in the finalization routine in the
5953 -- runtime itself, otherwise we get hopelessly circularly confused!
5955 if In_Finalization_Root
(Tag_Typ
) then
5958 -- Skip this if finalization is not available
5960 elsif Restriction_Active
(No_Finalization
) then
5963 elsif (Etype
(Tag_Typ
) = Tag_Typ
or else Is_Controlled
(Tag_Typ
))
5964 and then not Has_Controlled_Component
(Tag_Typ
)
5966 if not Is_Limited_Type
(Tag_Typ
) then
5967 Decl
:= Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Adjust
, True);
5969 if Is_Controlled
(Tag_Typ
) then
5970 Set_Handled_Statement_Sequence
(Decl
,
5971 Make_Handled_Sequence_Of_Statements
(Loc
,
5973 Ref
=> Make_Identifier
(Loc
, Name_V
),
5975 Flist_Ref
=> Make_Identifier
(Loc
, Name_L
),
5976 With_Attach
=> Make_Identifier
(Loc
, Name_B
))));
5979 Set_Handled_Statement_Sequence
(Decl
,
5980 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5981 Make_Null_Statement
(Loc
))));
5984 Append_To
(Res
, Decl
);
5987 Decl
:= Predef_Deep_Spec
(Loc
, Tag_Typ
, TSS_Deep_Finalize
, True);
5989 if Is_Controlled
(Tag_Typ
) then
5990 Set_Handled_Statement_Sequence
(Decl
,
5991 Make_Handled_Sequence_Of_Statements
(Loc
,
5993 Ref
=> Make_Identifier
(Loc
, Name_V
),
5995 With_Detach
=> Make_Identifier
(Loc
, Name_B
))));
5998 Set_Handled_Statement_Sequence
(Decl
,
5999 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
6000 Make_Null_Statement
(Loc
))));
6003 Append_To
(Res
, Decl
);
6007 end Predefined_Primitive_Bodies
;
6009 ---------------------------------
6010 -- Predefined_Primitive_Freeze --
6011 ---------------------------------
6013 function Predefined_Primitive_Freeze
6014 (Tag_Typ
: Entity_Id
) return List_Id
6016 Loc
: constant Source_Ptr
:= Sloc
(Tag_Typ
);
6017 Res
: constant List_Id
:= New_List
;
6022 Prim
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
6023 while Present
(Prim
) loop
6024 if Is_Internal
(Node
(Prim
)) then
6025 Frnodes
:= Freeze_Entity
(Node
(Prim
), Loc
);
6027 if Present
(Frnodes
) then
6028 Append_List_To
(Res
, Frnodes
);
6036 end Predefined_Primitive_Freeze
;
6038 --------------------------
6039 -- Stream_Operations_OK --
6040 --------------------------
6042 function Stream_Operations_OK
(Typ
: Entity_Id
) return Boolean is
6045 not Is_Limited_Type
(Typ
)
6046 and then RTE_Available
(RE_Tag
)
6047 and then RTE_Available
(RE_Root_Stream_Type
)
6048 and then not Restriction_Active
(No_Dispatch
)
6049 and then not Restriction_Active
(No_Streams
);
6050 end Stream_Operations_OK
;