]>
Commit | Line | Data |
---|---|---|
70482933 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- E X P _ C H 3 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
cccef051 | 9 | -- Copyright (C) 1992-2023, Free Software Foundation, Inc. -- |
70482933 RK |
10 | -- -- |
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- -- | |
93188a0b | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
70482933 RK |
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 -- | |
93188a0b GD |
18 | -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
19 | -- http://www.gnu.org/licenses for a complete copy of the license. -- | |
70482933 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
f459afaa | 26 | with Accessibility; use Accessibility; |
104f58db BD |
27 | with Aspects; use Aspects; |
28 | with Atree; use Atree; | |
29 | with Checks; use Checks; | |
475e1d24 | 30 | with Contracts; use Contracts; |
104f58db | 31 | with Einfo; use Einfo; |
76f9c7f4 | 32 | with Einfo.Entities; use Einfo.Entities; |
104f58db BD |
33 | with Einfo.Utils; use Einfo.Utils; |
34 | with Errout; use Errout; | |
a671959b | 35 | with Expander; use Expander; |
104f58db BD |
36 | with Exp_Aggr; use Exp_Aggr; |
37 | with Exp_Atag; use Exp_Atag; | |
38 | with Exp_Ch4; use Exp_Ch4; | |
39 | with Exp_Ch6; use Exp_Ch6; | |
40 | with Exp_Ch7; use Exp_Ch7; | |
41 | with Exp_Ch9; use Exp_Ch9; | |
42 | with Exp_Dbug; use Exp_Dbug; | |
43 | with Exp_Disp; use Exp_Disp; | |
44 | with Exp_Dist; use Exp_Dist; | |
110d0820 | 45 | with Exp_Put_Image; |
104f58db BD |
46 | with Exp_Smem; use Exp_Smem; |
47 | with Exp_Strm; use Exp_Strm; | |
104f58db BD |
48 | with Exp_Util; use Exp_Util; |
49 | with Freeze; use Freeze; | |
50 | with Ghost; use Ghost; | |
51 | with Lib; use Lib; | |
52 | with Namet; use Namet; | |
53 | with Nlists; use Nlists; | |
54 | with Nmake; use Nmake; | |
55 | with Opt; use Opt; | |
56 | with Restrict; use Restrict; | |
57 | with Rident; use Rident; | |
58 | with Rtsfind; use Rtsfind; | |
59 | with Sem; use Sem; | |
60 | with Sem_Aux; use Sem_Aux; | |
61 | with Sem_Attr; use Sem_Attr; | |
62 | with Sem_Cat; use Sem_Cat; | |
63 | with Sem_Ch3; use Sem_Ch3; | |
64 | with Sem_Ch6; use Sem_Ch6; | |
65 | with Sem_Ch8; use Sem_Ch8; | |
66 | with Sem_Disp; use Sem_Disp; | |
67 | with Sem_Eval; use Sem_Eval; | |
68 | with Sem_Mech; use Sem_Mech; | |
69 | with Sem_Res; use Sem_Res; | |
70 | with Sem_SCIL; use Sem_SCIL; | |
71 | with Sem_Type; use Sem_Type; | |
72 | with Sem_Util; use Sem_Util; | |
73 | with Sinfo; use Sinfo; | |
74 | with Sinfo.Nodes; use Sinfo.Nodes; | |
75 | with Sinfo.Utils; use Sinfo.Utils; | |
76 | with Stand; use Stand; | |
77 | with Snames; use Snames; | |
78 | with Tbuild; use Tbuild; | |
79 | with Ttypes; use Ttypes; | |
80 | with Validsw; use Validsw; | |
70482933 RK |
81 | |
82 | package body Exp_Ch3 is | |
83 | ||
84 | ----------------------- | |
85 | -- Local Subprograms -- | |
86 | ----------------------- | |
87 | ||
88 | procedure Adjust_Discriminants (Rtype : Entity_Id); | |
89 | -- This is used when freezing a record type. It attempts to construct | |
90 | -- more restrictive subtypes for discriminants so that the max size of | |
91 | -- the record can be calculated more accurately. See the body of this | |
92 | -- procedure for details. | |
93 | ||
94 | procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id); | |
95 | -- Build initialization procedure for given array type. Nod is a node | |
96 | -- used for attachment of any actions required in its construction. | |
97 | -- It also supplies the source location used for the procedure. | |
98 | ||
70482933 RK |
99 | function Build_Discriminant_Formals |
100 | (Rec_Id : Entity_Id; | |
2e071734 | 101 | Use_Dl : Boolean) return List_Id; |
70482933 | 102 | -- This function uses the discriminants of a type to build a list of |
5568b57c AC |
103 | -- formal parameters, used in Build_Init_Procedure among other places. |
104 | -- If the flag Use_Dl is set, the list is built using the already | |
105 | -- defined discriminals of the type, as is the case for concurrent | |
106 | -- types with discriminants. Otherwise new identifiers are created, | |
107 | -- with the source names of the discriminants. | |
70482933 | 108 | |
eb1091dd SB |
109 | procedure Build_Discr_Checking_Funcs (N : Node_Id); |
110 | -- For each variant component, builds a function which checks whether | |
111 | -- the component name is consistent with the current discriminants | |
112 | -- and sets the component's Dcheck_Function attribute to refer to it. | |
113 | -- N is the full type declaration node; the discriminant checking | |
114 | -- functions are inserted after this node. | |
115 | ||
47cc8d6b ES |
116 | function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id; |
117 | -- This function builds a static aggregate that can serve as the initial | |
118 | -- value for an array type whose bounds are static, and whose component | |
119 | -- type is a composite type that has a static equivalent aggregate. | |
120 | -- The equivalent array aggregate is used both for object initialization | |
121 | -- and for component initialization, when used in the following function. | |
122 | ||
123 | function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id; | |
124 | -- This function builds a static aggregate that can serve as the initial | |
125 | -- value for a record type whose components are scalar and initialized | |
04df6250 | 126 | -- with compile-time values, or arrays with similar initialization or |
47cc8d6b ES |
127 | -- defaults. When possible, initialization of an object of the type can |
128 | -- be achieved by using a copy of the aggregate as an initial value, thus | |
129 | -- removing the implicit call that would otherwise constitute elaboration | |
130 | -- code. | |
131 | ||
df3e68b1 | 132 | procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id); |
70482933 | 133 | -- Build record initialization procedure. N is the type declaration |
df3e68b1 | 134 | -- node, and Rec_Ent is the corresponding entity for the record type. |
70482933 | 135 | |
26fd4eae AC |
136 | procedure Build_Slice_Assignment (Typ : Entity_Id); |
137 | -- Build assignment procedure for one-dimensional arrays of controlled | |
138 | -- types. Other array and slice assignments are expanded in-line, but | |
139 | -- the code expansion for controlled components (when control actions | |
fff7a6d9 | 140 | -- are active) can lead to very large blocks that GCC handles poorly. |
26fd4eae | 141 | |
d151d6a3 | 142 | procedure Build_Untagged_Equality (Typ : Entity_Id); |
7a963087 RD |
143 | -- AI05-0123: Equality on untagged records composes. This procedure |
144 | -- builds the equality routine for an untagged record that has components | |
145 | -- of a record type that has user-defined primitive equality operations. | |
d151d6a3 AC |
146 | -- The resulting operation is a TSS subprogram. |
147 | ||
07fc65c4 | 148 | procedure Check_Stream_Attributes (Typ : Entity_Id); |
47cc8d6b ES |
149 | -- Check that if a limited extension has a parent with user-defined stream |
150 | -- attributes, and does not itself have user-defined stream-attributes, | |
151 | -- then any limited component of the extension also has the corresponding | |
152 | -- user-defined stream attributes. | |
07fc65c4 | 153 | |
3476f949 JM |
154 | procedure Clean_Task_Names |
155 | (Typ : Entity_Id; | |
156 | Proc_Id : Entity_Id); | |
157 | -- If an initialization procedure includes calls to generate names | |
158 | -- for task subcomponents, indicate that secondary stack cleanup is | |
159 | -- needed after an initialization. Typ is the component type, and Proc_Id | |
160 | -- the initialization procedure for the enclosing composite type. | |
161 | ||
eb1091dd SB |
162 | procedure Copy_Discr_Checking_Funcs (N : Node_Id); |
163 | -- For a derived untagged type, copy the attributes that were set | |
164 | -- for the components of the parent type onto the components of the | |
165 | -- derived type. No new subprograms are constructed. | |
166 | -- N is the full type declaration node, as for Build_Discr_Checking_Funcs. | |
167 | ||
e80d72ea | 168 | procedure Expand_Freeze_Array_Type (N : Node_Id); |
70482933 RK |
169 | -- Freeze an array type. Deals with building the initialization procedure, |
170 | -- creating the packed array type for a packed array and also with the | |
171 | -- creation of the controlling procedures for the controlled case. The | |
172 | -- argument N is the N_Freeze_Entity node for the type. | |
173 | ||
df3e68b1 HK |
174 | procedure Expand_Freeze_Class_Wide_Type (N : Node_Id); |
175 | -- Freeze a class-wide type. Build routine Finalize_Address for the purpose | |
176 | -- of finalizing controlled derivations from the class-wide's root type. | |
177 | ||
e80d72ea | 178 | procedure Expand_Freeze_Enumeration_Type (N : Node_Id); |
70482933 RK |
179 | -- Freeze enumeration type with non-standard representation. Builds the |
180 | -- array and function needed to convert between enumeration pos and | |
181 | -- enumeration representation values. N is the N_Freeze_Entity node | |
182 | -- for the type. | |
183 | ||
e80d72ea | 184 | procedure Expand_Freeze_Record_Type (N : Node_Id); |
70482933 RK |
185 | -- Freeze record type. Builds all necessary discriminant checking |
186 | -- and other ancillary functions, and builds dispatch tables where | |
187 | -- needed. The argument N is the N_Freeze_Entity node. This processing | |
188 | -- applies only to E_Record_Type entities, not to class wide types, | |
189 | -- record subtypes, or private types. | |
190 | ||
e477d718 AC |
191 | procedure Expand_Tagged_Root (T : Entity_Id); |
192 | -- Add a field _Tag at the beginning of the record. This field carries | |
193 | -- the value of the access to the Dispatch table. This procedure is only | |
194 | -- called on root type, the _Tag field being inherited by the descendants. | |
195 | ||
07fc65c4 GB |
196 | procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id); |
197 | -- Treat user-defined stream operations as renaming_as_body if the | |
198 | -- subprogram they rename is not frozen when the type is frozen. | |
199 | ||
b77029ff SB |
200 | package Initialization_Control is |
201 | ||
202 | function Requires_Late_Init | |
203 | (Decl : Node_Id; Rec_Type : Entity_Id) return Boolean; | |
204 | -- Return True iff the given component declaration requires late | |
205 | -- initialization, as defined by 3.3.1 (8.1/5). | |
206 | ||
207 | function Has_Late_Init_Component | |
208 | (Tagged_Rec_Type : Entity_Id) return Boolean; | |
209 | -- Return True iff the given tagged record type has at least one | |
210 | -- component that requires late initialization; this includes | |
211 | -- components of ancestor types. | |
212 | ||
213 | type Initialization_Mode is | |
214 | (Full_Init, Full_Init_Except_Tag, Early_Init_Only, Late_Init_Only); | |
215 | -- The initialization routine for a tagged type is passed in a | |
216 | -- formal parameter of this type, indicating what initialization | |
217 | -- is to be performed. This parameter defaults to Full_Init in all | |
218 | -- cases except when the init proc of a type extension (let's call | |
219 | -- that type T2) calls the init proc of its parent (let's call that | |
220 | -- type T1). In that case, one of the other 3 values will | |
221 | -- be passed in. In all three of those cases, the Tag component has | |
222 | -- already been initialized before the call and is therefore not to be | |
223 | -- modified. T2's init proc will either call T1's init proc | |
224 | -- once (with Full_Init_Except_Tag as the parameter value) or twice | |
225 | -- (first with Early_Init_Only, then later with Late_Init_Only), | |
226 | -- depending on the result returned by Has_Late_Init_Component (T1). | |
227 | -- In the latter case, the first call does not initialize any | |
228 | -- components that require late initialization and the second call | |
229 | -- then performs that deferred initialization. | |
230 | -- Strictly speaking, the formal parameter subtype is actually Natural | |
231 | -- but calls will only pass in values corresponding to literals | |
232 | -- of this enumeration type. | |
233 | ||
234 | function Make_Mode_Literal | |
235 | (Loc : Source_Ptr; Mode : Initialization_Mode) return Node_Id | |
236 | is (Make_Integer_Literal (Loc, Initialization_Mode'Pos (Mode))); | |
237 | -- Generate an integer literal for a given mode value. | |
238 | ||
239 | function Tag_Init_Condition | |
240 | (Loc : Source_Ptr; | |
241 | Init_Control_Formal : Entity_Id) return Node_Id; | |
242 | function Early_Init_Condition | |
243 | (Loc : Source_Ptr; | |
244 | Init_Control_Formal : Entity_Id) return Node_Id; | |
245 | function Late_Init_Condition | |
246 | (Loc : Source_Ptr; | |
247 | Init_Control_Formal : Entity_Id) return Node_Id; | |
248 | -- These three functions each return a Boolean expression that | |
249 | -- can be used to determine whether a given call to the initialization | |
250 | -- expression for a tagged type should initialize (respectively) | |
251 | -- the Tag component, the non-Tag components that do not require late | |
252 | -- initialization, and the components that do require late | |
253 | -- initialization. | |
254 | ||
255 | end Initialization_Control; | |
256 | ||
47cc8d6b ES |
257 | procedure Initialization_Warning (E : Entity_Id); |
258 | -- If static elaboration of the package is requested, indicate | |
259 | -- when a type does meet the conditions for static initialization. If | |
260 | -- E is a type, it has components that have no static initialization. | |
261 | -- if E is an entity, its initial expression is not compile-time known. | |
262 | ||
a7837c08 | 263 | function Init_Formals (Typ : Entity_Id; Proc_Id : Entity_Id) return List_Id; |
70482933 RK |
264 | -- This function builds the list of formals for an initialization routine. |
265 | -- The first formal is always _Init with the given type. For task value | |
266 | -- record types and types containing tasks, three additional formals are | |
a7837c08 | 267 | -- added and Proc_Id is decorated with attribute Has_Master_Entity: |
70482933 | 268 | -- |
fbf5a39b AC |
269 | -- _Master : Master_Id |
270 | -- _Chain : in out Activation_Chain | |
271 | -- _Task_Name : String | |
70482933 RK |
272 | -- |
273 | -- The caller must append additional entries for discriminants if required. | |
274 | ||
0d66b596 AC |
275 | function Inline_Init_Proc (Typ : Entity_Id) return Boolean; |
276 | -- Returns true if the initialization procedure of Typ should be inlined | |
277 | ||
70482933 RK |
278 | function In_Runtime (E : Entity_Id) return Boolean; |
279 | -- Check if E is defined in the RTL (in a child of Ada or System). Used | |
280 | -- to avoid to bring in the overhead of _Input, _Output for tagged types. | |
281 | ||
c743425f EB |
282 | function Is_Null_Statement_List (Stmts : List_Id) return Boolean; |
283 | -- Returns true if Stmts is made of null statements only, possibly wrapped | |
284 | -- in a case statement, recursively. This latter pattern may occur for the | |
285 | -- initialization procedure of an unchecked union. | |
286 | ||
d151d6a3 AC |
287 | function Make_Eq_Body |
288 | (Typ : Entity_Id; | |
289 | Eq_Name : Name_Id) return Node_Id; | |
290 | -- Build the body of a primitive equality operation for a tagged record | |
feab3549 | 291 | -- type, or in Ada 2012 for any record type that has components with a |
d151d6a3 AC |
292 | -- user-defined equality. Factored out of Predefined_Primitive_Bodies. |
293 | ||
5d09245e | 294 | function Make_Eq_Case |
fa1608c2 ES |
295 | (E : Entity_Id; |
296 | CL : Node_Id; | |
297 | Discrs : Elist_Id := New_Elmt_List) return List_Id; | |
47cc8d6b | 298 | -- Building block for variant record equality. Defined to share the code |
1fb63e89 | 299 | -- between the tagged and untagged case. Given a Component_List node CL, |
47cc8d6b ES |
300 | -- it generates an 'if' followed by a 'case' statement that compares all |
301 | -- components of local temporaries named X and Y (that are declared as | |
302 | -- formals at some upper level). E provides the Sloc to be used for the | |
fa1608c2 ES |
303 | -- generated code. |
304 | -- | |
305 | -- IF E is an unchecked_union, Discrs is the list of formals created for | |
306 | -- the inferred discriminants of one operand. These formals are used in | |
307 | -- the generated case statements for each variant of the unchecked union. | |
70482933 | 308 | |
5d09245e AC |
309 | function Make_Eq_If |
310 | (E : Entity_Id; | |
311 | L : List_Id) return Node_Id; | |
47cc8d6b | 312 | -- Building block for variant record equality. Defined to share the code |
1fb63e89 | 313 | -- between the tagged and untagged case. Given the list of components |
47cc8d6b ES |
314 | -- (or discriminants) L, it generates a return statement that compares all |
315 | -- components of local temporaries named X and Y (that are declared as | |
316 | -- formals at some upper level). E provides the Sloc to be used for the | |
317 | -- generated code. | |
70482933 | 318 | |
cd20e505 AC |
319 | function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id; |
320 | -- Search for a renaming of the inequality dispatching primitive of | |
321 | -- this tagged type. If found then build and return the corresponding | |
322 | -- rename-as-body inequality subprogram; otherwise return Empty. | |
323 | ||
70482933 RK |
324 | procedure Make_Predefined_Primitive_Specs |
325 | (Tag_Typ : Entity_Id; | |
326 | Predef_List : out List_Id; | |
4ce9a2d8 | 327 | Renamed_Eq : out Entity_Id); |
70482933 | 328 | -- Create a list with the specs of the predefined primitive operations. |
4ce9a2d8 HK |
329 | -- For tagged types that are interfaces all these primitives are defined |
330 | -- abstract. | |
331 | -- | |
fbf5a39b AC |
332 | -- The following entries are present for all tagged types, and provide |
333 | -- the results of the corresponding attribute applied to the object. | |
334 | -- Dispatching is required in general, since the result of the attribute | |
335 | -- will vary with the actual object subtype. | |
336 | -- | |
fbf5a39b AC |
337 | -- _size provides result of 'Size attribute |
338 | -- typSR provides result of 'Read attribute | |
339 | -- typSW provides result of 'Write attribute | |
340 | -- typSI provides result of 'Input attribute | |
341 | -- typSO provides result of 'Output attribute | |
110d0820 | 342 | -- typPI provides result of 'Put_Image attribute |
fbf5a39b | 343 | -- |
47cc8d6b ES |
344 | -- The following entries are additionally present for non-limited tagged |
345 | -- types, and implement additional dispatching operations for predefined | |
346 | -- operations: | |
fbf5a39b AC |
347 | -- |
348 | -- _equality implements "=" operator | |
349 | -- _assign implements assignment operation | |
350 | -- typDF implements deep finalization | |
47cc8d6b | 351 | -- typDA implements deep adjust |
fbf5a39b AC |
352 | -- |
353 | -- The latter two are empty procedures unless the type contains some | |
354 | -- controlled components that require finalization actions (the deep | |
355 | -- in the name refers to the fact that the action applies to components). | |
356 | -- | |
5ae5ba7a | 357 | -- The list of specs is returned in Predef_List |
70482933 RK |
358 | |
359 | function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean; | |
7d9880c9 | 360 | -- Returns True if there are representation clauses for type T that are not |
47cc8d6b ES |
361 | -- inherited. If the result is false, the init_proc and the discriminant |
362 | -- checking functions of the parent can be reused by a derived type. | |
70482933 | 363 | |
e5a58fac AC |
364 | function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id; |
365 | -- Ada 2005 (AI-251): Makes specs for null procedures associated with any | |
366 | -- null procedures inherited from an interface type that have not been | |
367 | -- overridden. Only one null procedure will be created for a given set of | |
368 | -- inherited null procedures with homographic profiles. | |
369 | ||
70482933 RK |
370 | function Predef_Spec_Or_Body |
371 | (Loc : Source_Ptr; | |
372 | Tag_Typ : Entity_Id; | |
373 | Name : Name_Id; | |
374 | Profile : List_Id; | |
375 | Ret_Type : Entity_Id := Empty; | |
2e071734 | 376 | For_Body : Boolean := False) return Node_Id; |
70482933 RK |
377 | -- This function generates the appropriate expansion for a predefined |
378 | -- primitive operation specified by its name, parameter profile and | |
379 | -- return type (Empty means this is a procedure). If For_Body is false, | |
380 | -- then the returned node is a subprogram declaration. If For_Body is | |
381 | -- true, then the returned node is a empty subprogram body containing | |
382 | -- no declarations and no statements. | |
383 | ||
384 | function Predef_Stream_Attr_Spec | |
35338c60 ES |
385 | (Loc : Source_Ptr; |
386 | Tag_Typ : Entity_Id; | |
387 | Name : TSS_Name_Type) return Node_Id; | |
fbf5a39b AC |
388 | -- Specialized version of Predef_Spec_Or_Body that apply to read, write, |
389 | -- input and output attribute whose specs are constructed in Exp_Strm. | |
70482933 RK |
390 | |
391 | function Predef_Deep_Spec | |
392 | (Loc : Source_Ptr; | |
393 | Tag_Typ : Entity_Id; | |
fbf5a39b | 394 | Name : TSS_Name_Type; |
2e071734 | 395 | For_Body : Boolean := False) return Node_Id; |
70482933 RK |
396 | -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust |
397 | -- and _deep_finalize | |
398 | ||
399 | function Predefined_Primitive_Bodies | |
400 | (Tag_Typ : Entity_Id; | |
4ce9a2d8 | 401 | Renamed_Eq : Entity_Id) return List_Id; |
70482933 RK |
402 | -- Create the bodies of the predefined primitives that are described in |
403 | -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote | |
404 | -- the defining unit name of the type's predefined equality as returned | |
405 | -- by Make_Predefined_Primitive_Specs. | |
406 | ||
407 | function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id; | |
408 | -- Freeze entities of all predefined primitive operations. This is needed | |
47cc8d6b | 409 | -- because the bodies of these operations do not normally do any freezing. |
70482933 RK |
410 | |
411 | -------------------------- | |
412 | -- Adjust_Discriminants -- | |
413 | -------------------------- | |
414 | ||
47cc8d6b ES |
415 | -- This procedure attempts to define subtypes for discriminants that are |
416 | -- more restrictive than those declared. Such a replacement is possible if | |
417 | -- we can demonstrate that values outside the restricted range would cause | |
418 | -- constraint errors in any case. The advantage of restricting the | |
419 | -- discriminant types in this way is that the maximum size of the variant | |
420 | -- record can be calculated more conservatively. | |
70482933 RK |
421 | |
422 | -- An example of a situation in which we can perform this type of | |
423 | -- restriction is the following: | |
424 | ||
425 | -- subtype B is range 1 .. 10; | |
426 | -- type Q is array (B range <>) of Integer; | |
427 | ||
428 | -- type V (N : Natural) is record | |
429 | -- C : Q (1 .. N); | |
430 | -- end record; | |
431 | ||
432 | -- In this situation, we can restrict the upper bound of N to 10, since | |
433 | -- any larger value would cause a constraint error in any case. | |
434 | ||
435 | -- There are many situations in which such restriction is possible, but | |
436 | -- for now, we just look for cases like the above, where the component | |
437 | -- in question is a one dimensional array whose upper bound is one of | |
438 | -- the record discriminants. Also the component must not be part of | |
439 | -- any variant part, since then the component does not always exist. | |
440 | ||
441 | procedure Adjust_Discriminants (Rtype : Entity_Id) is | |
442 | Loc : constant Source_Ptr := Sloc (Rtype); | |
443 | Comp : Entity_Id; | |
444 | Ctyp : Entity_Id; | |
445 | Ityp : Entity_Id; | |
446 | Lo : Node_Id; | |
447 | Hi : Node_Id; | |
448 | P : Node_Id; | |
449 | Loval : Uint; | |
450 | Discr : Entity_Id; | |
451 | Dtyp : Entity_Id; | |
452 | Dhi : Node_Id; | |
453 | Dhiv : Uint; | |
454 | Ahi : Node_Id; | |
455 | Ahiv : Uint; | |
456 | Tnn : Entity_Id; | |
457 | ||
458 | begin | |
459 | Comp := First_Component (Rtype); | |
460 | while Present (Comp) loop | |
461 | ||
462 | -- If our parent is a variant, quit, we do not look at components | |
463 | -- that are in variant parts, because they may not always exist. | |
464 | ||
465 | P := Parent (Comp); -- component declaration | |
466 | P := Parent (P); -- component list | |
467 | ||
468 | exit when Nkind (Parent (P)) = N_Variant; | |
469 | ||
470 | -- We are looking for a one dimensional array type | |
471 | ||
472 | Ctyp := Etype (Comp); | |
473 | ||
45ec05e1 | 474 | if not Is_Array_Type (Ctyp) or else Number_Dimensions (Ctyp) > 1 then |
70482933 RK |
475 | goto Continue; |
476 | end if; | |
477 | ||
478 | -- The lower bound must be constant, and the upper bound is a | |
479 | -- discriminant (which is a discriminant of the current record). | |
480 | ||
481 | Ityp := Etype (First_Index (Ctyp)); | |
482 | Lo := Type_Low_Bound (Ityp); | |
483 | Hi := Type_High_Bound (Ityp); | |
484 | ||
485 | if not Compile_Time_Known_Value (Lo) | |
486 | or else Nkind (Hi) /= N_Identifier | |
487 | or else No (Entity (Hi)) | |
488 | or else Ekind (Entity (Hi)) /= E_Discriminant | |
489 | then | |
490 | goto Continue; | |
491 | end if; | |
492 | ||
493 | -- We have an array with appropriate bounds | |
494 | ||
495 | Loval := Expr_Value (Lo); | |
496 | Discr := Entity (Hi); | |
497 | Dtyp := Etype (Discr); | |
498 | ||
499 | -- See if the discriminant has a known upper bound | |
500 | ||
501 | Dhi := Type_High_Bound (Dtyp); | |
502 | ||
503 | if not Compile_Time_Known_Value (Dhi) then | |
504 | goto Continue; | |
505 | end if; | |
506 | ||
507 | Dhiv := Expr_Value (Dhi); | |
508 | ||
509 | -- See if base type of component array has known upper bound | |
510 | ||
511 | Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp)))); | |
512 | ||
513 | if not Compile_Time_Known_Value (Ahi) then | |
514 | goto Continue; | |
515 | end if; | |
516 | ||
517 | Ahiv := Expr_Value (Ahi); | |
518 | ||
519 | -- The condition for doing the restriction is that the high bound | |
520 | -- of the discriminant is greater than the low bound of the array, | |
521 | -- and is also greater than the high bound of the base type index. | |
522 | ||
523 | if Dhiv > Loval and then Dhiv > Ahiv then | |
524 | ||
525 | -- We can reset the upper bound of the discriminant type to | |
526 | -- whichever is larger, the low bound of the component, or | |
527 | -- the high bound of the base type array index. | |
528 | ||
529 | -- We build a subtype that is declared as | |
530 | ||
531 | -- subtype Tnn is discr_type range discr_type'First .. max; | |
532 | ||
533 | -- And insert this declaration into the tree. The type of the | |
534 | -- discriminant is then reset to this more restricted subtype. | |
535 | ||
191fcb3a | 536 | Tnn := Make_Temporary (Loc, 'T'); |
70482933 RK |
537 | |
538 | Insert_Action (Declaration_Node (Rtype), | |
539 | Make_Subtype_Declaration (Loc, | |
540 | Defining_Identifier => Tnn, | |
541 | Subtype_Indication => | |
542 | Make_Subtype_Indication (Loc, | |
543 | Subtype_Mark => New_Occurrence_Of (Dtyp, Loc), | |
544 | Constraint => | |
545 | Make_Range_Constraint (Loc, | |
546 | Range_Expression => | |
547 | Make_Range (Loc, | |
548 | Low_Bound => | |
549 | Make_Attribute_Reference (Loc, | |
550 | Attribute_Name => Name_First, | |
551 | Prefix => New_Occurrence_Of (Dtyp, Loc)), | |
552 | High_Bound => | |
553 | Make_Integer_Literal (Loc, | |
554 | Intval => UI_Max (Loval, Ahiv))))))); | |
555 | ||
556 | Set_Etype (Discr, Tnn); | |
557 | end if; | |
558 | ||
559 | <<Continue>> | |
560 | Next_Component (Comp); | |
561 | end loop; | |
70482933 RK |
562 | end Adjust_Discriminants; |
563 | ||
7b6a7ef8 ES |
564 | ------------------------------------------ |
565 | -- Build_Access_Subprogram_Wrapper_Body -- | |
566 | ------------------------------------------ | |
567 | ||
568 | procedure Build_Access_Subprogram_Wrapper_Body | |
14e75608 | 569 | (Decl : Node_Id; |
7b6a7ef8 ES |
570 | New_Decl : Node_Id) |
571 | is | |
572 | Loc : constant Source_Ptr := Sloc (Decl); | |
14e75608 GD |
573 | Actuals : constant List_Id := New_List; |
574 | Type_Def : constant Node_Id := Type_Definition (Decl); | |
575 | Type_Id : constant Entity_Id := Defining_Identifier (Decl); | |
576 | Spec_Node : constant Node_Id := | |
9b501e59 ES |
577 | Copy_Subprogram_Spec (Specification (New_Decl)); |
578 | -- This copy creates new identifiers for formals and subprogram. | |
7b6a7ef8 ES |
579 | |
580 | Act : Node_Id; | |
581 | Body_Node : Node_Id; | |
582 | Call_Stmt : Node_Id; | |
583 | Ptr : Entity_Id; | |
14e75608 | 584 | |
7b6a7ef8 | 585 | begin |
14e75608 | 586 | -- Create List of actuals for indirect call. The last parameter of the |
9b501e59 | 587 | -- subprogram declaration is the access value for the indirect call. |
7b6a7ef8 ES |
588 | |
589 | Act := First (Parameter_Specifications (Spec_Node)); | |
590 | ||
591 | while Present (Act) loop | |
7d3a9f39 | 592 | exit when Act = Last (Parameter_Specifications (Spec_Node)); |
7b6a7ef8 ES |
593 | Append_To (Actuals, |
594 | Make_Identifier (Loc, Chars (Defining_Identifier (Act)))); | |
595 | Next (Act); | |
7b6a7ef8 ES |
596 | end loop; |
597 | ||
598 | Ptr := | |
599 | Defining_Identifier | |
9b501e59 | 600 | (Last (Parameter_Specifications (Specification (New_Decl)))); |
7b6a7ef8 ES |
601 | |
602 | if Nkind (Type_Def) = N_Access_Procedure_Definition then | |
603 | Call_Stmt := Make_Procedure_Call_Statement (Loc, | |
604 | Name => | |
605 | Make_Explicit_Dereference | |
606 | (Loc, New_Occurrence_Of (Ptr, Loc)), | |
607 | Parameter_Associations => Actuals); | |
608 | else | |
609 | Call_Stmt := Make_Simple_Return_Statement (Loc, | |
610 | Expression => | |
611 | Make_Function_Call (Loc, | |
612 | Name => Make_Explicit_Dereference | |
613 | (Loc, New_Occurrence_Of (Ptr, Loc)), | |
614 | Parameter_Associations => Actuals)); | |
615 | end if; | |
616 | ||
617 | Body_Node := Make_Subprogram_Body (Loc, | |
618 | Specification => Spec_Node, | |
619 | Declarations => New_List, | |
620 | Handled_Statement_Sequence => | |
621 | Make_Handled_Sequence_Of_Statements (Loc, | |
622 | Statements => New_List (Call_Stmt))); | |
623 | ||
624 | -- Place body in list of freeze actions for the type. | |
625 | ||
e4b5ab01 | 626 | Append_Freeze_Action (Type_Id, Body_Node); |
7b6a7ef8 ES |
627 | end Build_Access_Subprogram_Wrapper_Body; |
628 | ||
70482933 RK |
629 | --------------------------- |
630 | -- Build_Array_Init_Proc -- | |
631 | --------------------------- | |
632 | ||
633 | procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is | |
aa11d1dd | 634 | Comp_Type : constant Entity_Id := Component_Type (A_Type); |
f7fb5c08 | 635 | Comp_Simple_Init : constant Boolean := |
2eda24e9 | 636 | Needs_Simple_Initialization |
3b26fe82 | 637 | (Typ => Comp_Type, |
aa11d1dd | 638 | Consider_IS => |
2eda24e9 | 639 | not (Validity_Check_Copies and Is_Bit_Packed_Array (A_Type))); |
f7fb5c08 PMR |
640 | -- True if the component needs simple initialization, based on its type, |
641 | -- plus the fact that we do not do simple initialization for components | |
642 | -- of bit-packed arrays when validity checks are enabled, because the | |
643 | -- initialization with deliberately out-of-range values would raise | |
644 | -- Constraint_Error. | |
aa11d1dd | 645 | |
c5ecf679 GD |
646 | Body_Stmts : List_Id; |
647 | Has_Default_Init : Boolean; | |
df3e68b1 | 648 | Index_List : List_Id; |
24cb156d | 649 | Loc : Source_Ptr; |
c743425f | 650 | Parameters : List_Id; |
df3e68b1 | 651 | Proc_Id : Entity_Id; |
70482933 RK |
652 | |
653 | function Init_Component return List_Id; | |
654 | -- Create one statement to initialize one array component, designated | |
3b42c566 | 655 | -- by a full set of indexes. |
70482933 RK |
656 | |
657 | function Init_One_Dimension (N : Int) return List_Id; | |
658 | -- Create loop to initialize one dimension of the array. The single | |
659 | -- statement in the loop body initializes the inner dimensions if any, | |
660 | -- or else the single component. Note that this procedure is called | |
661 | -- recursively, with N being the dimension to be initialized. A call | |
662 | -- with N greater than the number of dimensions simply generates the | |
663 | -- component initialization, terminating the recursion. | |
664 | ||
665 | -------------------- | |
666 | -- Init_Component -- | |
667 | -------------------- | |
668 | ||
669 | function Init_Component return List_Id is | |
670 | Comp : Node_Id; | |
671 | ||
672 | begin | |
673 | Comp := | |
674 | Make_Indexed_Component (Loc, | |
7675ad4f | 675 | Prefix => Make_Identifier (Loc, Name_uInit), |
70482933 RK |
676 | Expressions => Index_List); |
677 | ||
a01b9df6 | 678 | if Has_Default_Aspect (A_Type) then |
70482933 RK |
679 | Set_Assignment_OK (Comp); |
680 | return New_List ( | |
681 | Make_Assignment_Statement (Loc, | |
a01b9df6 AC |
682 | Name => Comp, |
683 | Expression => | |
684 | Convert_To (Comp_Type, | |
6d9e03cb | 685 | Default_Aspect_Component_Value (First_Subtype (A_Type))))); |
a01b9df6 | 686 | |
f7fb5c08 | 687 | elsif Comp_Simple_Init then |
a01b9df6 AC |
688 | Set_Assignment_OK (Comp); |
689 | return New_List ( | |
690 | Make_Assignment_Statement (Loc, | |
691 | Name => Comp, | |
82c80734 RD |
692 | Expression => |
693 | Get_Simple_Init_Val | |
3b26fe82 HK |
694 | (Typ => Comp_Type, |
695 | N => Nod, | |
696 | Size => Component_Size (A_Type)))); | |
70482933 RK |
697 | |
698 | else | |
3476f949 | 699 | Clean_Task_Names (Comp_Type, Proc_Id); |
70482933 | 700 | return |
ea1941af | 701 | Build_Initialization_Call |
3b26fe82 HK |
702 | (Loc => Loc, |
703 | Id_Ref => Comp, | |
704 | Typ => Comp_Type, | |
ea1941af ES |
705 | In_Init_Proc => True, |
706 | Enclos_Type => A_Type); | |
70482933 RK |
707 | end if; |
708 | end Init_Component; | |
709 | ||
710 | ------------------------ | |
711 | -- Init_One_Dimension -- | |
712 | ------------------------ | |
713 | ||
714 | function Init_One_Dimension (N : Int) return List_Id is | |
f7937111 GD |
715 | Index : Entity_Id; |
716 | DIC_Call : Node_Id; | |
717 | Result_List : List_Id; | |
718 | ||
719 | function Possible_DIC_Call return Node_Id; | |
720 | -- If the component type has Default_Initial_Conditions and a DIC | |
721 | -- procedure that is not an empty body, then builds a call to the | |
722 | -- DIC procedure and returns it. | |
723 | ||
724 | ----------------------- | |
725 | -- Possible_DIC_Call -- | |
726 | ----------------------- | |
727 | ||
728 | function Possible_DIC_Call return Node_Id is | |
729 | begin | |
730 | -- When the component's type has a Default_Initial_Condition, then | |
731 | -- create a call for the DIC check. | |
732 | ||
733 | if Has_DIC (Comp_Type) | |
734 | -- In GNATprove mode, the component DICs are checked by other | |
735 | -- means. They should not be added to the record type DIC | |
736 | -- procedure, so that the procedure can be used to check the | |
737 | -- record type invariants or DICs if any. | |
738 | ||
739 | and then not GNATprove_Mode | |
740 | ||
097826df GD |
741 | -- DIC checks for components of controlled types are done later |
742 | -- (see Exp_Ch7.Make_Deep_Array_Body). | |
743 | ||
744 | and then not Is_Controlled (Comp_Type) | |
745 | ||
f7937111 GD |
746 | and then Present (DIC_Procedure (Comp_Type)) |
747 | ||
748 | and then not Has_Null_Body (DIC_Procedure (Comp_Type)) | |
749 | then | |
750 | return | |
751 | Build_DIC_Call (Loc, | |
752 | Make_Indexed_Component (Loc, | |
753 | Prefix => Make_Identifier (Loc, Name_uInit), | |
754 | Expressions => Index_List), | |
755 | Comp_Type); | |
756 | else | |
757 | return Empty; | |
758 | end if; | |
759 | end Possible_DIC_Call; | |
760 | ||
761 | -- Start of processing for Init_One_Dimension | |
70482933 RK |
762 | |
763 | begin | |
764 | -- If the component does not need initializing, then there is nothing | |
765 | -- to do here, so we return a null body. This occurs when generating | |
766 | -- the dummy Init_Proc needed for Initialize_Scalars processing. | |
f7937111 GD |
767 | -- An exception is if component type has a Default_Initial_Condition, |
768 | -- in which case we generate a call to the type's DIC procedure. | |
70482933 RK |
769 | |
770 | if not Has_Non_Null_Base_Init_Proc (Comp_Type) | |
f7fb5c08 | 771 | and then not Comp_Simple_Init |
70482933 | 772 | and then not Has_Task (Comp_Type) |
a01b9df6 | 773 | and then not Has_Default_Aspect (A_Type) |
f7937111 GD |
774 | and then (not Has_DIC (Comp_Type) |
775 | or else N > Number_Dimensions (A_Type)) | |
70482933 | 776 | then |
f7937111 GD |
777 | DIC_Call := Possible_DIC_Call; |
778 | ||
779 | if Present (DIC_Call) then | |
780 | return New_List (DIC_Call); | |
781 | else | |
782 | return New_List (Make_Null_Statement (Loc)); | |
783 | end if; | |
70482933 RK |
784 | |
785 | -- If all dimensions dealt with, we simply initialize the component | |
f7937111 | 786 | -- and append a call to component type's DIC procedure when needed. |
70482933 RK |
787 | |
788 | elsif N > Number_Dimensions (A_Type) then | |
f7937111 GD |
789 | DIC_Call := Possible_DIC_Call; |
790 | ||
791 | if Present (DIC_Call) then | |
792 | Result_List := Init_Component; | |
793 | Append (DIC_Call, Result_List); | |
794 | return Result_List; | |
795 | ||
796 | else | |
797 | return Init_Component; | |
798 | end if; | |
70482933 RK |
799 | |
800 | -- Here we generate the required loop | |
801 | ||
802 | else | |
803 | Index := | |
804 | Make_Defining_Identifier (Loc, New_External_Name ('J', N)); | |
805 | ||
e4494292 | 806 | Append (New_Occurrence_Of (Index, Loc), Index_List); |
70482933 RK |
807 | |
808 | return New_List ( | |
809 | Make_Implicit_Loop_Statement (Nod, | |
e477d718 | 810 | Identifier => Empty, |
70482933 RK |
811 | Iteration_Scheme => |
812 | Make_Iteration_Scheme (Loc, | |
813 | Loop_Parameter_Specification => | |
814 | Make_Loop_Parameter_Specification (Loc, | |
e477d718 | 815 | Defining_Identifier => Index, |
70482933 RK |
816 | Discrete_Subtype_Definition => |
817 | Make_Attribute_Reference (Loc, | |
e477d718 AC |
818 | Prefix => |
819 | Make_Identifier (Loc, Name_uInit), | |
70482933 | 820 | Attribute_Name => Name_Range, |
7675ad4f | 821 | Expressions => New_List ( |
70482933 | 822 | Make_Integer_Literal (Loc, N))))), |
e477d718 | 823 | Statements => Init_One_Dimension (N + 1))); |
70482933 RK |
824 | end if; |
825 | end Init_One_Dimension; | |
826 | ||
827 | -- Start of processing for Build_Array_Init_Proc | |
828 | ||
829 | begin | |
24cb156d AC |
830 | -- The init proc is created when analyzing the freeze node for the type, |
831 | -- but it properly belongs with the array type declaration. However, if | |
832 | -- the freeze node is for a subtype of a type declared in another unit | |
833 | -- it seems preferable to use the freeze node as the source location of | |
cf427f02 | 834 | -- the init proc. In any case this is preferable for gcov usage, and |
24cb156d AC |
835 | -- the Sloc is not otherwise used by the compiler. |
836 | ||
837 | if In_Open_Scopes (Scope (A_Type)) then | |
838 | Loc := Sloc (A_Type); | |
839 | else | |
840 | Loc := Sloc (Nod); | |
841 | end if; | |
842 | ||
ae7adb1b ES |
843 | -- Nothing to generate in the following cases: |
844 | ||
845 | -- 1. Initialization is suppressed for the type | |
535a8637 | 846 | -- 2. An initialization already exists for the base type |
ae7adb1b | 847 | |
5b1e6aca | 848 | if Initialization_Suppressed (A_Type) |
ae7adb1b ES |
849 | or else Present (Base_Init_Proc (A_Type)) |
850 | then | |
70482933 RK |
851 | return; |
852 | end if; | |
853 | ||
854 | Index_List := New_List; | |
855 | ||
856 | -- We need an initialization procedure if any of the following is true: | |
857 | ||
858 | -- 1. The component type has an initialization procedure | |
859 | -- 2. The component type needs simple initialization | |
860 | -- 3. Tasks are present | |
47cc8d6b | 861 | -- 4. The type is marked as a public entity |
a01b9df6 | 862 | -- 5. The array type has a Default_Component_Value aspect |
f7937111 | 863 | -- 6. The array component type has a Default_Initialization_Condition |
70482933 RK |
864 | |
865 | -- The reason for the public entity test is to deal properly with the | |
866 | -- Initialize_Scalars pragma. This pragma can be set in the client and | |
867 | -- not in the declaring package, this means the client will make a call | |
868 | -- to the initialization procedure (because one of conditions 1-3 must | |
869 | -- apply in this case), and we must generate a procedure (even if it is | |
870 | -- null) to satisfy the call in this case. | |
871 | ||
82c80734 RD |
872 | -- Exception: do not build an array init_proc for a type whose root |
873 | -- type is Standard.String or Standard.Wide_[Wide_]String, since there | |
874 | -- is no place to put the code, and in any case we handle initialization | |
875 | -- of such types (in the Initialize_Scalars case, that's the only time | |
876 | -- the issue arises) in a special manner anyway which does not need an | |
877 | -- init_proc. | |
70482933 | 878 | |
c5ecf679 | 879 | Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type) |
f7fb5c08 | 880 | or else Comp_Simple_Init |
a01b9df6 | 881 | or else Has_Task (Comp_Type) |
f7937111 GD |
882 | or else Has_Default_Aspect (A_Type) |
883 | or else Has_DIC (Comp_Type); | |
c5ecf679 GD |
884 | |
885 | if Has_Default_Init | |
6e937c1c | 886 | or else (not Restriction_Active (No_Initialize_Scalars) |
c5ecf679 | 887 | and then Is_Public (A_Type) |
bc3c2eca | 888 | and then not Is_Standard_String_Type (A_Type)) |
70482933 RK |
889 | then |
890 | Proc_Id := | |
f2cbd970 JM |
891 | Make_Defining_Identifier (Loc, |
892 | Chars => Make_Init_Proc_Name (A_Type)); | |
893 | ||
894 | -- If No_Default_Initialization restriction is active, then we don't | |
895 | -- want to build an init_proc, but we need to mark that an init_proc | |
896 | -- would be needed if this restriction was not active (so that we can | |
897 | -- detect attempts to call it), so set a dummy init_proc in place. | |
c5ecf679 | 898 | -- This is only done though when actual default initialization is |
26a29f01 GD |
899 | -- needed (and not done when only Is_Public is True), since otherwise |
900 | -- objects such as arrays of scalars could be wrongly flagged as | |
901 | -- violating the restriction. | |
f2cbd970 JM |
902 | |
903 | if Restriction_Active (No_Default_Initialization) then | |
c5ecf679 GD |
904 | if Has_Default_Init then |
905 | Set_Init_Proc (A_Type, Proc_Id); | |
906 | end if; | |
907 | ||
f2cbd970 JM |
908 | return; |
909 | end if; | |
70482933 RK |
910 | |
911 | Body_Stmts := Init_One_Dimension (1); | |
a7837c08 | 912 | Parameters := Init_Formals (A_Type, Proc_Id); |
70482933 | 913 | |
fbf5a39b | 914 | Discard_Node ( |
70482933 RK |
915 | Make_Subprogram_Body (Loc, |
916 | Specification => | |
917 | Make_Procedure_Specification (Loc, | |
918 | Defining_Unit_Name => Proc_Id, | |
c743425f | 919 | Parameter_Specifications => Parameters), |
70482933 RK |
920 | Declarations => New_List, |
921 | Handled_Statement_Sequence => | |
922 | Make_Handled_Sequence_Of_Statements (Loc, | |
fbf5a39b | 923 | Statements => Body_Stmts))); |
70482933 | 924 | |
2e02ab86 | 925 | Mutate_Ekind (Proc_Id, E_Procedure); |
70482933 | 926 | Set_Is_Public (Proc_Id, Is_Public (A_Type)); |
70482933 RK |
927 | Set_Is_Internal (Proc_Id); |
928 | Set_Has_Completion (Proc_Id); | |
929 | ||
930 | if not Debug_Generated_Code then | |
931 | Set_Debug_Info_Off (Proc_Id); | |
932 | end if; | |
933 | ||
0d66b596 AC |
934 | -- Set Inlined on Init_Proc if it is set on the Init_Proc of the |
935 | -- component type itself (see also Build_Record_Init_Proc). | |
07fc65c4 | 936 | |
0d66b596 | 937 | Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Comp_Type)); |
07fc65c4 | 938 | |
70482933 RK |
939 | -- Associate Init_Proc with type, and determine if the procedure |
940 | -- is null (happens because of the Initialize_Scalars pragma case, | |
941 | -- where we have to generate a null procedure in case it is called | |
942 | -- by a client with Initialize_Scalars set). Such procedures have | |
943 | -- to be generated, but do not have to be called, so we mark them | |
c743425f EB |
944 | -- as null to suppress the call. Kill also warnings for the _Init |
945 | -- out parameter, which is left entirely uninitialized. | |
70482933 RK |
946 | |
947 | Set_Init_Proc (A_Type, Proc_Id); | |
948 | ||
c743425f | 949 | if Is_Null_Statement_List (Body_Stmts) then |
70482933 | 950 | Set_Is_Null_Init_Proc (Proc_Id); |
c743425f | 951 | Set_Warnings_Off (Defining_Identifier (First (Parameters))); |
47cc8d6b ES |
952 | |
953 | else | |
a01b9df6 | 954 | -- Try to build a static aggregate to statically initialize |
47cc8d6b ES |
955 | -- objects of the type. This can only be done for constrained |
956 | -- one-dimensional arrays with static bounds. | |
957 | ||
958 | Set_Static_Initialization | |
959 | (Proc_Id, | |
327503f1 | 960 | Build_Equivalent_Array_Aggregate (First_Subtype (A_Type))); |
70482933 RK |
961 | end if; |
962 | end if; | |
70482933 RK |
963 | end Build_Array_Init_Proc; |
964 | ||
70482933 RK |
965 | -------------------------------- |
966 | -- Build_Discr_Checking_Funcs -- | |
967 | -------------------------------- | |
968 | ||
969 | procedure Build_Discr_Checking_Funcs (N : Node_Id) is | |
970 | Rec_Id : Entity_Id; | |
971 | Loc : Source_Ptr; | |
972 | Enclosing_Func_Id : Entity_Id; | |
d8a764c4 | 973 | Sequence : Nat := 1; |
70482933 RK |
974 | Type_Def : Node_Id; |
975 | V : Node_Id; | |
976 | ||
977 | function Build_Case_Statement | |
978 | (Case_Id : Entity_Id; | |
2e071734 | 979 | Variant : Node_Id) return Node_Id; |
47cc8d6b | 980 | -- Build a case statement containing only two alternatives. The first |
36e38022 BD |
981 | -- alternative corresponds to the discrete choices given on the variant |
982 | -- that contains the components that we are generating the checks | |
983 | -- for. If the discriminant is one of these return False. The second | |
984 | -- alternative is an OTHERS choice that returns True indicating the | |
985 | -- discriminant did not match. | |
70482933 RK |
986 | |
987 | function Build_Dcheck_Function | |
988 | (Case_Id : Entity_Id; | |
2e071734 | 989 | Variant : Node_Id) return Entity_Id; |
70482933 RK |
990 | -- Build the discriminant checking function for a given variant |
991 | ||
992 | procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id); | |
993 | -- Builds the discriminant checking function for each variant of the | |
994 | -- given variant part of the record type. | |
995 | ||
996 | -------------------------- | |
997 | -- Build_Case_Statement -- | |
998 | -------------------------- | |
999 | ||
1000 | function Build_Case_Statement | |
1001 | (Case_Id : Entity_Id; | |
2e071734 | 1002 | Variant : Node_Id) return Node_Id |
70482933 | 1003 | is |
fbf5a39b | 1004 | Alt_List : constant List_Id := New_List; |
70482933 | 1005 | Actuals_List : List_Id; |
70482933 RK |
1006 | Case_Node : Node_Id; |
1007 | Case_Alt_Node : Node_Id; | |
1008 | Choice : Node_Id; | |
1009 | Choice_List : List_Id; | |
1010 | D : Entity_Id; | |
1011 | Return_Node : Node_Id; | |
1012 | ||
1013 | begin | |
70482933 | 1014 | Case_Node := New_Node (N_Case_Statement, Loc); |
36e38022 | 1015 | Set_End_Span (Case_Node, Uint_0); |
70482933 | 1016 | |
d8a764c4 | 1017 | -- Replace the discriminant which controls the variant with the name |
47cc8d6b | 1018 | -- of the formal of the checking function. |
70482933 | 1019 | |
7675ad4f | 1020 | Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id))); |
70482933 RK |
1021 | |
1022 | Choice := First (Discrete_Choices (Variant)); | |
1023 | ||
1024 | if Nkind (Choice) = N_Others_Choice then | |
1025 | Choice_List := New_Copy_List (Others_Discrete_Choices (Choice)); | |
1026 | else | |
1027 | Choice_List := New_Copy_List (Discrete_Choices (Variant)); | |
1028 | end if; | |
1029 | ||
1030 | if not Is_Empty_List (Choice_List) then | |
1031 | Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); | |
1032 | Set_Discrete_Choices (Case_Alt_Node, Choice_List); | |
1033 | ||
1034 | -- In case this is a nested variant, we need to return the result | |
1035 | -- of the discriminant checking function for the immediately | |
1036 | -- enclosing variant. | |
1037 | ||
1038 | if Present (Enclosing_Func_Id) then | |
1039 | Actuals_List := New_List; | |
1040 | ||
1041 | D := First_Discriminant (Rec_Id); | |
1042 | while Present (D) loop | |
1043 | Append (Make_Identifier (Loc, Chars (D)), Actuals_List); | |
1044 | Next_Discriminant (D); | |
1045 | end loop; | |
1046 | ||
1047 | Return_Node := | |
04df6250 | 1048 | Make_Simple_Return_Statement (Loc, |
70482933 RK |
1049 | Expression => |
1050 | Make_Function_Call (Loc, | |
1051 | Name => | |
e4494292 | 1052 | New_Occurrence_Of (Enclosing_Func_Id, Loc), |
70482933 RK |
1053 | Parameter_Associations => |
1054 | Actuals_List)); | |
1055 | ||
1056 | else | |
1057 | Return_Node := | |
04df6250 | 1058 | Make_Simple_Return_Statement (Loc, |
70482933 | 1059 | Expression => |
e4494292 | 1060 | New_Occurrence_Of (Standard_False, Loc)); |
70482933 RK |
1061 | end if; |
1062 | ||
1063 | Set_Statements (Case_Alt_Node, New_List (Return_Node)); | |
1064 | Append (Case_Alt_Node, Alt_List); | |
1065 | end if; | |
1066 | ||
1067 | Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); | |
1068 | Choice_List := New_List (New_Node (N_Others_Choice, Loc)); | |
1069 | Set_Discrete_Choices (Case_Alt_Node, Choice_List); | |
1070 | ||
1071 | Return_Node := | |
04df6250 | 1072 | Make_Simple_Return_Statement (Loc, |
70482933 | 1073 | Expression => |
e4494292 | 1074 | New_Occurrence_Of (Standard_True, Loc)); |
70482933 RK |
1075 | |
1076 | Set_Statements (Case_Alt_Node, New_List (Return_Node)); | |
1077 | Append (Case_Alt_Node, Alt_List); | |
1078 | ||
1079 | Set_Alternatives (Case_Node, Alt_List); | |
1080 | return Case_Node; | |
1081 | end Build_Case_Statement; | |
1082 | ||
1083 | --------------------------- | |
1084 | -- Build_Dcheck_Function -- | |
1085 | --------------------------- | |
1086 | ||
1087 | function Build_Dcheck_Function | |
1088 | (Case_Id : Entity_Id; | |
2e071734 | 1089 | Variant : Node_Id) return Entity_Id |
70482933 | 1090 | is |
3077fc46 PT |
1091 | Body_Node : Node_Id; |
1092 | Func_Id : Entity_Id; | |
1093 | Parameter_List : List_Id; | |
1094 | Spec_Node : Node_Id; | |
70482933 RK |
1095 | |
1096 | begin | |
1097 | Body_Node := New_Node (N_Subprogram_Body, Loc); | |
1098 | Sequence := Sequence + 1; | |
1099 | ||
1100 | Func_Id := | |
1101 | Make_Defining_Identifier (Loc, | |
1102 | Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence)); | |
e2ef0ff6 | 1103 | Set_Is_Discriminant_Check_Function (Func_Id); |
70482933 RK |
1104 | |
1105 | Spec_Node := New_Node (N_Function_Specification, Loc); | |
1106 | Set_Defining_Unit_Name (Spec_Node, Func_Id); | |
1107 | ||
1108 | Parameter_List := Build_Discriminant_Formals (Rec_Id, False); | |
1109 | ||
1110 | Set_Parameter_Specifications (Spec_Node, Parameter_List); | |
10b93b2e | 1111 | Set_Result_Definition (Spec_Node, |
e4494292 | 1112 | New_Occurrence_Of (Standard_Boolean, Loc)); |
70482933 RK |
1113 | Set_Specification (Body_Node, Spec_Node); |
1114 | Set_Declarations (Body_Node, New_List); | |
1115 | ||
1116 | Set_Handled_Statement_Sequence (Body_Node, | |
1117 | Make_Handled_Sequence_Of_Statements (Loc, | |
1118 | Statements => New_List ( | |
1119 | Build_Case_Statement (Case_Id, Variant)))); | |
1120 | ||
2e02ab86 | 1121 | Mutate_Ekind (Func_Id, E_Function); |
70482933 RK |
1122 | Set_Mechanism (Func_Id, Default_Mechanism); |
1123 | Set_Is_Inlined (Func_Id, True); | |
1124 | Set_Is_Pure (Func_Id, True); | |
1125 | Set_Is_Public (Func_Id, Is_Public (Rec_Id)); | |
1126 | Set_Is_Internal (Func_Id, True); | |
1127 | ||
1128 | if not Debug_Generated_Code then | |
1129 | Set_Debug_Info_Off (Func_Id); | |
1130 | end if; | |
1131 | ||
fbf5a39b AC |
1132 | Analyze (Body_Node); |
1133 | ||
70482933 RK |
1134 | Append_Freeze_Action (Rec_Id, Body_Node); |
1135 | Set_Dcheck_Function (Variant, Func_Id); | |
1136 | return Func_Id; | |
1137 | end Build_Dcheck_Function; | |
1138 | ||
1139 | ---------------------------- | |
1140 | -- Build_Dcheck_Functions -- | |
1141 | ---------------------------- | |
1142 | ||
1143 | procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is | |
1144 | Component_List_Node : Node_Id; | |
1145 | Decl : Entity_Id; | |
1146 | Discr_Name : Entity_Id; | |
1147 | Func_Id : Entity_Id; | |
1148 | Variant : Node_Id; | |
1149 | Saved_Enclosing_Func_Id : Entity_Id; | |
1150 | ||
1151 | begin | |
d70d147e GD |
1152 | -- Build the discriminant-checking function for each variant, and |
1153 | -- label all components of that variant with the function's name. | |
1154 | -- We only Generate a discriminant-checking function when the | |
f2cbd970 | 1155 | -- variant is not empty, to prevent the creation of dead code. |
70482933 RK |
1156 | |
1157 | Discr_Name := Entity (Name (Variant_Part_Node)); | |
1158 | Variant := First_Non_Pragma (Variants (Variant_Part_Node)); | |
1159 | ||
1160 | while Present (Variant) loop | |
70482933 RK |
1161 | Component_List_Node := Component_List (Variant); |
1162 | ||
f8f50235 | 1163 | if not Null_Present (Component_List_Node) then |
f2cbd970 | 1164 | Func_Id := Build_Dcheck_Function (Discr_Name, Variant); |
46413d9e | 1165 | |
70482933 RK |
1166 | Decl := |
1167 | First_Non_Pragma (Component_Items (Component_List_Node)); | |
70482933 RK |
1168 | while Present (Decl) loop |
1169 | Set_Discriminant_Checking_Func | |
1170 | (Defining_Identifier (Decl), Func_Id); | |
70482933 RK |
1171 | Next_Non_Pragma (Decl); |
1172 | end loop; | |
1173 | ||
1174 | if Present (Variant_Part (Component_List_Node)) then | |
1175 | Saved_Enclosing_Func_Id := Enclosing_Func_Id; | |
1176 | Enclosing_Func_Id := Func_Id; | |
1177 | Build_Dcheck_Functions (Variant_Part (Component_List_Node)); | |
1178 | Enclosing_Func_Id := Saved_Enclosing_Func_Id; | |
1179 | end if; | |
1180 | end if; | |
1181 | ||
1182 | Next_Non_Pragma (Variant); | |
1183 | end loop; | |
1184 | end Build_Dcheck_Functions; | |
1185 | ||
1186 | -- Start of processing for Build_Discr_Checking_Funcs | |
1187 | ||
1188 | begin | |
1189 | -- Only build if not done already | |
1190 | ||
1191 | if not Discr_Check_Funcs_Built (N) then | |
1192 | Type_Def := Type_Definition (N); | |
1193 | ||
1194 | if Nkind (Type_Def) = N_Record_Definition then | |
1195 | if No (Component_List (Type_Def)) then -- null record. | |
1196 | return; | |
1197 | else | |
1198 | V := Variant_Part (Component_List (Type_Def)); | |
1199 | end if; | |
1200 | ||
1201 | else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition); | |
1202 | if No (Component_List (Record_Extension_Part (Type_Def))) then | |
1203 | return; | |
1204 | else | |
1205 | V := Variant_Part | |
1206 | (Component_List (Record_Extension_Part (Type_Def))); | |
1207 | end if; | |
1208 | end if; | |
1209 | ||
1210 | Rec_Id := Defining_Identifier (N); | |
1211 | ||
1212 | if Present (V) and then not Is_Unchecked_Union (Rec_Id) then | |
1213 | Loc := Sloc (N); | |
1214 | Enclosing_Func_Id := Empty; | |
1215 | Build_Dcheck_Functions (V); | |
1216 | end if; | |
1217 | ||
1218 | Set_Discr_Check_Funcs_Built (N); | |
1219 | end if; | |
1220 | end Build_Discr_Checking_Funcs; | |
1221 | ||
eb1091dd SB |
1222 | ---------------------------------------- |
1223 | -- Build_Or_Copy_Discr_Checking_Funcs -- | |
1224 | ---------------------------------------- | |
1225 | ||
1226 | procedure Build_Or_Copy_Discr_Checking_Funcs (N : Node_Id) is | |
1227 | Typ : constant Entity_Id := Defining_Identifier (N); | |
1228 | begin | |
1229 | if Is_Unchecked_Union (Typ) or else not Has_Discriminants (Typ) then | |
1230 | null; | |
1231 | elsif not Is_Derived_Type (Typ) | |
1232 | or else Has_New_Non_Standard_Rep (Typ) | |
1233 | or else Is_Tagged_Type (Typ) | |
1234 | then | |
1235 | Build_Discr_Checking_Funcs (N); | |
1236 | else | |
1237 | Copy_Discr_Checking_Funcs (N); | |
1238 | end if; | |
1239 | end Build_Or_Copy_Discr_Checking_Funcs; | |
1240 | ||
70482933 RK |
1241 | -------------------------------- |
1242 | -- Build_Discriminant_Formals -- | |
1243 | -------------------------------- | |
1244 | ||
1245 | function Build_Discriminant_Formals | |
1246 | (Rec_Id : Entity_Id; | |
2e071734 | 1247 | Use_Dl : Boolean) return List_Id |
70482933 | 1248 | is |
fbf5a39b AC |
1249 | Loc : Source_Ptr := Sloc (Rec_Id); |
1250 | Parameter_List : constant List_Id := New_List; | |
70482933 RK |
1251 | D : Entity_Id; |
1252 | Formal : Entity_Id; | |
5568b57c | 1253 | Formal_Type : Entity_Id; |
70482933 | 1254 | Param_Spec_Node : Node_Id; |
70482933 RK |
1255 | |
1256 | begin | |
1257 | if Has_Discriminants (Rec_Id) then | |
1258 | D := First_Discriminant (Rec_Id); | |
70482933 RK |
1259 | while Present (D) loop |
1260 | Loc := Sloc (D); | |
1261 | ||
1262 | if Use_Dl then | |
1263 | Formal := Discriminal (D); | |
5568b57c | 1264 | Formal_Type := Etype (Formal); |
70482933 | 1265 | else |
fbf5a39b | 1266 | Formal := Make_Defining_Identifier (Loc, Chars (D)); |
5568b57c | 1267 | Formal_Type := Etype (D); |
70482933 RK |
1268 | end if; |
1269 | ||
1270 | Param_Spec_Node := | |
1271 | Make_Parameter_Specification (Loc, | |
1272 | Defining_Identifier => Formal, | |
1273 | Parameter_Type => | |
e4494292 | 1274 | New_Occurrence_Of (Formal_Type, Loc)); |
70482933 RK |
1275 | Append (Param_Spec_Node, Parameter_List); |
1276 | Next_Discriminant (D); | |
1277 | end loop; | |
1278 | end if; | |
1279 | ||
1280 | return Parameter_List; | |
1281 | end Build_Discriminant_Formals; | |
1282 | ||
47cc8d6b ES |
1283 | -------------------------------------- |
1284 | -- Build_Equivalent_Array_Aggregate -- | |
1285 | -------------------------------------- | |
1286 | ||
1287 | function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is | |
1288 | Loc : constant Source_Ptr := Sloc (T); | |
1289 | Comp_Type : constant Entity_Id := Component_Type (T); | |
1290 | Index_Type : constant Entity_Id := Etype (First_Index (T)); | |
1291 | Proc : constant Entity_Id := Base_Init_Proc (T); | |
1292 | Lo, Hi : Node_Id; | |
1293 | Aggr : Node_Id; | |
1294 | Expr : Node_Id; | |
1295 | ||
1296 | begin | |
1297 | if not Is_Constrained (T) | |
1298 | or else Number_Dimensions (T) > 1 | |
1299 | or else No (Proc) | |
1300 | then | |
1301 | Initialization_Warning (T); | |
1302 | return Empty; | |
1303 | end if; | |
1304 | ||
1305 | Lo := Type_Low_Bound (Index_Type); | |
1306 | Hi := Type_High_Bound (Index_Type); | |
1307 | ||
1308 | if not Compile_Time_Known_Value (Lo) | |
1309 | or else not Compile_Time_Known_Value (Hi) | |
1310 | then | |
1311 | Initialization_Warning (T); | |
1312 | return Empty; | |
1313 | end if; | |
1314 | ||
1315 | if Is_Record_Type (Comp_Type) | |
1316 | and then Present (Base_Init_Proc (Comp_Type)) | |
1317 | then | |
1318 | Expr := Static_Initialization (Base_Init_Proc (Comp_Type)); | |
1319 | ||
1320 | if No (Expr) then | |
1321 | Initialization_Warning (T); | |
1322 | return Empty; | |
1323 | end if; | |
1324 | ||
1325 | else | |
1326 | Initialization_Warning (T); | |
1327 | return Empty; | |
1328 | end if; | |
1329 | ||
1330 | Aggr := Make_Aggregate (Loc, No_List, New_List); | |
1331 | Set_Etype (Aggr, T); | |
1332 | Set_Aggregate_Bounds (Aggr, | |
1333 | Make_Range (Loc, | |
1334 | Low_Bound => New_Copy (Lo), | |
1335 | High_Bound => New_Copy (Hi))); | |
1336 | Set_Parent (Aggr, Parent (Proc)); | |
1337 | ||
1338 | Append_To (Component_Associations (Aggr), | |
1339 | Make_Component_Association (Loc, | |
1340 | Choices => | |
1341 | New_List ( | |
1342 | Make_Range (Loc, | |
1343 | Low_Bound => New_Copy (Lo), | |
1344 | High_Bound => New_Copy (Hi))), | |
1345 | Expression => Expr)); | |
1346 | ||
1347 | if Static_Array_Aggregate (Aggr) then | |
1348 | return Aggr; | |
1349 | else | |
1350 | Initialization_Warning (T); | |
1351 | return Empty; | |
1352 | end if; | |
1353 | end Build_Equivalent_Array_Aggregate; | |
1354 | ||
1355 | --------------------------------------- | |
1356 | -- Build_Equivalent_Record_Aggregate -- | |
1357 | --------------------------------------- | |
1358 | ||
1359 | function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is | |
5d5e9775 AC |
1360 | Agg : Node_Id; |
1361 | Comp : Entity_Id; | |
1362 | Comp_Type : Entity_Id; | |
47cc8d6b | 1363 | |
47cc8d6b ES |
1364 | begin |
1365 | if not Is_Record_Type (T) | |
1366 | or else Has_Discriminants (T) | |
1367 | or else Is_Limited_Type (T) | |
1368 | or else Has_Non_Standard_Rep (T) | |
1369 | then | |
1370 | Initialization_Warning (T); | |
1371 | return Empty; | |
1372 | end if; | |
1373 | ||
1374 | Comp := First_Component (T); | |
1375 | ||
1376 | -- A null record needs no warning | |
1377 | ||
1378 | if No (Comp) then | |
1379 | return Empty; | |
1380 | end if; | |
1381 | ||
1382 | while Present (Comp) loop | |
1383 | ||
1384 | -- Array components are acceptable if initialized by a positional | |
1385 | -- aggregate with static components. | |
1386 | ||
1387 | if Is_Array_Type (Etype (Comp)) then | |
5d5e9775 | 1388 | Comp_Type := Component_Type (Etype (Comp)); |
47cc8d6b | 1389 | |
5d5e9775 AC |
1390 | if Nkind (Parent (Comp)) /= N_Component_Declaration |
1391 | or else No (Expression (Parent (Comp))) | |
1392 | or else Nkind (Expression (Parent (Comp))) /= N_Aggregate | |
1393 | then | |
1394 | Initialization_Warning (T); | |
1395 | return Empty; | |
47cc8d6b | 1396 | |
5d5e9775 AC |
1397 | elsif Is_Scalar_Type (Component_Type (Etype (Comp))) |
1398 | and then | |
ee4eee0a | 1399 | (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type)) |
5d5e9775 AC |
1400 | or else |
1401 | not Compile_Time_Known_Value (Type_High_Bound (Comp_Type))) | |
1402 | then | |
1403 | Initialization_Warning (T); | |
1404 | return Empty; | |
1405 | ||
1406 | elsif | |
1407 | not Static_Array_Aggregate (Expression (Parent (Comp))) | |
1408 | then | |
1409 | Initialization_Warning (T); | |
1410 | return Empty; | |
8439cae8 GL |
1411 | |
1412 | -- We need to return empty if the type has predicates because | |
1413 | -- this would otherwise duplicate calls to the predicate | |
1414 | -- function. If the type hasn't been frozen before being | |
1415 | -- referenced in the current record, the extraneous call to | |
1416 | -- the predicate function would be inserted somewhere before | |
1417 | -- the predicate function is elaborated, which would result in | |
1418 | -- an invalid tree. | |
1419 | ||
1420 | elsif Has_Predicates (Etype (Comp)) then | |
1421 | return Empty; | |
5d5e9775 | 1422 | end if; |
47cc8d6b ES |
1423 | |
1424 | elsif Is_Scalar_Type (Etype (Comp)) then | |
5d5e9775 AC |
1425 | Comp_Type := Etype (Comp); |
1426 | ||
47cc8d6b ES |
1427 | if Nkind (Parent (Comp)) /= N_Component_Declaration |
1428 | or else No (Expression (Parent (Comp))) | |
1429 | or else not Compile_Time_Known_Value (Expression (Parent (Comp))) | |
5d5e9775 AC |
1430 | or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type)) |
1431 | or else not | |
1432 | Compile_Time_Known_Value (Type_High_Bound (Comp_Type)) | |
47cc8d6b ES |
1433 | then |
1434 | Initialization_Warning (T); | |
1435 | return Empty; | |
1436 | end if; | |
1437 | ||
1438 | -- For now, other types are excluded | |
1439 | ||
1440 | else | |
1441 | Initialization_Warning (T); | |
1442 | return Empty; | |
1443 | end if; | |
1444 | ||
1445 | Next_Component (Comp); | |
1446 | end loop; | |
1447 | ||
e80d72ea ES |
1448 | -- All components have static initialization. Build positional aggregate |
1449 | -- from the given expressions or defaults. | |
47cc8d6b ES |
1450 | |
1451 | Agg := Make_Aggregate (Sloc (T), New_List, New_List); | |
1452 | Set_Parent (Agg, Parent (T)); | |
1453 | ||
1454 | Comp := First_Component (T); | |
1455 | while Present (Comp) loop | |
1456 | Append | |
1457 | (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg)); | |
1458 | Next_Component (Comp); | |
1459 | end loop; | |
1460 | ||
1461 | Analyze_And_Resolve (Agg, T); | |
1462 | return Agg; | |
1463 | end Build_Equivalent_Record_Aggregate; | |
1464 | ||
d7e20130 JS |
1465 | ---------------------------- |
1466 | -- Init_Proc_Level_Formal -- | |
1467 | ---------------------------- | |
1468 | ||
1469 | function Init_Proc_Level_Formal (Proc : Entity_Id) return Entity_Id is | |
1470 | Form : Entity_Id; | |
1471 | begin | |
1472 | -- Move through the formals of the initialization procedure Proc to find | |
1473 | -- the extra accessibility level parameter associated with the object | |
1474 | -- being initialized. | |
1475 | ||
1476 | Form := First_Formal (Proc); | |
1477 | while Present (Form) loop | |
1478 | if Chars (Form) = Name_uInit_Level then | |
1479 | return Form; | |
1480 | end if; | |
1481 | ||
1482 | Next_Formal (Form); | |
1483 | end loop; | |
1484 | ||
1485 | -- No formal was found, return Empty | |
1486 | ||
1487 | return Empty; | |
1488 | end Init_Proc_Level_Formal; | |
1489 | ||
70482933 RK |
1490 | ------------------------------- |
1491 | -- Build_Initialization_Call -- | |
1492 | ------------------------------- | |
1493 | ||
47cc8d6b ES |
1494 | -- References to a discriminant inside the record type declaration can |
1495 | -- appear either in the subtype_indication to constrain a record or an | |
1496 | -- array, or as part of a larger expression given for the initial value | |
1497 | -- of a component. In both of these cases N appears in the record | |
1498 | -- initialization procedure and needs to be replaced by the formal | |
1499 | -- parameter of the initialization procedure which corresponds to that | |
1500 | -- discriminant. | |
70482933 RK |
1501 | |
1502 | -- In the example below, references to discriminants D1 and D2 in proc_1 | |
1503 | -- are replaced by references to formals with the same name | |
1504 | -- (discriminals) | |
1505 | ||
47cc8d6b ES |
1506 | -- A similar replacement is done for calls to any record initialization |
1507 | -- procedure for any components that are themselves of a record type. | |
70482933 RK |
1508 | |
1509 | -- type R (D1, D2 : Integer) is record | |
1510 | -- X : Integer := F * D1; | |
1511 | -- Y : Integer := F * D2; | |
1512 | -- end record; | |
1513 | ||
1514 | -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is | |
1515 | -- begin | |
1516 | -- Out_2.D1 := D1; | |
1517 | -- Out_2.D2 := D2; | |
1518 | -- Out_2.X := F * D1; | |
1519 | -- Out_2.Y := F * D2; | |
1520 | -- end; | |
1521 | ||
1522 | function Build_Initialization_Call | |
b77029ff SB |
1523 | (Loc : Source_Ptr; |
1524 | Id_Ref : Node_Id; | |
1525 | Typ : Entity_Id; | |
1526 | In_Init_Proc : Boolean := False; | |
1527 | Enclos_Type : Entity_Id := Empty; | |
1528 | Discr_Map : Elist_Id := New_Elmt_List; | |
1529 | With_Default_Init : Boolean := False; | |
1530 | Constructor_Ref : Node_Id := Empty; | |
1531 | Init_Control_Actual : Entity_Id := Empty) return List_Id | |
70482933 | 1532 | is |
0289a8d7 AC |
1533 | Res : constant List_Id := New_List; |
1534 | ||
1535 | Full_Type : Entity_Id; | |
1536 | ||
1537 | procedure Check_Predicated_Discriminant | |
1538 | (Val : Node_Id; | |
1539 | Discr : Entity_Id); | |
1540 | -- Discriminants whose subtypes have predicates are checked in two | |
1541 | -- cases: | |
1542 | -- a) When an object is default-initialized and assertions are enabled | |
1543 | -- we check that the value of the discriminant obeys the predicate. | |
1544 | ||
1545 | -- b) In all cases, if the discriminant controls a variant and the | |
1546 | -- variant has no others_choice, Constraint_Error must be raised if | |
1547 | -- the predicate is violated, because there is no variant covered | |
1548 | -- by the illegal discriminant value. | |
1549 | ||
1550 | ----------------------------------- | |
1551 | -- Check_Predicated_Discriminant -- | |
1552 | ----------------------------------- | |
1553 | ||
1554 | procedure Check_Predicated_Discriminant | |
1555 | (Val : Node_Id; | |
1556 | Discr : Entity_Id) | |
1557 | is | |
1558 | Typ : constant Entity_Id := Etype (Discr); | |
1559 | ||
1560 | procedure Check_Missing_Others (V : Node_Id); | |
1326b0e8 JS |
1561 | -- Check that a given variant and its nested variants have an others |
1562 | -- choice, and generate a constraint error raise when it does not. | |
0289a8d7 AC |
1563 | |
1564 | -------------------------- | |
1565 | -- Check_Missing_Others -- | |
1566 | -------------------------- | |
1567 | ||
1568 | procedure Check_Missing_Others (V : Node_Id) is | |
1569 | Alt : Node_Id; | |
1570 | Choice : Node_Id; | |
1571 | Last_Var : Node_Id; | |
1572 | ||
1573 | begin | |
1574 | Last_Var := Last_Non_Pragma (Variants (V)); | |
1575 | Choice := First (Discrete_Choices (Last_Var)); | |
1576 | ||
1577 | -- An others_choice is added during expansion for gcc use, but | |
1578 | -- does not cover the illegality. | |
1579 | ||
1580 | if Entity (Name (V)) = Discr then | |
1581 | if Present (Choice) | |
1582 | and then (Nkind (Choice) /= N_Others_Choice | |
1583 | or else not Comes_From_Source (Choice)) | |
1584 | then | |
1585 | Check_Expression_Against_Static_Predicate (Val, Typ); | |
1586 | ||
1587 | if not Is_Static_Expression (Val) then | |
1588 | Prepend_To (Res, | |
1589 | Make_Raise_Constraint_Error (Loc, | |
1590 | Condition => | |
1591 | Make_Op_Not (Loc, | |
1592 | Right_Opnd => Make_Predicate_Call (Typ, Val)), | |
1593 | Reason => CE_Invalid_Data)); | |
1594 | end if; | |
1595 | end if; | |
1596 | end if; | |
1597 | ||
1598 | -- Check whether some nested variant is ruled by the predicated | |
1599 | -- discriminant. | |
1600 | ||
1601 | Alt := First (Variants (V)); | |
1602 | while Present (Alt) loop | |
1603 | if Nkind (Alt) = N_Variant | |
1604 | and then Present (Variant_Part (Component_List (Alt))) | |
1605 | then | |
1606 | Check_Missing_Others | |
1607 | (Variant_Part (Component_List (Alt))); | |
1608 | end if; | |
1609 | ||
1610 | Next (Alt); | |
1611 | end loop; | |
1612 | end Check_Missing_Others; | |
1613 | ||
1614 | -- Local variables | |
1615 | ||
1616 | Def : Node_Id; | |
1617 | ||
1618 | -- Start of processing for Check_Predicated_Discriminant | |
1619 | ||
1620 | begin | |
1621 | if Ekind (Base_Type (Full_Type)) = E_Record_Type then | |
1622 | Def := Type_Definition (Parent (Base_Type (Full_Type))); | |
1623 | else | |
1624 | return; | |
1625 | end if; | |
1626 | ||
1627 | if Policy_In_Effect (Name_Assert) = Name_Check | |
1628 | and then not Predicates_Ignored (Etype (Discr)) | |
1629 | then | |
1630 | Prepend_To (Res, Make_Predicate_Check (Typ, Val)); | |
1631 | end if; | |
1632 | ||
1633 | -- If discriminant controls a variant, verify that predicate is | |
1634 | -- obeyed or else an Others_Choice is present. | |
1635 | ||
1636 | if Nkind (Def) = N_Record_Definition | |
1637 | and then Present (Variant_Part (Component_List (Def))) | |
1638 | and then Policy_In_Effect (Name_Assert) = Name_Ignore | |
1639 | then | |
1640 | Check_Missing_Others (Variant_Part (Component_List (Def))); | |
1641 | end if; | |
1642 | end Check_Predicated_Discriminant; | |
1643 | ||
1644 | -- Local variables | |
1645 | ||
236fecbf | 1646 | Arg : Node_Id; |
70482933 | 1647 | Args : List_Id; |
236fecbf | 1648 | Decls : List_Id; |
df3e68b1 | 1649 | Decl : Node_Id; |
70482933 | 1650 | Discr : Entity_Id; |
236fecbf JM |
1651 | First_Arg : Node_Id; |
1652 | Full_Init_Type : Entity_Id; | |
2168d7cc | 1653 | Init_Call : Node_Id; |
236fecbf JM |
1654 | Init_Type : Entity_Id; |
1655 | Proc : Entity_Id; | |
70482933 | 1656 | |
0289a8d7 AC |
1657 | -- Start of processing for Build_Initialization_Call |
1658 | ||
70482933 | 1659 | begin |
236fecbf JM |
1660 | pragma Assert (Constructor_Ref = Empty |
1661 | or else Is_CPP_Constructor_Call (Constructor_Ref)); | |
1662 | ||
1663 | if No (Constructor_Ref) then | |
1664 | Proc := Base_Init_Proc (Typ); | |
1665 | else | |
1666 | Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref))); | |
1667 | end if; | |
1668 | ||
ae65d635 | 1669 | pragma Assert (Present (Proc)); |
236fecbf JM |
1670 | Init_Type := Etype (First_Formal (Proc)); |
1671 | Full_Init_Type := Underlying_Type (Init_Type); | |
1672 | ||
2820d220 | 1673 | -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars |
70482933 RK |
1674 | -- is active (in which case we make the call anyway, since in the |
1675 | -- actual compiled client it may be non null). | |
1676 | ||
535a8637 | 1677 | if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then |
70482933 | 1678 | return Empty_List; |
1804faa4 AC |
1679 | |
1680 | -- Nothing to do for an array of controlled components that have only | |
1681 | -- the inherited Initialize primitive. This is a useful optimization | |
1682 | -- for CodePeer. | |
1683 | ||
1684 | elsif Is_Trivial_Subprogram (Proc) | |
1685 | and then Is_Array_Type (Full_Init_Type) | |
1686 | then | |
1687 | return New_List (Make_Null_Statement (Loc)); | |
70482933 RK |
1688 | end if; |
1689 | ||
8c691dc6 AC |
1690 | -- Use the [underlying] full view when dealing with a private type. This |
1691 | -- may require several steps depending on derivations. | |
625d8a9f | 1692 | |
46413d9e | 1693 | Full_Type := Typ; |
8c691dc6 AC |
1694 | loop |
1695 | if Is_Private_Type (Full_Type) then | |
1696 | if Present (Full_View (Full_Type)) then | |
1697 | Full_Type := Full_View (Full_Type); | |
1698 | ||
1699 | elsif Present (Underlying_Full_View (Full_Type)) then | |
1700 | Full_Type := Underlying_Full_View (Full_Type); | |
1701 | ||
1702 | -- When a private type acts as a generic actual and lacks a full | |
1703 | -- view, use the base type. | |
1704 | ||
1705 | elsif Is_Generic_Actual_Type (Full_Type) then | |
1706 | Full_Type := Base_Type (Full_Type); | |
1707 | ||
b03d3f73 AC |
1708 | elsif Ekind (Full_Type) = E_Private_Subtype |
1709 | and then (not Has_Discriminants (Full_Type) | |
1710 | or else No (Discriminant_Constraint (Full_Type))) | |
1711 | then | |
1712 | Full_Type := Etype (Full_Type); | |
1713 | ||
8c691dc6 AC |
1714 | -- The loop has recovered the [underlying] full view, stop the |
1715 | -- traversal. | |
1716 | ||
1717 | else | |
1718 | exit; | |
1719 | end if; | |
1720 | ||
1721 | -- The type is not private, nothing to do | |
1722 | ||
1723 | else | |
1724 | exit; | |
1725 | end if; | |
1726 | end loop; | |
70482933 RK |
1727 | |
1728 | -- If Typ is derived, the procedure is the initialization procedure for | |
1729 | -- the root type. Wrap the argument in an conversion to make it type | |
1730 | -- honest. Actually it isn't quite type honest, because there can be | |
1731 | -- conflicts of views in the private type case. That is why we set | |
1732 | -- Conversion_OK in the conversion node. | |
a05e99a2 | 1733 | |
70482933 RK |
1734 | if (Is_Record_Type (Typ) |
1735 | or else Is_Array_Type (Typ) | |
1736 | or else Is_Private_Type (Typ)) | |
1737 | and then Init_Type /= Base_Type (Typ) | |
1738 | then | |
1739 | First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref); | |
1740 | Set_Etype (First_Arg, Init_Type); | |
1741 | ||
1742 | else | |
1743 | First_Arg := Id_Ref; | |
1744 | end if; | |
1745 | ||
1746 | Args := New_List (Convert_Concurrent (First_Arg, Typ)); | |
1747 | ||
1748 | -- In the tasks case, add _Master as the value of the _Master parameter | |
1749 | -- and _Chain as the value of the _Chain parameter. At the outer level, | |
1750 | -- these will be variables holding the corresponding values obtained | |
1751 | -- from GNARL. At inner levels, they will be the parameters passed down | |
1752 | -- through the outer routines. | |
1753 | ||
1754 | if Has_Task (Full_Type) then | |
6e937c1c | 1755 | if Restriction_Active (No_Task_Hierarchy) then |
37cd8d97 | 1756 | Append_To (Args, Make_Integer_Literal (Loc, Library_Task_Level)); |
70482933 RK |
1757 | else |
1758 | Append_To (Args, Make_Identifier (Loc, Name_uMaster)); | |
1759 | end if; | |
1760 | ||
6bc057a7 AC |
1761 | -- Add _Chain (not done for sequential elaboration policy, see |
1762 | -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). | |
c18e9f65 | 1763 | |
6bc057a7 | 1764 | if Partition_Elaboration_Policy /= 'S' then |
c18e9f65 TG |
1765 | Append_To (Args, Make_Identifier (Loc, Name_uChain)); |
1766 | end if; | |
70482933 | 1767 | |
0ab80019 | 1768 | -- Ada 2005 (AI-287): In case of default initialized components |
c45b6ae0 AC |
1769 | -- with tasks, we generate a null string actual parameter. |
1770 | -- This is just a workaround that must be improved later??? | |
70482933 | 1771 | |
c45b6ae0 | 1772 | if With_Default_Init then |
1d571f3b AC |
1773 | Append_To (Args, |
1774 | Make_String_Literal (Loc, | |
1775 | Strval => "")); | |
1776 | ||
c45b6ae0 | 1777 | else |
3476f949 JM |
1778 | Decls := |
1779 | Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc); | |
c45b6ae0 AC |
1780 | Decl := Last (Decls); |
1781 | ||
1782 | Append_To (Args, | |
1783 | New_Occurrence_Of (Defining_Identifier (Decl), Loc)); | |
1784 | Append_List (Decls, Res); | |
1785 | end if; | |
70482933 RK |
1786 | |
1787 | else | |
1788 | Decls := No_List; | |
1789 | Decl := Empty; | |
1790 | end if; | |
1791 | ||
341e0bb6 JS |
1792 | -- Handle the optionally generated formal *_skip_null_excluding_checks |
1793 | ||
fa528281 JS |
1794 | -- Look at the associated node for the object we are referencing and |
1795 | -- verify that we are expanding a call to an Init_Proc for an internally | |
1796 | -- generated object declaration before passing True and skipping the | |
1797 | -- relevant checks. | |
1798 | ||
1799 | if Needs_Conditional_Null_Excluding_Check (Full_Init_Type) | |
1800 | and then Nkind (Id_Ref) in N_Has_Entity | |
1801 | and then (Comes_From_Source (Id_Ref) | |
1802 | or else (Present (Associated_Node (Id_Ref)) | |
1803 | and then Comes_From_Source | |
1804 | (Associated_Node (Id_Ref)))) | |
1805 | then | |
1806 | Append_To (Args, New_Occurrence_Of (Standard_True, Loc)); | |
341e0bb6 JS |
1807 | end if; |
1808 | ||
70482933 RK |
1809 | -- Add discriminant values if discriminants are present |
1810 | ||
1811 | if Has_Discriminants (Full_Init_Type) then | |
1812 | Discr := First_Discriminant (Full_Init_Type); | |
70482933 RK |
1813 | while Present (Discr) loop |
1814 | ||
1815 | -- If this is a discriminated concurrent type, the init_proc | |
47cc8d6b ES |
1816 | -- for the corresponding record is being called. Use that type |
1817 | -- directly to find the discriminant value, to handle properly | |
1818 | -- intervening renamed discriminants. | |
70482933 RK |
1819 | |
1820 | declare | |
1821 | T : Entity_Id := Full_Type; | |
1822 | ||
1823 | begin | |
1824 | if Is_Protected_Type (T) then | |
1825 | T := Corresponding_Record_Type (T); | |
1826 | end if; | |
1827 | ||
1828 | Arg := | |
1829 | Get_Discriminant_Value ( | |
1830 | Discr, | |
1831 | T, | |
1832 | Discriminant_Constraint (Full_Type)); | |
1833 | end; | |
1834 | ||
08f8a983 AC |
1835 | -- If the target has access discriminants, and is constrained by |
1836 | -- an access to the enclosing construct, i.e. a current instance, | |
1837 | -- replace the reference to the type by a reference to the object. | |
1838 | ||
1839 | if Nkind (Arg) = N_Attribute_Reference | |
1840 | and then Is_Access_Type (Etype (Arg)) | |
1841 | and then Is_Entity_Name (Prefix (Arg)) | |
1842 | and then Is_Type (Entity (Prefix (Arg))) | |
1843 | then | |
1844 | Arg := | |
1845 | Make_Attribute_Reference (Loc, | |
1846 | Prefix => New_Copy (Prefix (Id_Ref)), | |
1847 | Attribute_Name => Name_Unrestricted_Access); | |
1848 | ||
1849 | elsif In_Init_Proc then | |
70482933 RK |
1850 | |
1851 | -- Replace any possible references to the discriminant in the | |
1852 | -- call to the record initialization procedure with references | |
1853 | -- to the appropriate formal parameter. | |
1854 | ||
1855 | if Nkind (Arg) = N_Identifier | |
ee4eee0a | 1856 | and then Ekind (Entity (Arg)) = E_Discriminant |
70482933 | 1857 | then |
e4494292 | 1858 | Arg := New_Occurrence_Of (Discriminal (Entity (Arg)), Loc); |
70482933 | 1859 | |
47cc8d6b ES |
1860 | -- Otherwise make a copy of the default expression. Note that |
1861 | -- we use the current Sloc for this, because we do not want the | |
1862 | -- call to appear to be at the declaration point. Within the | |
1863 | -- expression, replace discriminants with their discriminals. | |
70482933 RK |
1864 | |
1865 | else | |
1866 | Arg := | |
1867 | New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc); | |
1868 | end if; | |
1869 | ||
1870 | else | |
1871 | if Is_Constrained (Full_Type) then | |
fbf5a39b | 1872 | Arg := Duplicate_Subexpr_No_Checks (Arg); |
70482933 | 1873 | else |
47cc8d6b ES |
1874 | -- The constraints come from the discriminant default exps, |
1875 | -- they must be reevaluated, so we use New_Copy_Tree but we | |
1876 | -- ensure the proper Sloc (for any embedded calls). | |
eae66578 | 1877 | -- In addition, if a predicate check is needed on the value |
e666e744 | 1878 | -- of the discriminant, insert it ahead of the call. |
70482933 RK |
1879 | |
1880 | Arg := New_Copy_Tree (Arg, New_Sloc => Loc); | |
0289a8d7 | 1881 | end if; |
e666e744 | 1882 | |
0289a8d7 AC |
1883 | if Has_Predicates (Etype (Discr)) then |
1884 | Check_Predicated_Discriminant (Arg, Discr); | |
70482933 RK |
1885 | end if; |
1886 | end if; | |
1887 | ||
1baa4d2d | 1888 | -- Ada 2005 (AI-287): In case of default initialized components, |
6823270c AC |
1889 | -- if the component is constrained with a discriminant of the |
1890 | -- enclosing type, we need to generate the corresponding selected | |
1891 | -- component node to access the discriminant value. In other cases | |
1892 | -- this is not required, either because we are inside the init | |
1893 | -- proc and we use the corresponding formal, or else because the | |
1894 | -- component is constrained by an expression. | |
c45b6ae0 AC |
1895 | |
1896 | if With_Default_Init | |
1897 | and then Nkind (Id_Ref) = N_Selected_Component | |
a05e99a2 | 1898 | and then Nkind (Arg) = N_Identifier |
6823270c | 1899 | and then Ekind (Entity (Arg)) = E_Discriminant |
c45b6ae0 AC |
1900 | then |
1901 | Append_To (Args, | |
1902 | Make_Selected_Component (Loc, | |
2168d7cc | 1903 | Prefix => New_Copy_Tree (Prefix (Id_Ref)), |
c45b6ae0 AC |
1904 | Selector_Name => Arg)); |
1905 | else | |
1906 | Append_To (Args, Arg); | |
1907 | end if; | |
70482933 RK |
1908 | |
1909 | Next_Discriminant (Discr); | |
1910 | end loop; | |
1911 | end if; | |
1912 | ||
1913 | -- If this is a call to initialize the parent component of a derived | |
1914 | -- tagged type, indicate that the tag should not be set in the parent. | |
b77029ff SB |
1915 | -- This is done via the actual parameter value for the Init_Control |
1916 | -- formal parameter, which is also used to deal with late initialization | |
1917 | -- requirements. | |
1918 | -- | |
1919 | -- We pass in Full_Init_Except_Tag unless the caller tells us to do | |
1920 | -- otherwise (by passing in a nonempty Init_Control_Actual parameter). | |
70482933 RK |
1921 | |
1922 | if Is_Tagged_Type (Full_Init_Type) | |
1923 | and then not Is_CPP_Class (Full_Init_Type) | |
1924 | and then Nkind (Id_Ref) = N_Selected_Component | |
1925 | and then Chars (Selector_Name (Id_Ref)) = Name_uParent | |
1926 | then | |
b77029ff SB |
1927 | declare |
1928 | use Initialization_Control; | |
1929 | begin | |
1930 | Append_To (Args, | |
1931 | (if Present (Init_Control_Actual) | |
1932 | then Init_Control_Actual | |
1933 | else Make_Mode_Literal (Loc, Full_Init_Except_Tag))); | |
1934 | end; | |
236fecbf JM |
1935 | elsif Present (Constructor_Ref) then |
1936 | Append_List_To (Args, | |
1937 | New_Copy_List (Parameter_Associations (Constructor_Ref))); | |
70482933 RK |
1938 | end if; |
1939 | ||
d7e20130 JS |
1940 | -- Pass the extra accessibility level parameter associated with the |
1941 | -- level of the object being initialized when required. | |
1942 | ||
d7e20130 JS |
1943 | if Is_Entity_Name (Id_Ref) |
1944 | and then Present (Init_Proc_Level_Formal (Proc)) | |
1945 | then | |
1946 | Append_To (Args, | |
1947 | Make_Parameter_Association (Loc, | |
1948 | Selector_Name => | |
1949 | Make_Identifier (Loc, Name_uInit_Level), | |
1950 | Explicit_Actual_Parameter => | |
66e97274 | 1951 | Accessibility_Level (Id_Ref, Dynamic_Level))); |
d7e20130 JS |
1952 | end if; |
1953 | ||
70482933 RK |
1954 | Append_To (Res, |
1955 | Make_Procedure_Call_Statement (Loc, | |
2168d7cc | 1956 | Name => New_Occurrence_Of (Proc, Loc), |
70482933 RK |
1957 | Parameter_Associations => Args)); |
1958 | ||
048e5cef | 1959 | if Needs_Finalization (Typ) |
70482933 RK |
1960 | and then Nkind (Id_Ref) = N_Selected_Component |
1961 | then | |
1962 | if Chars (Selector_Name (Id_Ref)) /= Name_uParent then | |
2168d7cc | 1963 | Init_Call := |
243cae0a AC |
1964 | Make_Init_Call |
1965 | (Obj_Ref => New_Copy_Tree (First_Arg), | |
2168d7cc AC |
1966 | Typ => Typ); |
1967 | ||
1968 | -- Guard against a missing [Deep_]Initialize when the type was not | |
1969 | -- properly frozen. | |
1970 | ||
1971 | if Present (Init_Call) then | |
1972 | Append_To (Res, Init_Call); | |
1973 | end if; | |
70482933 RK |
1974 | end if; |
1975 | end if; | |
1976 | ||
70482933 | 1977 | return Res; |
fbf5a39b AC |
1978 | |
1979 | exception | |
1980 | when RE_Not_Available => | |
1981 | return Empty_List; | |
70482933 RK |
1982 | end Build_Initialization_Call; |
1983 | ||
70482933 RK |
1984 | ---------------------------- |
1985 | -- Build_Record_Init_Proc -- | |
1986 | ---------------------------- | |
1987 | ||
df3e68b1 | 1988 | procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id) is |
db4b3c49 AC |
1989 | Decls : constant List_Id := New_List; |
1990 | Discr_Map : constant Elist_Id := New_Elmt_List; | |
1991 | Loc : constant Source_Ptr := Sloc (Rec_Ent); | |
16e764a7 | 1992 | Counter : Nat := 0; |
db4b3c49 AC |
1993 | Proc_Id : Entity_Id; |
1994 | Rec_Type : Entity_Id; | |
b77029ff SB |
1995 | |
1996 | Init_Control_Formal : Entity_Id := Empty; -- set in Build_Init_Statements | |
1997 | Has_Late_Init_Comp : Boolean := False; -- set in Build_Init_Statements | |
70482933 | 1998 | |
5168a9b3 | 1999 | function Build_Assignment |
3fc40cd7 PMR |
2000 | (Id : Entity_Id; |
2001 | Default : Node_Id) return List_Id; | |
5168a9b3 PMR |
2002 | -- Build an assignment statement that assigns the default expression to |
2003 | -- its corresponding record component if defined. The left-hand side of | |
2004 | -- the assignment is marked Assignment_OK so that initialization of | |
df3e68b1 HK |
2005 | -- limited private records works correctly. This routine may also build |
2006 | -- an adjustment call if the component is controlled. | |
70482933 RK |
2007 | |
2008 | procedure Build_Discriminant_Assignments (Statement_List : List_Id); | |
df3e68b1 HK |
2009 | -- If the record has discriminants, add assignment statements to |
2010 | -- Statement_List to initialize the discriminant values from the | |
70482933 RK |
2011 | -- arguments of the initialization procedure. |
2012 | ||
2013 | function Build_Init_Statements (Comp_List : Node_Id) return List_Id; | |
2014 | -- Build a list representing a sequence of statements which initialize | |
2015 | -- components of the given component list. This may involve building | |
df3e68b1 HK |
2016 | -- case statements for the variant parts. Append any locally declared |
2017 | -- objects on list Decls. | |
70482933 | 2018 | |
2e071734 | 2019 | function Build_Init_Call_Thru (Parameters : List_Id) return List_Id; |
e9a79435 | 2020 | -- Given an untagged type-derivation that declares discriminants, e.g. |
70482933 | 2021 | -- |
1fb63e89 RD |
2022 | -- type R (R1, R2 : Integer) is record ... end record; |
2023 | -- type D (D1 : Integer) is new R (1, D1); | |
70482933 RK |
2024 | -- |
2025 | -- we make the _init_proc of D be | |
2026 | -- | |
df3e68b1 | 2027 | -- procedure _init_proc (X : D; D1 : Integer) is |
70482933 | 2028 | -- begin |
df3e68b1 | 2029 | -- _init_proc (R (X), 1, D1); |
70482933 RK |
2030 | -- end _init_proc; |
2031 | -- | |
2032 | -- This function builds the call statement in this _init_proc. | |
2033 | ||
cefce34c JM |
2034 | procedure Build_CPP_Init_Procedure; |
2035 | -- Build the tree corresponding to the procedure specification and body | |
2036 | -- of the IC procedure that initializes the C++ part of the dispatch | |
2037 | -- table of an Ada tagged type that is a derivation of a CPP type. | |
2038 | -- Install it as the CPP_Init TSS. | |
2039 | ||
70482933 RK |
2040 | procedure Build_Init_Procedure; |
2041 | -- Build the tree corresponding to the procedure specification and body | |
df3e68b1 | 2042 | -- of the initialization procedure and install it as the _init TSS. |
70482933 | 2043 | |
a05e99a2 JM |
2044 | procedure Build_Offset_To_Top_Functions; |
2045 | -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec | |
df3e68b1 HK |
2046 | -- and body of Offset_To_Top, a function used in conjuction with types |
2047 | -- having secondary dispatch tables. | |
a05e99a2 | 2048 | |
07fc65c4 | 2049 | procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id); |
47cc8d6b | 2050 | -- Add range checks to components of discriminated records. S is a |
07fc65c4 GB |
2051 | -- subtype indication of a record component. Check_List is a list |
2052 | -- to which the check actions are appended. | |
70482933 RK |
2053 | |
2054 | function Component_Needs_Simple_Initialization | |
2e071734 | 2055 | (T : Entity_Id) return Boolean; |
df3e68b1 HK |
2056 | -- Determine if a component needs simple initialization, given its type |
2057 | -- T. This routine is the same as Needs_Simple_Initialization except for | |
2058 | -- components of type Tag and Interface_Tag. These two access types do | |
2059 | -- not require initialization since they are explicitly initialized by | |
2060 | -- other means. | |
70482933 RK |
2061 | |
2062 | function Parent_Subtype_Renaming_Discrims return Boolean; | |
2063 | -- Returns True for base types N that rename discriminants, else False | |
2064 | ||
2065 | function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean; | |
df3e68b1 | 2066 | -- Determine whether a record initialization procedure needs to be |
70482933 RK |
2067 | -- generated for the given record type. |
2068 | ||
2069 | ---------------------- | |
2070 | -- Build_Assignment -- | |
2071 | ---------------------- | |
2072 | ||
5168a9b3 | 2073 | function Build_Assignment |
3fc40cd7 PMR |
2074 | (Id : Entity_Id; |
2075 | Default : Node_Id) return List_Id | |
5168a9b3 PMR |
2076 | is |
2077 | Default_Loc : constant Source_Ptr := Sloc (Default); | |
3fc40cd7 | 2078 | Typ : constant Entity_Id := Underlying_Type (Etype (Id)); |
2168d7cc AC |
2079 | |
2080 | Adj_Call : Node_Id; | |
ea5a7a77 EB |
2081 | Exp : Node_Id; |
2082 | Exp_Q : Node_Id; | |
2168d7cc AC |
2083 | Lhs : Node_Id; |
2084 | Res : List_Id; | |
70482933 RK |
2085 | |
2086 | begin | |
70482933 | 2087 | Lhs := |
5168a9b3 | 2088 | Make_Selected_Component (Default_Loc, |
7675ad4f | 2089 | Prefix => Make_Identifier (Loc, Name_uInit), |
5168a9b3 | 2090 | Selector_Name => New_Occurrence_Of (Id, Default_Loc)); |
70482933 RK |
2091 | Set_Assignment_OK (Lhs); |
2092 | ||
ea5a7a77 | 2093 | -- Take copy of Default to ensure that later copies of this component |
47cc8d6b | 2094 | -- declaration in derived types see the original tree, not a node |
5afaf827 | 2095 | -- rewritten during expansion of the init_proc. If the copy contains |
e7d72fb9 | 2096 | -- itypes, the scope of the new itypes is the init_proc being built. |
c885d7a1 | 2097 | |
77630ba9 SB |
2098 | declare |
2099 | Map : Elist_Id := No_Elist; | |
ea5a7a77 | 2100 | |
77630ba9 SB |
2101 | begin |
2102 | if Has_Late_Init_Comp then | |
2103 | -- Map the type to the _Init parameter in order to | |
2104 | -- handle "current instance" references. | |
2105 | ||
2106 | Map := New_Elmt_List | |
2107 | (Elmt1 => Rec_Type, | |
2108 | Elmt2 => Defining_Identifier (First | |
2109 | (Parameter_Specifications | |
2110 | (Parent (Proc_Id))))); | |
1f26ff11 JS |
2111 | |
2112 | -- If the type has an incomplete view, a current instance | |
2113 | -- may have an incomplete type. In that case, it must also be | |
2114 | -- replaced by the formal of the Init_Proc. | |
2115 | ||
2116 | if Nkind (Parent (Rec_Type)) = N_Full_Type_Declaration | |
2117 | and then Present (Incomplete_View (Parent (Rec_Type))) | |
2118 | then | |
2119 | Append_Elmt ( | |
82ca7489 | 2120 | N => Incomplete_View (Parent (Rec_Type)), |
1f26ff11 JS |
2121 | To => Map); |
2122 | Append_Elmt ( | |
2123 | N => Defining_Identifier | |
2124 | (First | |
2125 | (Parameter_Specifications | |
2126 | (Parent (Proc_Id)))), | |
2127 | To => Map); | |
2128 | end if; | |
77630ba9 SB |
2129 | end if; |
2130 | ||
ea5a7a77 | 2131 | Exp := New_Copy_Tree (Default, New_Scope => Proc_Id, Map => Map); |
77630ba9 | 2132 | end; |
c885d7a1 | 2133 | |
70482933 RK |
2134 | Res := New_List ( |
2135 | Make_Assignment_Statement (Loc, | |
2136 | Name => Lhs, | |
2137 | Expression => Exp)); | |
2138 | ||
2139 | Set_No_Ctrl_Actions (First (Res)); | |
2140 | ||
ea5a7a77 EB |
2141 | Exp_Q := Unqualify (Exp); |
2142 | ||
70482933 | 2143 | -- Adjust the tag if tagged (because of possible view conversions). |
535a8637 | 2144 | -- Suppress the tag adjustment when not Tagged_Type_Expansion because |
32794080 JM |
2145 | -- tags are represented implicitly in objects, and when the record is |
2146 | -- initialized with a raise expression. | |
2147 | ||
2148 | if Is_Tagged_Type (Typ) | |
2149 | and then Tagged_Type_Expansion | |
ea5a7a77 | 2150 | and then Nkind (Exp_Q) /= N_Raise_Expression |
32794080 | 2151 | then |
70482933 | 2152 | Append_To (Res, |
af10c962 EB |
2153 | Make_Tag_Assignment_From_Type |
2154 | (Default_Loc, | |
2155 | New_Copy_Tree (Lhs, New_Scope => Proc_Id), | |
2156 | Underlying_Type (Typ))); | |
70482933 RK |
2157 | end if; |
2158 | ||
47cc8d6b | 2159 | -- Adjust the component if controlled except if it is an aggregate |
e7d72fb9 | 2160 | -- that will be expanded inline. |
70482933 | 2161 | |
048e5cef | 2162 | if Needs_Finalization (Typ) |
ea5a7a77 | 2163 | and then Nkind (Exp_Q) not in N_Aggregate | N_Extension_Aggregate |
5168a9b3 | 2164 | and then not Is_Build_In_Place_Function_Call (Exp) |
70482933 | 2165 | then |
2168d7cc | 2166 | Adj_Call := |
243cae0a AC |
2167 | Make_Adjust_Call |
2168 | (Obj_Ref => New_Copy_Tree (Lhs), | |
2168d7cc AC |
2169 | Typ => Etype (Id)); |
2170 | ||
2171 | -- Guard against a missing [Deep_]Adjust when the component type | |
2172 | -- was not properly frozen. | |
2173 | ||
2174 | if Present (Adj_Call) then | |
2175 | Append_To (Res, Adj_Call); | |
2176 | end if; | |
70482933 RK |
2177 | end if; |
2178 | ||
2179 | return Res; | |
fbf5a39b AC |
2180 | |
2181 | exception | |
2182 | when RE_Not_Available => | |
2183 | return Empty_List; | |
70482933 RK |
2184 | end Build_Assignment; |
2185 | ||
2186 | ------------------------------------ | |
2187 | -- Build_Discriminant_Assignments -- | |
2188 | ------------------------------------ | |
2189 | ||
2190 | procedure Build_Discriminant_Assignments (Statement_List : List_Id) is | |
70482933 | 2191 | Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type); |
df3e68b1 | 2192 | D : Entity_Id; |
db4b3c49 | 2193 | D_Loc : Source_Ptr; |
70482933 RK |
2194 | |
2195 | begin | |
2196 | if Has_Discriminants (Rec_Type) | |
2197 | and then not Is_Unchecked_Union (Rec_Type) | |
2198 | then | |
2199 | D := First_Discriminant (Rec_Type); | |
70482933 | 2200 | while Present (D) loop |
327503f1 | 2201 | |
70482933 RK |
2202 | -- Don't generate the assignment for discriminants in derived |
2203 | -- tagged types if the discriminant is a renaming of some | |
a05e99a2 | 2204 | -- ancestor discriminant. This initialization will be done |
70482933 RK |
2205 | -- when initializing the _parent field of the derived record. |
2206 | ||
df3e68b1 HK |
2207 | if Is_Tagged |
2208 | and then Present (Corresponding_Discriminant (D)) | |
70482933 RK |
2209 | then |
2210 | null; | |
2211 | ||
2212 | else | |
db4b3c49 | 2213 | D_Loc := Sloc (D); |
70482933 RK |
2214 | Append_List_To (Statement_List, |
2215 | Build_Assignment (D, | |
e4494292 | 2216 | New_Occurrence_Of (Discriminal (D), D_Loc))); |
70482933 RK |
2217 | end if; |
2218 | ||
2219 | Next_Discriminant (D); | |
2220 | end loop; | |
2221 | end if; | |
2222 | end Build_Discriminant_Assignments; | |
2223 | ||
2224 | -------------------------- | |
2225 | -- Build_Init_Call_Thru -- | |
2226 | -------------------------- | |
2227 | ||
2e071734 AC |
2228 | function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is |
2229 | Parent_Proc : constant Entity_Id := | |
2230 | Base_Init_Proc (Etype (Rec_Type)); | |
70482933 | 2231 | |
2e071734 AC |
2232 | Parent_Type : constant Entity_Id := |
2233 | Etype (First_Formal (Parent_Proc)); | |
70482933 | 2234 | |
2e071734 AC |
2235 | Uparent_Type : constant Entity_Id := |
2236 | Underlying_Type (Parent_Type); | |
70482933 RK |
2237 | |
2238 | First_Discr_Param : Node_Id; | |
2239 | ||
70482933 | 2240 | Arg : Node_Id; |
df3e68b1 HK |
2241 | Args : List_Id; |
2242 | First_Arg : Node_Id; | |
2243 | Parent_Discr : Entity_Id; | |
70482933 RK |
2244 | Res : List_Id; |
2245 | ||
2246 | begin | |
2247 | -- First argument (_Init) is the object to be initialized. | |
2248 | -- ??? not sure where to get a reasonable Loc for First_Arg | |
2249 | ||
2250 | First_Arg := | |
2251 | OK_Convert_To (Parent_Type, | |
e4494292 RD |
2252 | New_Occurrence_Of |
2253 | (Defining_Identifier (First (Parameters)), Loc)); | |
70482933 RK |
2254 | |
2255 | Set_Etype (First_Arg, Parent_Type); | |
2256 | ||
2257 | Args := New_List (Convert_Concurrent (First_Arg, Rec_Type)); | |
2258 | ||
2259 | -- In the tasks case, | |
2260 | -- add _Master as the value of the _Master parameter | |
2261 | -- add _Chain as the value of the _Chain parameter. | |
fbf5a39b | 2262 | -- add _Task_Name as the value of the _Task_Name parameter. |
70482933 RK |
2263 | -- At the outer level, these will be variables holding the |
2264 | -- corresponding values obtained from GNARL or the expander. | |
2265 | -- | |
2266 | -- At inner levels, they will be the parameters passed down through | |
2267 | -- the outer routines. | |
2268 | ||
2269 | First_Discr_Param := Next (First (Parameters)); | |
2270 | ||
2271 | if Has_Task (Rec_Type) then | |
6e937c1c | 2272 | if Restriction_Active (No_Task_Hierarchy) then |
37cd8d97 AC |
2273 | Append_To |
2274 | (Args, Make_Integer_Literal (Loc, Library_Task_Level)); | |
70482933 RK |
2275 | else |
2276 | Append_To (Args, Make_Identifier (Loc, Name_uMaster)); | |
2277 | end if; | |
2278 | ||
6bc057a7 AC |
2279 | -- Add _Chain (not done for sequential elaboration policy, see |
2280 | -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). | |
c18e9f65 | 2281 | |
6bc057a7 | 2282 | if Partition_Elaboration_Policy /= 'S' then |
c18e9f65 TG |
2283 | Append_To (Args, Make_Identifier (Loc, Name_uChain)); |
2284 | end if; | |
2285 | ||
fbf5a39b | 2286 | Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); |
70482933 RK |
2287 | First_Discr_Param := Next (Next (Next (First_Discr_Param))); |
2288 | end if; | |
2289 | ||
2290 | -- Append discriminant values | |
2291 | ||
2292 | if Has_Discriminants (Uparent_Type) then | |
2293 | pragma Assert (not Is_Tagged_Type (Uparent_Type)); | |
2294 | ||
2295 | Parent_Discr := First_Discriminant (Uparent_Type); | |
2296 | while Present (Parent_Discr) loop | |
2297 | ||
2298 | -- Get the initial value for this discriminant | |
fbf5a39b | 2299 | -- ??? needs to be cleaned up to use parent_Discr_Constr |
70482933 RK |
2300 | -- directly. |
2301 | ||
2302 | declare | |
70482933 | 2303 | Discr : Entity_Id := |
fbf5a39b | 2304 | First_Stored_Discriminant (Uparent_Type); |
df3e68b1 HK |
2305 | |
2306 | Discr_Value : Elmt_Id := | |
2307 | First_Elmt (Stored_Constraint (Rec_Type)); | |
2308 | ||
70482933 RK |
2309 | begin |
2310 | while Original_Record_Component (Parent_Discr) /= Discr loop | |
fbf5a39b | 2311 | Next_Stored_Discriminant (Discr); |
70482933 RK |
2312 | Next_Elmt (Discr_Value); |
2313 | end loop; | |
2314 | ||
2315 | Arg := Node (Discr_Value); | |
2316 | end; | |
2317 | ||
2318 | -- Append it to the list | |
2319 | ||
2320 | if Nkind (Arg) = N_Identifier | |
ee4eee0a | 2321 | and then Ekind (Entity (Arg)) = E_Discriminant |
70482933 RK |
2322 | then |
2323 | Append_To (Args, | |
e4494292 | 2324 | New_Occurrence_Of (Discriminal (Entity (Arg)), Loc)); |
70482933 RK |
2325 | |
2326 | -- Case of access discriminants. We replace the reference | |
3476f949 | 2327 | -- to the type by a reference to the actual object. |
70482933 | 2328 | |
3476f949 JM |
2329 | -- Is above comment right??? Use of New_Copy below seems mighty |
2330 | -- suspicious ??? | |
70482933 RK |
2331 | |
2332 | else | |
2333 | Append_To (Args, New_Copy (Arg)); | |
2334 | end if; | |
2335 | ||
2336 | Next_Discriminant (Parent_Discr); | |
2337 | end loop; | |
2338 | end if; | |
2339 | ||
2340 | Res := | |
df3e68b1 HK |
2341 | New_List ( |
2342 | Make_Procedure_Call_Statement (Loc, | |
243cae0a | 2343 | Name => |
df3e68b1 HK |
2344 | New_Occurrence_Of (Parent_Proc, Loc), |
2345 | Parameter_Associations => Args)); | |
70482933 RK |
2346 | |
2347 | return Res; | |
2348 | end Build_Init_Call_Thru; | |
2349 | ||
a05e99a2 JM |
2350 | ----------------------------------- |
2351 | -- Build_Offset_To_Top_Functions -- | |
2352 | ----------------------------------- | |
2353 | ||
2354 | procedure Build_Offset_To_Top_Functions is | |
a05e99a2 | 2355 | |
04df6250 TQ |
2356 | procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id); |
2357 | -- Generate: | |
8a49a499 AC |
2358 | -- function Fxx (O : Address) return Storage_Offset is |
2359 | -- type Acc is access all <Typ>; | |
04df6250 | 2360 | -- begin |
8a49a499 | 2361 | -- return Acc!(O).Iface_Comp'Position; |
04df6250 | 2362 | -- end Fxx; |
a05e99a2 | 2363 | |
a8f59a33 AC |
2364 | ---------------------------------- |
2365 | -- Build_Offset_To_Top_Function -- | |
2366 | ---------------------------------- | |
04df6250 TQ |
2367 | |
2368 | procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is | |
2369 | Body_Node : Node_Id; | |
2370 | Func_Id : Entity_Id; | |
2371 | Spec_Node : Node_Id; | |
8a49a499 | 2372 | Acc_Type : Entity_Id; |
a05e99a2 | 2373 | |
a05e99a2 | 2374 | begin |
191fcb3a | 2375 | Func_Id := Make_Temporary (Loc, 'F'); |
04df6250 | 2376 | Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id); |
ea1941af | 2377 | |
04df6250 TQ |
2378 | -- Generate |
2379 | -- function Fxx (O : in Rec_Typ) return Storage_Offset; | |
a05e99a2 | 2380 | |
04df6250 TQ |
2381 | Spec_Node := New_Node (N_Function_Specification, Loc); |
2382 | Set_Defining_Unit_Name (Spec_Node, Func_Id); | |
2383 | Set_Parameter_Specifications (Spec_Node, New_List ( | |
2384 | Make_Parameter_Specification (Loc, | |
df3e68b1 HK |
2385 | Defining_Identifier => |
2386 | Make_Defining_Identifier (Loc, Name_uO), | |
243cae0a AC |
2387 | In_Present => True, |
2388 | Parameter_Type => | |
e4494292 | 2389 | New_Occurrence_Of (RTE (RE_Address), Loc)))); |
04df6250 | 2390 | Set_Result_Definition (Spec_Node, |
e4494292 | 2391 | New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); |
04df6250 TQ |
2392 | |
2393 | -- Generate | |
2394 | -- function Fxx (O : in Rec_Typ) return Storage_Offset is | |
2395 | -- begin | |
d0567dc0 | 2396 | -- return -O.Iface_Comp'Position; |
04df6250 TQ |
2397 | -- end Fxx; |
2398 | ||
2399 | Body_Node := New_Node (N_Subprogram_Body, Loc); | |
2400 | Set_Specification (Body_Node, Spec_Node); | |
8a49a499 AC |
2401 | |
2402 | Acc_Type := Make_Temporary (Loc, 'T'); | |
2403 | Set_Declarations (Body_Node, New_List ( | |
2404 | Make_Full_Type_Declaration (Loc, | |
2405 | Defining_Identifier => Acc_Type, | |
5b5b27ad | 2406 | Type_Definition => |
8a49a499 AC |
2407 | Make_Access_To_Object_Definition (Loc, |
2408 | All_Present => True, | |
2409 | Null_Exclusion_Present => False, | |
2410 | Constant_Present => False, | |
2411 | Subtype_Indication => | |
e4494292 | 2412 | New_Occurrence_Of (Rec_Type, Loc))))); |
8a49a499 | 2413 | |
04df6250 TQ |
2414 | Set_Handled_Statement_Sequence (Body_Node, |
2415 | Make_Handled_Sequence_Of_Statements (Loc, | |
243cae0a | 2416 | Statements => New_List ( |
04df6250 TQ |
2417 | Make_Simple_Return_Statement (Loc, |
2418 | Expression => | |
d0567dc0 PMR |
2419 | Make_Op_Minus (Loc, |
2420 | Make_Attribute_Reference (Loc, | |
2421 | Prefix => | |
2422 | Make_Selected_Component (Loc, | |
2423 | Prefix => | |
f715a5bd EB |
2424 | Make_Explicit_Dereference (Loc, |
2425 | Unchecked_Convert_To (Acc_Type, | |
2426 | Make_Identifier (Loc, Name_uO))), | |
d0567dc0 PMR |
2427 | Selector_Name => |
2428 | New_Occurrence_Of (Iface_Comp, Loc)), | |
2429 | Attribute_Name => Name_Position)))))); | |
04df6250 | 2430 | |
2e02ab86 | 2431 | Mutate_Ekind (Func_Id, E_Function); |
04df6250 TQ |
2432 | Set_Mechanism (Func_Id, Default_Mechanism); |
2433 | Set_Is_Internal (Func_Id, True); | |
2434 | ||
2435 | if not Debug_Generated_Code then | |
2436 | Set_Debug_Info_Off (Func_Id); | |
a05e99a2 JM |
2437 | end if; |
2438 | ||
04df6250 | 2439 | Analyze (Body_Node); |
a05e99a2 | 2440 | |
04df6250 TQ |
2441 | Append_Freeze_Action (Rec_Type, Body_Node); |
2442 | end Build_Offset_To_Top_Function; | |
a05e99a2 | 2443 | |
04df6250 | 2444 | -- Local variables |
a05e99a2 | 2445 | |
38b181d6 | 2446 | Iface_Comp : Node_Id; |
df3e68b1 HK |
2447 | Iface_Comp_Elmt : Elmt_Id; |
2448 | Ifaces_Comp_List : Elist_Id; | |
ae7adb1b | 2449 | |
a05e99a2 JM |
2450 | -- Start of processing for Build_Offset_To_Top_Functions |
2451 | ||
2452 | begin | |
04df6250 TQ |
2453 | -- Offset_To_Top_Functions are built only for derivations of types |
2454 | -- with discriminants that cover interface types. | |
535a8637 AC |
2455 | -- Nothing is needed either in case of virtual targets, since |
2456 | -- interfaces are handled directly by the target. | |
ea1941af | 2457 | |
04df6250 TQ |
2458 | if not Is_Tagged_Type (Rec_Type) |
2459 | or else Etype (Rec_Type) = Rec_Type | |
a05e99a2 | 2460 | or else not Has_Discriminants (Etype (Rec_Type)) |
1f110335 | 2461 | or else not Tagged_Type_Expansion |
a05e99a2 JM |
2462 | then |
2463 | return; | |
2464 | end if; | |
2465 | ||
38b181d6 | 2466 | Collect_Interface_Components (Rec_Type, Ifaces_Comp_List); |
a05e99a2 | 2467 | |
04df6250 TQ |
2468 | -- For each interface type with secondary dispatch table we generate |
2469 | -- the Offset_To_Top_Functions (required to displace the pointer in | |
2470 | -- interface conversions) | |
a05e99a2 | 2471 | |
38b181d6 JM |
2472 | Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); |
2473 | while Present (Iface_Comp_Elmt) loop | |
2474 | Iface_Comp := Node (Iface_Comp_Elmt); | |
2475 | pragma Assert (Is_Interface (Related_Type (Iface_Comp))); | |
a05e99a2 | 2476 | |
04df6250 TQ |
2477 | -- If the interface is a parent of Rec_Type it shares the primary |
2478 | -- dispatch table and hence there is no need to build the function | |
2479 | ||
4ac2477e JM |
2480 | if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type, |
2481 | Use_Full_View => True) | |
2482 | then | |
38b181d6 | 2483 | Build_Offset_To_Top_Function (Iface_Comp); |
04df6250 TQ |
2484 | end if; |
2485 | ||
38b181d6 | 2486 | Next_Elmt (Iface_Comp_Elmt); |
04df6250 | 2487 | end loop; |
a05e99a2 JM |
2488 | end Build_Offset_To_Top_Functions; |
2489 | ||
cefce34c JM |
2490 | ------------------------------ |
2491 | -- Build_CPP_Init_Procedure -- | |
2492 | ------------------------------ | |
2493 | ||
2494 | procedure Build_CPP_Init_Procedure is | |
2495 | Body_Node : Node_Id; | |
2496 | Body_Stmts : List_Id; | |
2497 | Flag_Id : Entity_Id; | |
cefce34c JM |
2498 | Handled_Stmt_Node : Node_Id; |
2499 | Init_Tags_List : List_Id; | |
2500 | Proc_Id : Entity_Id; | |
2501 | Proc_Spec_Node : Node_Id; | |
2502 | ||
2503 | begin | |
2504 | -- Check cases requiring no IC routine | |
2505 | ||
2506 | if not Is_CPP_Class (Root_Type (Rec_Type)) | |
2507 | or else Is_CPP_Class (Rec_Type) | |
2508 | or else CPP_Num_Prims (Rec_Type) = 0 | |
2509 | or else not Tagged_Type_Expansion | |
2510 | or else No_Run_Time_Mode | |
2511 | then | |
2512 | return; | |
2513 | end if; | |
2514 | ||
2515 | -- Generate: | |
2516 | ||
2517 | -- Flag : Boolean := False; | |
2518 | -- | |
2519 | -- procedure Typ_IC is | |
2520 | -- begin | |
2521 | -- if not Flag then | |
2522 | -- Copy C++ dispatch table slots from parent | |
2523 | -- Update C++ slots of overridden primitives | |
2524 | -- end if; | |
2525 | -- end; | |
2526 | ||
2527 | Flag_Id := Make_Temporary (Loc, 'F'); | |
2528 | ||
6d0b56ad | 2529 | Append_Freeze_Action (Rec_Type, |
cefce34c JM |
2530 | Make_Object_Declaration (Loc, |
2531 | Defining_Identifier => Flag_Id, | |
2532 | Object_Definition => | |
e4494292 | 2533 | New_Occurrence_Of (Standard_Boolean, Loc), |
cefce34c | 2534 | Expression => |
6d0b56ad | 2535 | New_Occurrence_Of (Standard_True, Loc))); |
cefce34c JM |
2536 | |
2537 | Body_Stmts := New_List; | |
6d0b56ad | 2538 | Body_Node := New_Node (N_Subprogram_Body, Loc); |
cefce34c JM |
2539 | |
2540 | Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); | |
2541 | ||
2542 | Proc_Id := | |
2543 | Make_Defining_Identifier (Loc, | |
2544 | Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc)); | |
2545 | ||
2e02ab86 | 2546 | Mutate_Ekind (Proc_Id, E_Procedure); |
cefce34c JM |
2547 | Set_Is_Internal (Proc_Id); |
2548 | ||
2549 | Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); | |
2550 | ||
2551 | Set_Parameter_Specifications (Proc_Spec_Node, New_List); | |
2552 | Set_Specification (Body_Node, Proc_Spec_Node); | |
6d0b56ad | 2553 | Set_Declarations (Body_Node, New_List); |
cefce34c JM |
2554 | |
2555 | Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type); | |
2556 | ||
2557 | Append_To (Init_Tags_List, | |
2558 | Make_Assignment_Statement (Loc, | |
2559 | Name => | |
e4494292 | 2560 | New_Occurrence_Of (Flag_Id, Loc), |
cefce34c | 2561 | Expression => |
e4494292 | 2562 | New_Occurrence_Of (Standard_False, Loc))); |
cefce34c JM |
2563 | |
2564 | Append_To (Body_Stmts, | |
2565 | Make_If_Statement (Loc, | |
2566 | Condition => New_Occurrence_Of (Flag_Id, Loc), | |
2567 | Then_Statements => Init_Tags_List)); | |
2568 | ||
2569 | Handled_Stmt_Node := | |
2570 | New_Node (N_Handled_Sequence_Of_Statements, Loc); | |
2571 | Set_Statements (Handled_Stmt_Node, Body_Stmts); | |
2572 | Set_Exception_Handlers (Handled_Stmt_Node, No_List); | |
2573 | Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); | |
2574 | ||
2575 | if not Debug_Generated_Code then | |
2576 | Set_Debug_Info_Off (Proc_Id); | |
2577 | end if; | |
2578 | ||
2579 | -- Associate CPP_Init_Proc with type | |
2580 | ||
2581 | Set_Init_Proc (Rec_Type, Proc_Id); | |
2582 | end Build_CPP_Init_Procedure; | |
2583 | ||
70482933 RK |
2584 | -------------------------- |
2585 | -- Build_Init_Procedure -- | |
2586 | -------------------------- | |
2587 | ||
2588 | procedure Build_Init_Procedure is | |
df3e68b1 | 2589 | Body_Stmts : List_Id; |
70482933 RK |
2590 | Body_Node : Node_Id; |
2591 | Handled_Stmt_Node : Node_Id; | |
df3e68b1 | 2592 | Init_Tags_List : List_Id; |
70482933 RK |
2593 | Parameters : List_Id; |
2594 | Proc_Spec_Node : Node_Id; | |
70482933 | 2595 | Record_Extension_Node : Node_Id; |
70482933 | 2596 | |
b77029ff | 2597 | use Initialization_Control; |
70482933 RK |
2598 | begin |
2599 | Body_Stmts := New_List; | |
2600 | Body_Node := New_Node (N_Subprogram_Body, Loc); | |
2e02ab86 | 2601 | Mutate_Ekind (Proc_Id, E_Procedure); |
70482933 RK |
2602 | |
2603 | Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); | |
2604 | Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); | |
2605 | ||
a7837c08 | 2606 | Parameters := Init_Formals (Rec_Type, Proc_Id); |
70482933 RK |
2607 | Append_List_To (Parameters, |
2608 | Build_Discriminant_Formals (Rec_Type, True)); | |
2609 | ||
b77029ff SB |
2610 | -- For tagged types, we add a parameter to indicate what |
2611 | -- portion of the object's initialization is to be performed. | |
2612 | -- This is used for two purposes: | |
2613 | -- 1) When a type extension's initialization procedure calls | |
2614 | -- the initialization procedure of the parent type, we do | |
2615 | -- not want the parent to initialize the Tag component; | |
2616 | -- it has been set already. | |
2617 | -- 2) If an ancestor type has at least one component that requires | |
2618 | -- late initialization, then we need to be able to initialize | |
2619 | -- those components separately after initializing any other | |
2620 | -- components. | |
70482933 | 2621 | |
cefce34c | 2622 | if Is_Tagged_Type (Rec_Type) then |
b77029ff | 2623 | Init_Control_Formal := Make_Temporary (Loc, 'P'); |
70482933 RK |
2624 | |
2625 | Append_To (Parameters, | |
2626 | Make_Parameter_Specification (Loc, | |
b77029ff | 2627 | Defining_Identifier => Init_Control_Formal, |
df3e68b1 | 2628 | Parameter_Type => |
b77029ff SB |
2629 | New_Occurrence_Of (Standard_Natural, Loc), |
2630 | Expression => Make_Mode_Literal (Loc, Full_Init))); | |
70482933 RK |
2631 | end if; |
2632 | ||
d7e20130 JS |
2633 | -- Create an extra accessibility parameter to capture the level of |
2634 | -- the object being initialized when its type is a limited record. | |
2635 | ||
2636 | if Is_Limited_Record (Rec_Type) then | |
2637 | Append_To (Parameters, | |
2638 | Make_Parameter_Specification (Loc, | |
2639 | Defining_Identifier => Make_Defining_Identifier | |
2640 | (Loc, Name_uInit_Level), | |
2641 | Parameter_Type => | |
2642 | New_Occurrence_Of (Standard_Natural, Loc), | |
2643 | Expression => | |
2644 | Make_Integer_Literal | |
2645 | (Loc, Scope_Depth (Standard_Standard)))); | |
2646 | end if; | |
2647 | ||
70482933 RK |
2648 | Set_Parameter_Specifications (Proc_Spec_Node, Parameters); |
2649 | Set_Specification (Body_Node, Proc_Spec_Node); | |
df3e68b1 | 2650 | Set_Declarations (Body_Node, Decls); |
70482933 | 2651 | |
df3e68b1 HK |
2652 | -- N is a Derived_Type_Definition that renames the parameters of the |
2653 | -- ancestor type. We initialize it by expanding our discriminants and | |
2654 | -- call the ancestor _init_proc with a type-converted object. | |
70482933 | 2655 | |
df3e68b1 HK |
2656 | if Parent_Subtype_Renaming_Discrims then |
2657 | Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters)); | |
70482933 RK |
2658 | |
2659 | elsif Nkind (Type_Definition (N)) = N_Record_Definition then | |
2660 | Build_Discriminant_Assignments (Body_Stmts); | |
2661 | ||
2662 | if not Null_Present (Type_Definition (N)) then | |
2663 | Append_List_To (Body_Stmts, | |
37368818 | 2664 | Build_Init_Statements (Component_List (Type_Definition (N)))); |
70482933 RK |
2665 | end if; |
2666 | ||
df3e68b1 HK |
2667 | -- N is a Derived_Type_Definition with a possible non-empty |
2668 | -- extension. The initialization of a type extension consists in the | |
2669 | -- initialization of the components in the extension. | |
70482933 | 2670 | |
df3e68b1 | 2671 | else |
70482933 RK |
2672 | Build_Discriminant_Assignments (Body_Stmts); |
2673 | ||
2674 | Record_Extension_Node := | |
2675 | Record_Extension_Part (Type_Definition (N)); | |
2676 | ||
2677 | if not Null_Present (Record_Extension_Node) then | |
2678 | declare | |
fbf5a39b AC |
2679 | Stmts : constant List_Id := |
2680 | Build_Init_Statements ( | |
2681 | Component_List (Record_Extension_Node)); | |
70482933 RK |
2682 | |
2683 | begin | |
8d81fb4e AC |
2684 | -- The parent field must be initialized first because the |
2685 | -- offset of the new discriminants may depend on it. This is | |
2686 | -- not needed if the parent is an interface type because in | |
2687 | -- such case the initialization of the _parent field was not | |
2688 | -- generated. | |
2689 | ||
c3831524 AC |
2690 | if not Is_Interface (Etype (Rec_Ent)) then |
2691 | declare | |
2692 | Parent_IP : constant Name_Id := | |
2693 | Make_Init_Proc_Name (Etype (Rec_Ent)); | |
b77029ff SB |
2694 | Stmt : Node_Id := First (Stmts); |
2695 | IP_Call : Node_Id := Empty; | |
c3831524 | 2696 | begin |
b77029ff SB |
2697 | -- Look for a call to the parent IP associated with |
2698 | -- the record extension. | |
2699 | -- The call will be inside not one but two | |
2700 | -- if-statements (with the same condition). Testing | |
2701 | -- the same Early_Init condition twice might seem | |
2702 | -- redundant. However, as soon as we exit this loop, | |
2703 | -- we are going to hoist the inner if-statement out | |
2704 | -- of the outer one; the "redundant" test was built | |
2705 | -- in anticipation of this hoisting. | |
c3831524 AC |
2706 | |
2707 | while Present (Stmt) loop | |
b77029ff SB |
2708 | if Nkind (Stmt) = N_If_Statement then |
2709 | declare | |
2710 | Then_Stmt1 : Node_Id := | |
2711 | First (Then_Statements (Stmt)); | |
2712 | Then_Stmt2 : Node_Id; | |
2713 | begin | |
2714 | while Present (Then_Stmt1) loop | |
2715 | if Nkind (Then_Stmt1) = N_If_Statement then | |
2716 | Then_Stmt2 := | |
2717 | First (Then_Statements (Then_Stmt1)); | |
2718 | ||
2719 | if Nkind (Then_Stmt2) = | |
2720 | N_Procedure_Call_Statement | |
2721 | and then Chars (Name (Then_Stmt2)) = | |
2722 | Parent_IP | |
2723 | then | |
2724 | -- IP_Call is a call wrapped in an | |
2725 | -- if statement. | |
2726 | IP_Call := Then_Stmt1; | |
2727 | exit; | |
2728 | end if; | |
2729 | end if; | |
2730 | Next (Then_Stmt1); | |
2731 | end loop; | |
2732 | end; | |
c3831524 AC |
2733 | end if; |
2734 | ||
2735 | Next (Stmt); | |
2736 | end loop; | |
2737 | ||
2738 | -- If found then move it to the beginning of the | |
2739 | -- statements of this IP routine | |
2740 | ||
2741 | if Present (IP_Call) then | |
b77029ff SB |
2742 | Remove (IP_Call); |
2743 | Prepend_List_To (Body_Stmts, New_List (IP_Call)); | |
c3831524 AC |
2744 | end if; |
2745 | end; | |
8d81fb4e | 2746 | end if; |
70482933 | 2747 | |
70482933 RK |
2748 | Append_List_To (Body_Stmts, Stmts); |
2749 | end; | |
2750 | end if; | |
2751 | end if; | |
2752 | ||
2753 | -- Add here the assignment to instantiate the Tag | |
2754 | ||
47cc8d6b | 2755 | -- The assignment corresponds to the code: |
70482933 RK |
2756 | |
2757 | -- _Init._Tag := Typ'Tag; | |
2758 | ||
535a8637 AC |
2759 | -- Suppress the tag assignment when not Tagged_Type_Expansion because |
2760 | -- tags are represented implicitly in objects. It is also suppressed | |
2761 | -- in case of CPP_Class types because in this case the tag is | |
2762 | -- initialized in the C++ side. | |
70482933 RK |
2763 | |
2764 | if Is_Tagged_Type (Rec_Type) | |
1f110335 | 2765 | and then Tagged_Type_Expansion |
47cc8d6b | 2766 | and then not No_Run_Time_Mode |
70482933 | 2767 | then |
cefce34c JM |
2768 | -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of |
2769 | -- the actual object and invoke the IP of the parent (in this | |
2770 | -- order). The tag must be initialized before the call to the IP | |
2771 | -- of the parent and the assignments to other components because | |
2772 | -- the initial value of the components may depend on the tag (eg. | |
2773 | -- through a dispatching operation on an access to the current | |
2774 | -- type). The tag assignment is not done when initializing the | |
2775 | -- parent component of a type extension, because in that case the | |
2776 | -- tag is set in the extension. | |
70482933 | 2777 | |
cefce34c | 2778 | if not Is_CPP_Class (Root_Type (Rec_Type)) then |
04df6250 | 2779 | |
cefce34c | 2780 | -- Initialize the primary tag component |
04df6250 | 2781 | |
cefce34c | 2782 | Init_Tags_List := New_List ( |
af10c962 EB |
2783 | Make_Tag_Assignment_From_Type |
2784 | (Loc, Make_Identifier (Loc, Name_uInit), Rec_Type)); | |
70482933 | 2785 | |
cefce34c JM |
2786 | -- Ada 2005 (AI-251): Initialize the secondary tags components |
2787 | -- located at fixed positions (tags whose position depends on | |
2788 | -- variable size components are initialized later ---see below) | |
47cc8d6b | 2789 | |
0791fbe9 | 2790 | if Ada_Version >= Ada_2005 |
cefce34c JM |
2791 | and then not Is_Interface (Rec_Type) |
2792 | and then Has_Interfaces (Rec_Type) | |
2793 | then | |
fe683ef6 AC |
2794 | declare |
2795 | Elab_Sec_DT_Stmts_List : constant List_Id := New_List; | |
65e5747e | 2796 | Elab_List : List_Id := New_List; |
70482933 | 2797 | |
fe683ef6 AC |
2798 | begin |
2799 | Init_Secondary_Tags | |
2800 | (Typ => Rec_Type, | |
2801 | Target => Make_Identifier (Loc, Name_uInit), | |
2802 | Init_Tags_List => Init_Tags_List, | |
2803 | Stmts_List => Elab_Sec_DT_Stmts_List, | |
2804 | Fixed_Comps => True, | |
2805 | Variable_Comps => False); | |
2806 | ||
3ec54569 | 2807 | Elab_List := New_List ( |
ed323421 | 2808 | Make_If_Statement (Loc, |
b77029ff SB |
2809 | Condition => |
2810 | Tag_Init_Condition (Loc, Init_Control_Formal), | |
3ec54569 PMR |
2811 | Then_Statements => Init_Tags_List)); |
2812 | ||
2813 | if Elab_Flag_Needed (Rec_Type) then | |
2814 | Append_To (Elab_Sec_DT_Stmts_List, | |
2815 | Make_Assignment_Statement (Loc, | |
2816 | Name => | |
2817 | New_Occurrence_Of | |
2818 | (Access_Disp_Table_Elab_Flag (Rec_Type), | |
2819 | Loc), | |
2820 | Expression => | |
2821 | New_Occurrence_Of (Standard_False, Loc))); | |
2822 | ||
2823 | Append_To (Elab_List, | |
2824 | Make_If_Statement (Loc, | |
2825 | Condition => | |
2826 | New_Occurrence_Of | |
2827 | (Access_Disp_Table_Elab_Flag (Rec_Type), Loc), | |
2828 | Then_Statements => Elab_Sec_DT_Stmts_List)); | |
2829 | end if; | |
fe683ef6 | 2830 | |
3ec54569 | 2831 | Prepend_List_To (Body_Stmts, Elab_List); |
fe683ef6 AC |
2832 | end; |
2833 | else | |
2834 | Prepend_To (Body_Stmts, | |
2835 | Make_If_Statement (Loc, | |
b77029ff SB |
2836 | Condition => |
2837 | Tag_Init_Condition (Loc, Init_Control_Formal), | |
fe683ef6 AC |
2838 | Then_Statements => Init_Tags_List)); |
2839 | end if; | |
758c442c | 2840 | |
cefce34c JM |
2841 | -- Case 2: CPP type. The imported C++ constructor takes care of |
2842 | -- tags initialization. No action needed here because the IP | |
2843 | -- is built by Set_CPP_Constructors; in this case the IP is a | |
2844 | -- wrapper that invokes the C++ constructor and copies the C++ | |
2845 | -- tags locally. Done to inherit the C++ slots in Ada derivations | |
2846 | -- (see case 3). | |
2847 | ||
2848 | elsif Is_CPP_Class (Rec_Type) then | |
2849 | pragma Assert (False); | |
2850 | null; | |
2851 | ||
2852 | -- Case 3: Combined hierarchy containing C++ types and Ada tagged | |
2853 | -- type derivations. Derivations of imported C++ classes add a | |
2854 | -- complication, because we cannot inhibit tag setting in the | |
2855 | -- constructor for the parent. Hence we initialize the tag after | |
2856 | -- the call to the parent IP (that is, in reverse order compared | |
2857 | -- with pure Ada hierarchies ---see comment on case 1). | |
47cc8d6b | 2858 | |
70482933 | 2859 | else |
cefce34c JM |
2860 | -- Initialize the primary tag |
2861 | ||
2862 | Init_Tags_List := New_List ( | |
af10c962 EB |
2863 | Make_Tag_Assignment_From_Type |
2864 | (Loc, Make_Identifier (Loc, Name_uInit), Rec_Type)); | |
cefce34c JM |
2865 | |
2866 | -- Ada 2005 (AI-251): Initialize the secondary tags components | |
2867 | -- located at fixed positions (tags whose position depends on | |
2868 | -- variable size components are initialized later ---see below) | |
2869 | ||
0791fbe9 | 2870 | if Ada_Version >= Ada_2005 |
cefce34c JM |
2871 | and then not Is_Interface (Rec_Type) |
2872 | and then Has_Interfaces (Rec_Type) | |
2873 | then | |
2874 | Init_Secondary_Tags | |
2875 | (Typ => Rec_Type, | |
2876 | Target => Make_Identifier (Loc, Name_uInit), | |
fe683ef6 | 2877 | Init_Tags_List => Init_Tags_List, |
cefce34c JM |
2878 | Stmts_List => Init_Tags_List, |
2879 | Fixed_Comps => True, | |
2880 | Variable_Comps => False); | |
2881 | end if; | |
2882 | ||
2883 | -- Initialize the tag component after invocation of parent IP. | |
2884 | ||
2885 | -- Generate: | |
2886 | -- parent_IP(_init.parent); // Invokes the C++ constructor | |
2887 | -- [ typIC; ] // Inherit C++ slots from parent | |
2888 | -- init_tags | |
2889 | ||
70482933 | 2890 | declare |
cefce34c | 2891 | Ins_Nod : Node_Id; |
70482933 RK |
2892 | |
2893 | begin | |
cefce34c JM |
2894 | -- Search for the call to the IP of the parent. We assume |
2895 | -- that the first init_proc call is for the parent. | |
b77029ff SB |
2896 | -- It is wrapped in an "if Early_Init_Condition" |
2897 | -- if-statement. | |
70482933 | 2898 | |
cefce34c JM |
2899 | Ins_Nod := First (Body_Stmts); |
2900 | while Present (Next (Ins_Nod)) | |
b77029ff SB |
2901 | and then |
2902 | (Nkind (Ins_Nod) /= N_If_Statement | |
8f563162 AC |
2903 | or else Nkind (First (Then_Statements (Ins_Nod))) |
2904 | /= N_Procedure_Call_Statement | |
b77029ff SB |
2905 | or else not Is_Init_Proc |
2906 | (Name (First (Then_Statements | |
2907 | (Ins_Nod))))) | |
70482933 | 2908 | loop |
cefce34c | 2909 | Next (Ins_Nod); |
70482933 RK |
2910 | end loop; |
2911 | ||
cefce34c JM |
2912 | -- The IC routine copies the inherited slots of the C+ part |
2913 | -- of the dispatch table from the parent and updates the | |
2914 | -- overridden C++ slots. | |
ea1941af | 2915 | |
cefce34c JM |
2916 | if CPP_Num_Prims (Rec_Type) > 0 then |
2917 | declare | |
2918 | Init_DT : Entity_Id; | |
2919 | New_Nod : Node_Id; | |
3476f949 | 2920 | |
cefce34c JM |
2921 | begin |
2922 | Init_DT := CPP_Init_Proc (Rec_Type); | |
2923 | pragma Assert (Present (Init_DT)); | |
ea1941af | 2924 | |
cefce34c JM |
2925 | New_Nod := |
2926 | Make_Procedure_Call_Statement (Loc, | |
e4494292 | 2927 | New_Occurrence_Of (Init_DT, Loc)); |
cefce34c | 2928 | Insert_After (Ins_Nod, New_Nod); |
3476f949 | 2929 | |
cefce34c JM |
2930 | -- Update location of init tag statements |
2931 | ||
2932 | Ins_Nod := New_Nod; | |
2933 | end; | |
2934 | end if; | |
2935 | ||
2936 | Insert_List_After (Ins_Nod, Init_Tags_List); | |
70482933 RK |
2937 | end; |
2938 | end if; | |
3476f949 | 2939 | |
04df6250 TQ |
2940 | -- Ada 2005 (AI-251): Initialize the secondary tag components |
2941 | -- located at variable positions. We delay the generation of this | |
2942 | -- code until here because the value of the attribute 'Position | |
2943 | -- applied to variable size components of the parent type that | |
2944 | -- depend on discriminants is only safely read at runtime after | |
2945 | -- the parent components have been initialized. | |
3476f949 | 2946 | |
0791fbe9 | 2947 | if Ada_Version >= Ada_2005 |
3476f949 | 2948 | and then not Is_Interface (Rec_Type) |
ce2b6ba5 | 2949 | and then Has_Interfaces (Rec_Type) |
04df6250 TQ |
2950 | and then Has_Discriminants (Etype (Rec_Type)) |
2951 | and then Is_Variable_Size_Record (Etype (Rec_Type)) | |
3476f949 | 2952 | then |
04df6250 TQ |
2953 | Init_Tags_List := New_List; |
2954 | ||
3476f949 | 2955 | Init_Secondary_Tags |
04df6250 TQ |
2956 | (Typ => Rec_Type, |
2957 | Target => Make_Identifier (Loc, Name_uInit), | |
fe683ef6 | 2958 | Init_Tags_List => Init_Tags_List, |
04df6250 TQ |
2959 | Stmts_List => Init_Tags_List, |
2960 | Fixed_Comps => False, | |
2961 | Variable_Comps => True); | |
2962 | ||
3174b67e | 2963 | Append_List_To (Body_Stmts, Init_Tags_List); |
3476f949 | 2964 | end if; |
70482933 RK |
2965 | end if; |
2966 | ||
2967 | Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc); | |
2968 | Set_Statements (Handled_Stmt_Node, Body_Stmts); | |
df3e68b1 HK |
2969 | |
2970 | -- Generate: | |
ab01e614 | 2971 | -- Deep_Finalize (_init, C1, ..., CN); |
df3e68b1 HK |
2972 | -- raise; |
2973 | ||
2974 | if Counter > 0 | |
2975 | and then Needs_Finalization (Rec_Type) | |
2976 | and then not Is_Abstract_Type (Rec_Type) | |
2977 | and then not Restriction_Active (No_Exception_Propagation) | |
2978 | then | |
2979 | declare | |
967947ed PMR |
2980 | DF_Call : Node_Id; |
2981 | DF_Id : Entity_Id; | |
df3e68b1 HK |
2982 | |
2983 | begin | |
2984 | -- Create a local version of Deep_Finalize which has indication | |
2985 | -- of partial initialization state. | |
2986 | ||
90e491a7 PMR |
2987 | DF_Id := |
2988 | Make_Defining_Identifier (Loc, | |
2989 | Chars => New_External_Name (Name_uFinalizer)); | |
df3e68b1 | 2990 | |
ab01e614 AC |
2991 | Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id)); |
2992 | ||
967947ed PMR |
2993 | DF_Call := |
2994 | Make_Procedure_Call_Statement (Loc, | |
2995 | Name => New_Occurrence_Of (DF_Id, Loc), | |
2996 | Parameter_Associations => New_List ( | |
2997 | Make_Identifier (Loc, Name_uInit), | |
2998 | New_Occurrence_Of (Standard_False, Loc))); | |
2999 | ||
3000 | -- Do not emit warnings related to the elaboration order when a | |
3001 | -- controlled object is declared before the body of Finalize is | |
3002 | -- seen. | |
3003 | ||
3004 | if Legacy_Elaboration_Checks then | |
3005 | Set_No_Elaboration_Check (DF_Call); | |
3006 | end if; | |
3007 | ||
df3e68b1 HK |
3008 | Set_Exception_Handlers (Handled_Stmt_Node, New_List ( |
3009 | Make_Exception_Handler (Loc, | |
3010 | Exception_Choices => New_List ( | |
3011 | Make_Others_Choice (Loc)), | |
ab01e614 | 3012 | Statements => New_List ( |
967947ed | 3013 | DF_Call, |
df3e68b1 HK |
3014 | Make_Raise_Statement (Loc))))); |
3015 | end; | |
3016 | else | |
624e1688 | 3017 | Set_Exception_Handlers (Handled_Stmt_Node, No_List); |
df3e68b1 HK |
3018 | end if; |
3019 | ||
70482933 RK |
3020 | Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); |
3021 | ||
3022 | if not Debug_Generated_Code then | |
3023 | Set_Debug_Info_Off (Proc_Id); | |
3024 | end if; | |
3025 | ||
3026 | -- Associate Init_Proc with type, and determine if the procedure | |
3027 | -- is null (happens because of the Initialize_Scalars pragma case, | |
3028 | -- where we have to generate a null procedure in case it is called | |
3029 | -- by a client with Initialize_Scalars set). Such procedures have | |
3030 | -- to be generated, but do not have to be called, so we mark them | |
c743425f EB |
3031 | -- as null to suppress the call. Kill also warnings for the _Init |
3032 | -- out parameter, which is left entirely uninitialized. | |
70482933 RK |
3033 | |
3034 | Set_Init_Proc (Rec_Type, Proc_Id); | |
3035 | ||
c743425f | 3036 | if Is_Null_Statement_List (Body_Stmts) then |
70482933 | 3037 | Set_Is_Null_Init_Proc (Proc_Id); |
c743425f | 3038 | Set_Warnings_Off (Defining_Identifier (First (Parameters))); |
70482933 RK |
3039 | end if; |
3040 | end Build_Init_Procedure; | |
3041 | ||
3042 | --------------------------- | |
3043 | -- Build_Init_Statements -- | |
3044 | --------------------------- | |
3045 | ||
3046 | function Build_Init_Statements (Comp_List : Node_Id) return List_Id is | |
76e0721a AC |
3047 | Checks : constant List_Id := New_List; |
3048 | Actions : List_Id := No_List; | |
3049 | Counter_Id : Entity_Id := Empty; | |
3050 | Comp_Loc : Source_Ptr; | |
3051 | Decl : Node_Id; | |
76e0721a AC |
3052 | Id : Entity_Id; |
3053 | Parent_Stmts : List_Id; | |
b77029ff SB |
3054 | Parent_Id : Entity_Id := Empty; |
3055 | Stmts, Late_Stmts : List_Id := Empty_List; | |
76e0721a | 3056 | Typ : Entity_Id; |
df3e68b1 | 3057 | |
b77029ff SB |
3058 | procedure Increment_Counter |
3059 | (Loc : Source_Ptr; Late : Boolean := False); | |
df3e68b1 | 3060 | -- Generate an "increment by one" statement for the current counter |
b77029ff | 3061 | -- and append it to the appropriate statement list. |
df3e68b1 | 3062 | |
db4b3c49 | 3063 | procedure Make_Counter (Loc : Source_Ptr); |
df3e68b1 HK |
3064 | -- Create a new counter for the current component list. The routine |
3065 | -- creates a new defining Id, adds an object declaration and sets | |
3066 | -- the Id generator for the next variant. | |
3067 | ||
3068 | ----------------------- | |
3069 | -- Increment_Counter -- | |
3070 | ----------------------- | |
3071 | ||
b77029ff SB |
3072 | procedure Increment_Counter |
3073 | (Loc : Source_Ptr; Late : Boolean := False) is | |
df3e68b1 HK |
3074 | begin |
3075 | -- Generate: | |
3076 | -- Counter := Counter + 1; | |
5d09245e | 3077 | |
b77029ff | 3078 | Append_To ((if Late then Late_Stmts else Stmts), |
df3e68b1 | 3079 | Make_Assignment_Statement (Loc, |
e4494292 | 3080 | Name => New_Occurrence_Of (Counter_Id, Loc), |
df3e68b1 HK |
3081 | Expression => |
3082 | Make_Op_Add (Loc, | |
e4494292 | 3083 | Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), |
243cae0a | 3084 | Right_Opnd => Make_Integer_Literal (Loc, 1)))); |
df3e68b1 HK |
3085 | end Increment_Counter; |
3086 | ||
3087 | ------------------ | |
3088 | -- Make_Counter -- | |
3089 | ------------------ | |
3090 | ||
db4b3c49 | 3091 | procedure Make_Counter (Loc : Source_Ptr) is |
5d09245e | 3092 | begin |
df3e68b1 | 3093 | -- Increment the Id generator |
5d09245e | 3094 | |
df3e68b1 | 3095 | Counter := Counter + 1; |
5d09245e | 3096 | |
df3e68b1 HK |
3097 | -- Create the entity and declaration |
3098 | ||
3099 | Counter_Id := | |
3100 | Make_Defining_Identifier (Loc, | |
3101 | Chars => New_External_Name ('C', Counter)); | |
3102 | ||
3103 | -- Generate: | |
3104 | -- Cnn : Integer := 0; | |
3105 | ||
3106 | Append_To (Decls, | |
3107 | Make_Object_Declaration (Loc, | |
3108 | Defining_Identifier => Counter_Id, | |
243cae0a | 3109 | Object_Definition => |
e4494292 | 3110 | New_Occurrence_Of (Standard_Integer, Loc), |
243cae0a | 3111 | Expression => |
df3e68b1 HK |
3112 | Make_Integer_Literal (Loc, 0))); |
3113 | end Make_Counter; | |
5d09245e AC |
3114 | |
3115 | -- Start of processing for Build_Init_Statements | |
3116 | ||
70482933 RK |
3117 | begin |
3118 | if Null_Present (Comp_List) then | |
3119 | return New_List (Make_Null_Statement (Loc)); | |
3120 | end if; | |
3121 | ||
b9696ffb | 3122 | Parent_Stmts := New_List; |
df3e68b1 | 3123 | Stmts := New_List; |
70482933 | 3124 | |
575a1b32 JM |
3125 | -- Loop through visible declarations of task types and protected |
3126 | -- types moving any expanded code from the spec to the body of the | |
5f143024 | 3127 | -- init procedure. |
575a1b32 | 3128 | |
1bafcab0 | 3129 | if Is_Concurrent_Record_Type (Rec_Type) then |
575a1b32 JM |
3130 | declare |
3131 | Decl : constant Node_Id := | |
3132 | Parent (Corresponding_Concurrent_Type (Rec_Type)); | |
3133 | Def : Node_Id; | |
3134 | N1 : Node_Id; | |
3135 | N2 : Node_Id; | |
3136 | ||
3137 | begin | |
3138 | if Is_Task_Record_Type (Rec_Type) then | |
3139 | Def := Task_Definition (Decl); | |
3140 | else | |
3141 | Def := Protected_Definition (Decl); | |
3142 | end if; | |
3143 | ||
3144 | if Present (Def) then | |
3145 | N1 := First (Visible_Declarations (Def)); | |
3146 | while Present (N1) loop | |
3147 | N2 := N1; | |
3148 | N1 := Next (N1); | |
3149 | ||
3150 | if Nkind (N2) in N_Statement_Other_Than_Procedure_Call | |
3151 | or else Nkind (N2) in N_Raise_xxx_Error | |
3152 | or else Nkind (N2) = N_Procedure_Call_Statement | |
3153 | then | |
df3e68b1 | 3154 | Append_To (Stmts, |
575a1b32 JM |
3155 | New_Copy_Tree (N2, New_Scope => Proc_Id)); |
3156 | Rewrite (N2, Make_Null_Statement (Sloc (N2))); | |
3157 | Analyze (N2); | |
3158 | end if; | |
3159 | end loop; | |
3160 | end if; | |
3161 | end; | |
3162 | end if; | |
3163 | ||
70482933 RK |
3164 | -- Loop through components, skipping pragmas, in 2 steps. The first |
3165 | -- step deals with regular components. The second step deals with | |
76e0721a | 3166 | -- components that require late initialization. |
70482933 | 3167 | |
df3e68b1 | 3168 | -- First pass : regular components |
70482933 RK |
3169 | |
3170 | Decl := First_Non_Pragma (Component_Items (Comp_List)); | |
3171 | while Present (Decl) loop | |
db4b3c49 | 3172 | Comp_Loc := Sloc (Decl); |
a397db96 | 3173 | Build_Record_Checks |
df3e68b1 | 3174 | (Subtype_Indication (Component_Definition (Decl)), Checks); |
70482933 | 3175 | |
db4b3c49 | 3176 | Id := Defining_Identifier (Decl); |
70482933 RK |
3177 | Typ := Etype (Id); |
3178 | ||
76e0721a AC |
3179 | -- Leave any processing of component requiring late initialization |
3180 | -- for the second pass. | |
df3e68b1 | 3181 | |
b77029ff SB |
3182 | if Initialization_Control.Requires_Late_Init (Decl, Rec_Type) then |
3183 | if not Has_Late_Init_Comp then | |
3184 | Late_Stmts := New_List; | |
3185 | end if; | |
76e0721a | 3186 | Has_Late_Init_Comp := True; |
70482933 | 3187 | |
df3e68b1 | 3188 | -- Regular component cases |
fbf5a39b | 3189 | |
70482933 | 3190 | else |
422e02cf AC |
3191 | -- In the context of the init proc, references to discriminants |
3192 | -- resolve to denote the discriminals: this is where we can | |
3193 | -- freeze discriminant dependent component subtypes. | |
3194 | ||
3195 | if not Is_Frozen (Typ) then | |
3196 | Append_List_To (Stmts, Freeze_Entity (Typ, N)); | |
3197 | end if; | |
3198 | ||
df3e68b1 | 3199 | -- Explicit initialization |
fbf5a39b | 3200 | |
70482933 | 3201 | if Present (Expression (Decl)) then |
236fecbf | 3202 | if Is_CPP_Constructor_Call (Expression (Decl)) then |
df3e68b1 | 3203 | Actions := |
236fecbf | 3204 | Build_Initialization_Call |
db4b3c49 | 3205 | (Comp_Loc, |
2be0bff8 | 3206 | Id_Ref => |
db4b3c49 | 3207 | Make_Selected_Component (Comp_Loc, |
2be0bff8 | 3208 | Prefix => |
db4b3c49 AC |
3209 | Make_Identifier (Comp_Loc, Name_uInit), |
3210 | Selector_Name => | |
3211 | New_Occurrence_Of (Id, Comp_Loc)), | |
2be0bff8 TQ |
3212 | Typ => Typ, |
3213 | In_Init_Proc => True, | |
3214 | Enclos_Type => Rec_Type, | |
3215 | Discr_Map => Discr_Map, | |
236fecbf JM |
3216 | Constructor_Ref => Expression (Decl)); |
3217 | else | |
df3e68b1 | 3218 | Actions := Build_Assignment (Id, Expression (Decl)); |
236fecbf | 3219 | end if; |
70482933 | 3220 | |
4bfe4a99 GD |
3221 | -- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size |
3222 | -- components are filled in with the corresponding rep-item | |
3223 | -- expression of the concurrent type (if any). | |
b98e2969 AC |
3224 | |
3225 | elsif Ekind (Scope (Id)) = E_Record_Type | |
3226 | and then Present (Corresponding_Concurrent_Type (Scope (Id))) | |
4a08c95c AC |
3227 | and then Chars (Id) in Name_uCPU |
3228 | | Name_uDispatching_Domain | |
3229 | | Name_uPriority | |
3230 | | Name_uSecondary_Stack_Size | |
b98e2969 AC |
3231 | then |
3232 | declare | |
3233 | Exp : Node_Id; | |
3234 | Nam : Name_Id; | |
66c19cd4 | 3235 | pragma Warnings (Off, Nam); |
b98e2969 AC |
3236 | Ritem : Node_Id; |
3237 | ||
3238 | begin | |
3239 | if Chars (Id) = Name_uCPU then | |
3240 | Nam := Name_CPU; | |
3241 | ||
3242 | elsif Chars (Id) = Name_uDispatching_Domain then | |
3243 | Nam := Name_Dispatching_Domain; | |
3244 | ||
3245 | elsif Chars (Id) = Name_uPriority then | |
3246 | Nam := Name_Priority; | |
eacfa9bc AC |
3247 | |
3248 | elsif Chars (Id) = Name_uSecondary_Stack_Size then | |
3249 | Nam := Name_Secondary_Stack_Size; | |
b98e2969 AC |
3250 | end if; |
3251 | ||
3252 | -- Get the Rep Item (aspect specification, attribute | |
3253 | -- definition clause or pragma) of the corresponding | |
3254 | -- concurrent type. | |
3255 | ||
3256 | Ritem := | |
3257 | Get_Rep_Item | |
8a0320ad AC |
3258 | (Corresponding_Concurrent_Type (Scope (Id)), |
3259 | Nam, | |
3260 | Check_Parents => False); | |
b98e2969 AC |
3261 | |
3262 | if Present (Ritem) then | |
02e4edea | 3263 | |
b98e2969 AC |
3264 | -- Pragma case |
3265 | ||
3266 | if Nkind (Ritem) = N_Pragma then | |
0aa855e5 PT |
3267 | Exp := |
3268 | Get_Pragma_Arg | |
3269 | (First (Pragma_Argument_Associations (Ritem))); | |
b98e2969 AC |
3270 | |
3271 | -- Conversion for Priority expression | |
3272 | ||
3273 | if Nam = Name_Priority then | |
6e759c2a | 3274 | if Pragma_Name (Ritem) = Name_Priority |
b98e2969 AC |
3275 | and then not GNAT_Mode |
3276 | then | |
3277 | Exp := Convert_To (RTE (RE_Priority), Exp); | |
3278 | else | |
3279 | Exp := | |
3280 | Convert_To (RTE (RE_Any_Priority), Exp); | |
3281 | end if; | |
3282 | end if; | |
3283 | ||
3284 | -- Aspect/Attribute definition clause case | |
3285 | ||
3286 | else | |
3287 | Exp := Expression (Ritem); | |
3288 | ||
3289 | -- Conversion for Priority expression | |
3290 | ||
3291 | if Nam = Name_Priority then | |
3292 | if Chars (Ritem) = Name_Priority | |
3293 | and then not GNAT_Mode | |
3294 | then | |
3295 | Exp := Convert_To (RTE (RE_Priority), Exp); | |
3296 | else | |
3297 | Exp := | |
3298 | Convert_To (RTE (RE_Any_Priority), Exp); | |
3299 | end if; | |
3300 | end if; | |
3301 | end if; | |
3302 | ||
3303 | -- Conversion for Dispatching_Domain value | |
3304 | ||
3305 | if Nam = Name_Dispatching_Domain then | |
3306 | Exp := | |
3307 | Unchecked_Convert_To | |
3308 | (RTE (RE_Dispatching_Domain_Access), Exp); | |
be3416c6 AC |
3309 | |
3310 | -- Conversion for Secondary_Stack_Size value | |
3311 | ||
3312 | elsif Nam = Name_Secondary_Stack_Size then | |
3313 | Exp := Convert_To (RTE (RE_Size_Type), Exp); | |
b98e2969 AC |
3314 | end if; |
3315 | ||
3316 | Actions := Build_Assignment (Id, Exp); | |
3317 | ||
3318 | -- Nothing needed if no Rep Item | |
3319 | ||
3320 | else | |
3321 | Actions := No_List; | |
3322 | end if; | |
3323 | end; | |
3324 | ||
df3e68b1 | 3325 | -- Composite component with its own Init_Proc |
fbf5a39b | 3326 | |
4d744221 JM |
3327 | elsif not Is_Interface (Typ) |
3328 | and then Has_Non_Null_Base_Init_Proc (Typ) | |
3329 | then | |
b77029ff SB |
3330 | declare |
3331 | use Initialization_Control; | |
3332 | Init_Control_Actual : Node_Id := Empty; | |
3333 | Is_Parent : constant Boolean := Chars (Id) = Name_uParent; | |
3334 | Init_Call_Stmts : List_Id; | |
3335 | begin | |
3336 | if Is_Parent and then Has_Late_Init_Component (Etype (Id)) | |
3337 | then | |
3338 | Init_Control_Actual := | |
3339 | Make_Mode_Literal (Comp_Loc, Early_Init_Only); | |
3340 | -- Parent_Id used later in second call to parent's | |
3341 | -- init proc to initialize late-init components. | |
3342 | Parent_Id := Id; | |
3343 | end if; | |
3344 | ||
3345 | Init_Call_Stmts := | |
3346 | Build_Initialization_Call | |
3347 | (Comp_Loc, | |
3348 | Make_Selected_Component (Comp_Loc, | |
3349 | Prefix => | |
3350 | Make_Identifier (Comp_Loc, Name_uInit), | |
3351 | Selector_Name => New_Occurrence_Of (Id, Comp_Loc)), | |
3352 | Typ, | |
3353 | In_Init_Proc => True, | |
3354 | Enclos_Type => Rec_Type, | |
3355 | Discr_Map => Discr_Map, | |
3356 | Init_Control_Actual => Init_Control_Actual); | |
3357 | ||
3358 | if Is_Parent then | |
3359 | -- This is tricky. At first it looks like | |
3360 | -- we are going to end up with nested | |
3361 | -- if-statements with the same condition: | |
3362 | -- if Early_Init_Condition then | |
3363 | -- if Early_Init_Condition then | |
3364 | -- Parent_TypeIP (...); | |
3365 | -- end if; | |
3366 | -- end if; | |
3367 | -- But later we will hoist the inner if-statement | |
3368 | -- out of the outer one; we do this because the | |
3369 | -- init-proc call for the _Parent component of a type | |
3370 | -- extension has to precede any other initialization. | |
3371 | Actions := | |
3372 | New_List (Make_If_Statement (Loc, | |
3373 | Condition => | |
3374 | Early_Init_Condition (Loc, Init_Control_Formal), | |
3375 | Then_Statements => Init_Call_Stmts)); | |
3376 | else | |
3377 | Actions := Init_Call_Stmts; | |
3378 | end if; | |
3379 | end; | |
fbf5a39b | 3380 | |
3476f949 JM |
3381 | Clean_Task_Names (Typ, Proc_Id); |
3382 | ||
b23cdc01 BD |
3383 | -- Simple initialization. If the Esize is not yet set, we pass |
3384 | -- Uint_0 as expected by Get_Simple_Init_Val. | |
70482933 RK |
3385 | |
3386 | elsif Component_Needs_Simple_Initialization (Typ) then | |
df3e68b1 | 3387 | Actions := |
82c80734 | 3388 | Build_Assignment |
3b26fe82 HK |
3389 | (Id => Id, |
3390 | Default => | |
3391 | Get_Simple_Init_Val | |
3392 | (Typ => Typ, | |
3393 | N => N, | |
b23cdc01 BD |
3394 | Size => |
3395 | (if Known_Esize (Id) then Esize (Id) | |
3396 | else Uint_0))); | |
70482933 | 3397 | |
fbf5a39b AC |
3398 | -- Nothing needed for this case |
3399 | ||
70482933 | 3400 | else |
df3e68b1 | 3401 | Actions := No_List; |
70482933 RK |
3402 | end if; |
3403 | ||
f7937111 GD |
3404 | -- When the component's type has a Default_Initial_Condition, |
3405 | -- and the component is default initialized, then check the | |
3406 | -- DIC here. | |
3407 | ||
3408 | if Has_DIC (Typ) | |
b77029ff | 3409 | and then No (Expression (Decl)) |
f7937111 GD |
3410 | and then Present (DIC_Procedure (Typ)) |
3411 | and then not Has_Null_Body (DIC_Procedure (Typ)) | |
3412 | ||
3413 | -- The DICs of ancestors are checked as part of the type's | |
3414 | -- DIC procedure. | |
3415 | ||
3416 | and then Chars (Id) /= Name_uParent | |
3417 | ||
3418 | -- In GNATprove mode, the component DICs are checked by other | |
3419 | -- means. They should not be added to the record type DIC | |
3420 | -- procedure, so that the procedure can be used to check the | |
3421 | -- record type invariants or DICs if any. | |
3422 | ||
3423 | and then not GNATprove_Mode | |
3424 | then | |
3425 | Append_New_To (Actions, | |
3426 | Build_DIC_Call | |
3427 | (Comp_Loc, | |
3428 | Make_Selected_Component (Comp_Loc, | |
3429 | Prefix => | |
3430 | Make_Identifier (Comp_Loc, Name_uInit), | |
3431 | Selector_Name => | |
3432 | New_Occurrence_Of (Id, Comp_Loc)), | |
3433 | Typ)); | |
3434 | end if; | |
3435 | ||
df3e68b1 | 3436 | if Present (Checks) then |
b9696ffb AC |
3437 | if Chars (Id) = Name_uParent then |
3438 | Append_List_To (Parent_Stmts, Checks); | |
3439 | else | |
3440 | Append_List_To (Stmts, Checks); | |
3441 | end if; | |
70482933 RK |
3442 | end if; |
3443 | ||
df3e68b1 | 3444 | if Present (Actions) then |
b9696ffb AC |
3445 | if Chars (Id) = Name_uParent then |
3446 | Append_List_To (Parent_Stmts, Actions); | |
b9696ffb AC |
3447 | else |
3448 | Append_List_To (Stmts, Actions); | |
df3e68b1 | 3449 | |
d56f4479 | 3450 | -- Preserve initialization state in the current counter |
df3e68b1 | 3451 | |
b9696ffb AC |
3452 | if Needs_Finalization (Typ) then |
3453 | if No (Counter_Id) then | |
3454 | Make_Counter (Comp_Loc); | |
3455 | end if; | |
df3e68b1 | 3456 | |
b9696ffb AC |
3457 | Increment_Counter (Comp_Loc); |
3458 | end if; | |
70482933 RK |
3459 | end if; |
3460 | end if; | |
3461 | end if; | |
3462 | ||
3463 | Next_Non_Pragma (Decl); | |
3464 | end loop; | |
3465 | ||
b9696ffb AC |
3466 | -- The parent field must be initialized first because variable |
3467 | -- size components of the parent affect the location of all the | |
3468 | -- new components. | |
3469 | ||
3470 | Prepend_List_To (Stmts, Parent_Stmts); | |
3471 | ||
5f3f175d AC |
3472 | -- Set up tasks and protected object support. This needs to be done |
3473 | -- before any component with a per-object access discriminant | |
3474 | -- constraint, or any variant part (which may contain such | |
3475 | -- components) is initialized, because the initialization of these | |
3476 | -- components may reference the enclosing concurrent object. | |
70482933 | 3477 | |
df3e68b1 HK |
3478 | -- For a task record type, add the task create call and calls to bind |
3479 | -- any interrupt (signal) entries. | |
70482933 RK |
3480 | |
3481 | if Is_Task_Record_Type (Rec_Type) then | |
523456db AC |
3482 | |
3483 | -- In the case of the restricted run time the ATCB has already | |
3484 | -- been preallocated. | |
3485 | ||
3486 | if Restricted_Profile then | |
df3e68b1 | 3487 | Append_To (Stmts, |
523456db | 3488 | Make_Assignment_Statement (Loc, |
243cae0a | 3489 | Name => |
df3e68b1 HK |
3490 | Make_Selected_Component (Loc, |
3491 | Prefix => Make_Identifier (Loc, Name_uInit), | |
3492 | Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), | |
3493 | Expression => | |
3494 | Make_Attribute_Reference (Loc, | |
243cae0a | 3495 | Prefix => |
df3e68b1 HK |
3496 | Make_Selected_Component (Loc, |
3497 | Prefix => Make_Identifier (Loc, Name_uInit), | |
3498 | Selector_Name => Make_Identifier (Loc, Name_uATCB)), | |
3499 | Attribute_Name => Name_Unchecked_Access))); | |
523456db AC |
3500 | end if; |
3501 | ||
df3e68b1 | 3502 | Append_To (Stmts, Make_Task_Create_Call (Rec_Type)); |
70482933 RK |
3503 | |
3504 | declare | |
3505 | Task_Type : constant Entity_Id := | |
3506 | Corresponding_Concurrent_Type (Rec_Type); | |
3507 | Task_Decl : constant Node_Id := Parent (Task_Type); | |
3508 | Task_Def : constant Node_Id := Task_Definition (Task_Decl); | |
db4b3c49 | 3509 | Decl_Loc : Source_Ptr; |
70482933 | 3510 | Ent : Entity_Id; |
df3e68b1 | 3511 | Vis_Decl : Node_Id; |
70482933 RK |
3512 | |
3513 | begin | |
3514 | if Present (Task_Def) then | |
3515 | Vis_Decl := First (Visible_Declarations (Task_Def)); | |
3516 | while Present (Vis_Decl) loop | |
db4b3c49 | 3517 | Decl_Loc := Sloc (Vis_Decl); |
70482933 RK |
3518 | |
3519 | if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then | |
3520 | if Get_Attribute_Id (Chars (Vis_Decl)) = | |
3521 | Attribute_Address | |
3522 | then | |
3523 | Ent := Entity (Name (Vis_Decl)); | |
3524 | ||
3525 | if Ekind (Ent) = E_Entry then | |
df3e68b1 | 3526 | Append_To (Stmts, |
db4b3c49 | 3527 | Make_Procedure_Call_Statement (Decl_Loc, |
df3e68b1 | 3528 | Name => |
e4494292 | 3529 | New_Occurrence_Of (RTE ( |
db4b3c49 | 3530 | RE_Bind_Interrupt_To_Entry), Decl_Loc), |
70482933 | 3531 | Parameter_Associations => New_List ( |
db4b3c49 | 3532 | Make_Selected_Component (Decl_Loc, |
7675ad4f | 3533 | Prefix => |
db4b3c49 | 3534 | Make_Identifier (Decl_Loc, Name_uInit), |
70482933 | 3535 | Selector_Name => |
db4b3c49 AC |
3536 | Make_Identifier |
3537 | (Decl_Loc, Name_uTask_Id)), | |
7675ad4f | 3538 | Entry_Index_Expression |
db4b3c49 | 3539 | (Decl_Loc, Ent, Empty, Task_Type), |
70482933 RK |
3540 | Expression (Vis_Decl)))); |
3541 | end if; | |
3542 | end if; | |
3543 | end if; | |
3544 | ||
3545 | Next (Vis_Decl); | |
3546 | end loop; | |
3547 | end if; | |
3548 | end; | |
70482933 RK |
3549 | |
3550 | -- For a protected type, add statements generated by | |
3551 | -- Make_Initialize_Protection. | |
3552 | ||
1bafcab0 | 3553 | elsif Is_Protected_Record_Type (Rec_Type) then |
df3e68b1 | 3554 | Append_List_To (Stmts, |
70482933 RK |
3555 | Make_Initialize_Protection (Rec_Type)); |
3556 | end if; | |
3557 | ||
76e0721a | 3558 | -- Second pass: components that require late initialization |
5f3f175d | 3559 | |
b77029ff SB |
3560 | if Present (Parent_Id) then |
3561 | declare | |
3562 | Parent_Loc : constant Source_Ptr := Sloc (Parent (Parent_Id)); | |
3563 | use Initialization_Control; | |
3564 | begin | |
3565 | -- We are building the init proc for a type extension. | |
3566 | -- Call the parent type's init proc a second time, this | |
3567 | -- time to initialize the parent's components that require | |
3568 | -- late initialization. | |
3569 | ||
3570 | Append_List_To (Late_Stmts, | |
3571 | Build_Initialization_Call | |
3572 | (Loc => Parent_Loc, | |
3573 | Id_Ref => | |
3574 | Make_Selected_Component (Parent_Loc, | |
3575 | Prefix => Make_Identifier | |
3576 | (Parent_Loc, Name_uInit), | |
3577 | Selector_Name => New_Occurrence_Of (Parent_Id, | |
3578 | Parent_Loc)), | |
3579 | Typ => Etype (Parent_Id), | |
3580 | In_Init_Proc => True, | |
3581 | Enclos_Type => Rec_Type, | |
3582 | Discr_Map => Discr_Map, | |
3583 | Init_Control_Actual => Make_Mode_Literal | |
3584 | (Parent_Loc, Late_Init_Only))); | |
3585 | end; | |
3586 | end if; | |
3587 | ||
76e0721a | 3588 | if Has_Late_Init_Comp then |
5f3f175d AC |
3589 | Decl := First_Non_Pragma (Component_Items (Comp_List)); |
3590 | while Present (Decl) loop | |
db4b3c49 | 3591 | Comp_Loc := Sloc (Decl); |
5f3f175d AC |
3592 | Id := Defining_Identifier (Decl); |
3593 | Typ := Etype (Id); | |
3594 | ||
b77029ff SB |
3595 | if Initialization_Control.Requires_Late_Init (Decl, Rec_Type) |
3596 | then | |
76e0721a | 3597 | if Present (Expression (Decl)) then |
b77029ff | 3598 | Append_List_To (Late_Stmts, |
76e0721a AC |
3599 | Build_Assignment (Id, Expression (Decl))); |
3600 | ||
3601 | elsif Has_Non_Null_Base_Init_Proc (Typ) then | |
b77029ff | 3602 | Append_List_To (Late_Stmts, |
db4b3c49 AC |
3603 | Build_Initialization_Call (Comp_Loc, |
3604 | Make_Selected_Component (Comp_Loc, | |
3605 | Prefix => | |
3606 | Make_Identifier (Comp_Loc, Name_uInit), | |
3607 | Selector_Name => New_Occurrence_Of (Id, Comp_Loc)), | |
5f3f175d AC |
3608 | Typ, |
3609 | In_Init_Proc => True, | |
3610 | Enclos_Type => Rec_Type, | |
3611 | Discr_Map => Discr_Map)); | |
3612 | ||
3613 | Clean_Task_Names (Typ, Proc_Id); | |
3614 | ||
465b6532 | 3615 | -- Preserve initialization state in the current counter |
df3e68b1 HK |
3616 | |
3617 | if Needs_Finalization (Typ) then | |
3618 | if No (Counter_Id) then | |
db4b3c49 | 3619 | Make_Counter (Comp_Loc); |
df3e68b1 HK |
3620 | end if; |
3621 | ||
b77029ff | 3622 | Increment_Counter (Comp_Loc, Late => True); |
df3e68b1 | 3623 | end if; |
5f3f175d | 3624 | elsif Component_Needs_Simple_Initialization (Typ) then |
b77029ff | 3625 | Append_List_To (Late_Stmts, |
5f3f175d | 3626 | Build_Assignment |
3b26fe82 HK |
3627 | (Id => Id, |
3628 | Default => | |
3629 | Get_Simple_Init_Val | |
3630 | (Typ => Typ, | |
3631 | N => N, | |
3632 | Size => Esize (Id)))); | |
5f3f175d AC |
3633 | end if; |
3634 | end if; | |
3635 | ||
3636 | Next_Non_Pragma (Decl); | |
3637 | end loop; | |
3638 | end if; | |
3639 | ||
b77029ff SB |
3640 | -- Process the variant part (incorrectly ignoring late |
3641 | -- initialization requirements for components therein). | |
5f3f175d AC |
3642 | |
3643 | if Present (Variant_Part (Comp_List)) then | |
df3e68b1 HK |
3644 | declare |
3645 | Variant_Alts : constant List_Id := New_List; | |
a6d25cad | 3646 | Var_Loc : Source_Ptr := No_Location; |
df3e68b1 | 3647 | Variant : Node_Id; |
5f3f175d | 3648 | |
df3e68b1 HK |
3649 | begin |
3650 | Variant := | |
3651 | First_Non_Pragma (Variants (Variant_Part (Comp_List))); | |
3652 | while Present (Variant) loop | |
db4b3c49 | 3653 | Var_Loc := Sloc (Variant); |
df3e68b1 | 3654 | Append_To (Variant_Alts, |
db4b3c49 | 3655 | Make_Case_Statement_Alternative (Var_Loc, |
df3e68b1 HK |
3656 | Discrete_Choices => |
3657 | New_Copy_List (Discrete_Choices (Variant)), | |
3658 | Statements => | |
3659 | Build_Init_Statements (Component_List (Variant)))); | |
3660 | Next_Non_Pragma (Variant); | |
3661 | end loop; | |
5f3f175d | 3662 | |
df3e68b1 HK |
3663 | -- The expression of the case statement which is a reference |
3664 | -- to one of the discriminants is replaced by the appropriate | |
3665 | -- formal parameter of the initialization procedure. | |
3666 | ||
3667 | Append_To (Stmts, | |
db4b3c49 | 3668 | Make_Case_Statement (Var_Loc, |
df3e68b1 | 3669 | Expression => |
e4494292 | 3670 | New_Occurrence_Of (Discriminal ( |
db4b3c49 | 3671 | Entity (Name (Variant_Part (Comp_List)))), Var_Loc), |
df3e68b1 HK |
3672 | Alternatives => Variant_Alts)); |
3673 | end; | |
5f3f175d AC |
3674 | end if; |
3675 | ||
b77029ff SB |
3676 | if No (Init_Control_Formal) then |
3677 | Append_List_To (Stmts, Late_Stmts); | |
70482933 | 3678 | |
b77029ff SB |
3679 | -- If no initializations were generated for component declarations |
3680 | -- and included in Stmts, then append a null statement to Stmts | |
3681 | -- to make it a valid Ada tree. | |
70482933 | 3682 | |
b77029ff SB |
3683 | if Is_Empty_List (Stmts) then |
3684 | Append (Make_Null_Statement (Loc), Stmts); | |
3685 | end if; | |
fbf5a39b | 3686 | |
b77029ff SB |
3687 | return Stmts; |
3688 | else | |
3689 | declare | |
3690 | use Initialization_Control; | |
3691 | ||
3692 | If_Early : constant Node_Id := | |
3693 | (if Is_Empty_List (Stmts) then | |
3694 | Make_Null_Statement (Loc) | |
3695 | else | |
3696 | Make_If_Statement (Loc, | |
3697 | Condition => | |
3698 | Early_Init_Condition (Loc, Init_Control_Formal), | |
3699 | Then_Statements => Stmts)); | |
3700 | If_Late : constant Node_Id := | |
3701 | (if Is_Empty_List (Late_Stmts) then | |
3702 | Make_Null_Statement (Loc) | |
3703 | else | |
3704 | Make_If_Statement (Loc, | |
3705 | Condition => | |
3706 | Late_Init_Condition (Loc, Init_Control_Formal), | |
3707 | Then_Statements => Late_Stmts)); | |
3708 | begin | |
3709 | return New_List (If_Early, If_Late); | |
3710 | end; | |
3711 | end if; | |
fbf5a39b AC |
3712 | exception |
3713 | when RE_Not_Available => | |
09d67391 | 3714 | return Empty_List; |
70482933 RK |
3715 | end Build_Init_Statements; |
3716 | ||
3717 | ------------------------- | |
3718 | -- Build_Record_Checks -- | |
3719 | ------------------------- | |
3720 | ||
07fc65c4 | 3721 | procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is |
70482933 | 3722 | Subtype_Mark_Id : Entity_Id; |
70482933 | 3723 | |
df3e68b1 HK |
3724 | procedure Constrain_Array |
3725 | (SI : Node_Id; | |
3726 | Check_List : List_Id); | |
3727 | -- Apply a list of index constraints to an unconstrained array type. | |
3728 | -- The first parameter is the entity for the resulting subtype. | |
3729 | -- Check_List is a list to which the check actions are appended. | |
3730 | ||
3731 | --------------------- | |
3732 | -- Constrain_Array -- | |
3733 | --------------------- | |
3734 | ||
3735 | procedure Constrain_Array | |
3736 | (SI : Node_Id; | |
3737 | Check_List : List_Id) | |
3738 | is | |
3739 | C : constant Node_Id := Constraint (SI); | |
3740 | Number_Of_Constraints : Nat := 0; | |
3741 | Index : Node_Id; | |
3742 | S, T : Entity_Id; | |
3743 | ||
3744 | procedure Constrain_Index | |
3745 | (Index : Node_Id; | |
3746 | S : Node_Id; | |
3747 | Check_List : List_Id); | |
3748 | -- Process an index constraint in a constrained array declaration. | |
3749 | -- The constraint can be either a subtype name or a range with or | |
3750 | -- without an explicit subtype mark. Index is the corresponding | |
3751 | -- index of the unconstrained array. S is the range expression. | |
3752 | -- Check_List is a list to which the check actions are appended. | |
3753 | ||
3754 | --------------------- | |
3755 | -- Constrain_Index -- | |
3756 | --------------------- | |
3757 | ||
3758 | procedure Constrain_Index | |
3759 | (Index : Node_Id; | |
3760 | S : Node_Id; | |
3761 | Check_List : List_Id) | |
3762 | is | |
3763 | T : constant Entity_Id := Etype (Index); | |
3764 | ||
3765 | begin | |
3766 | if Nkind (S) = N_Range then | |
41a58113 | 3767 | Process_Range_Expr_In_Decl (S, T, Check_List => Check_List); |
df3e68b1 HK |
3768 | end if; |
3769 | end Constrain_Index; | |
3770 | ||
3771 | -- Start of processing for Constrain_Array | |
3772 | ||
3773 | begin | |
3774 | T := Entity (Subtype_Mark (SI)); | |
3775 | ||
3f1bc2cf | 3776 | if Is_Access_Type (T) then |
df3e68b1 HK |
3777 | T := Designated_Type (T); |
3778 | end if; | |
3779 | ||
3780 | S := First (Constraints (C)); | |
df3e68b1 HK |
3781 | while Present (S) loop |
3782 | Number_Of_Constraints := Number_Of_Constraints + 1; | |
3783 | Next (S); | |
3784 | end loop; | |
3785 | ||
3786 | -- In either case, the index constraint must provide a discrete | |
3787 | -- range for each index of the array type and the type of each | |
3788 | -- discrete range must be the same as that of the corresponding | |
3789 | -- index. (RM 3.6.1) | |
3790 | ||
3791 | S := First (Constraints (C)); | |
3792 | Index := First_Index (T); | |
3793 | Analyze (Index); | |
3794 | ||
3795 | -- Apply constraints to each index type | |
3796 | ||
3797 | for J in 1 .. Number_Of_Constraints loop | |
3798 | Constrain_Index (Index, S, Check_List); | |
3799 | Next (Index); | |
3800 | Next (S); | |
3801 | end loop; | |
3802 | end Constrain_Array; | |
3803 | ||
3804 | -- Start of processing for Build_Record_Checks | |
3805 | ||
07fc65c4 | 3806 | begin |
70482933 RK |
3807 | if Nkind (S) = N_Subtype_Indication then |
3808 | Find_Type (Subtype_Mark (S)); | |
70482933 RK |
3809 | Subtype_Mark_Id := Entity (Subtype_Mark (S)); |
3810 | ||
3811 | -- Remaining processing depends on type | |
3812 | ||
3813 | case Ekind (Subtype_Mark_Id) is | |
70482933 | 3814 | when Array_Kind => |
07fc65c4 | 3815 | Constrain_Array (S, Check_List); |
70482933 RK |
3816 | |
3817 | when others => | |
3818 | null; | |
3819 | end case; | |
3820 | end if; | |
70482933 RK |
3821 | end Build_Record_Checks; |
3822 | ||
3823 | ------------------------------------------- | |
3824 | -- Component_Needs_Simple_Initialization -- | |
3825 | ------------------------------------------- | |
3826 | ||
3827 | function Component_Needs_Simple_Initialization | |
2e071734 | 3828 | (T : Entity_Id) return Boolean |
70482933 RK |
3829 | is |
3830 | begin | |
3831 | return | |
3832 | Needs_Simple_Initialization (T) | |
3833 | and then not Is_RTE (T, RE_Tag) | |
a05e99a2 | 3834 | |
d8f43ee6 | 3835 | -- Ada 2005 (AI-251): Check also the tag of abstract interfaces |
a05e99a2 JM |
3836 | |
3837 | and then not Is_RTE (T, RE_Interface_Tag); | |
70482933 RK |
3838 | end Component_Needs_Simple_Initialization; |
3839 | ||
70482933 RK |
3840 | -------------------------------------- |
3841 | -- Parent_Subtype_Renaming_Discrims -- | |
3842 | -------------------------------------- | |
3843 | ||
3844 | function Parent_Subtype_Renaming_Discrims return Boolean is | |
3845 | De : Entity_Id; | |
3846 | Dp : Entity_Id; | |
3847 | ||
3848 | begin | |
df3e68b1 | 3849 | if Base_Type (Rec_Ent) /= Rec_Ent then |
70482933 RK |
3850 | return False; |
3851 | end if; | |
3852 | ||
df3e68b1 HK |
3853 | if Etype (Rec_Ent) = Rec_Ent |
3854 | or else not Has_Discriminants (Rec_Ent) | |
3855 | or else Is_Constrained (Rec_Ent) | |
3856 | or else Is_Tagged_Type (Rec_Ent) | |
70482933 RK |
3857 | then |
3858 | return False; | |
3859 | end if; | |
3860 | ||
fbf5a39b | 3861 | -- If there are no explicit stored discriminants we have inherited |
70482933 RK |
3862 | -- the root type discriminants so far, so no renamings occurred. |
3863 | ||
df3e68b1 HK |
3864 | if First_Discriminant (Rec_Ent) = |
3865 | First_Stored_Discriminant (Rec_Ent) | |
3866 | then | |
70482933 RK |
3867 | return False; |
3868 | end if; | |
3869 | ||
3870 | -- Check if we have done some trivial renaming of the parent | |
47cc8d6b | 3871 | -- discriminants, i.e. something like |
70482933 | 3872 | -- |
df3e68b1 | 3873 | -- type DT (X1, X2: int) is new PT (X1, X2); |
70482933 | 3874 | |
df3e68b1 HK |
3875 | De := First_Discriminant (Rec_Ent); |
3876 | Dp := First_Discriminant (Etype (Rec_Ent)); | |
70482933 RK |
3877 | while Present (De) loop |
3878 | pragma Assert (Present (Dp)); | |
3879 | ||
3880 | if Corresponding_Discriminant (De) /= Dp then | |
3881 | return True; | |
3882 | end if; | |
3883 | ||
3884 | Next_Discriminant (De); | |
3885 | Next_Discriminant (Dp); | |
3886 | end loop; | |
3887 | ||
3888 | return Present (Dp); | |
3889 | end Parent_Subtype_Renaming_Discrims; | |
3890 | ||
3891 | ------------------------ | |
3892 | -- Requires_Init_Proc -- | |
3893 | ------------------------ | |
3894 | ||
3895 | function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is | |
3896 | Comp_Decl : Node_Id; | |
3897 | Id : Entity_Id; | |
3898 | Typ : Entity_Id; | |
3899 | ||
3900 | begin | |
3901 | -- Definitely do not need one if specifically suppressed | |
3902 | ||
5b1e6aca | 3903 | if Initialization_Suppressed (Rec_Id) then |
70482933 RK |
3904 | return False; |
3905 | end if; | |
3906 | ||
f4d379b8 HK |
3907 | -- If it is a type derived from a type with unknown discriminants, |
3908 | -- we cannot build an initialization procedure for it. | |
3909 | ||
39f346aa ES |
3910 | if Has_Unknown_Discriminants (Rec_Id) |
3911 | or else Has_Unknown_Discriminants (Etype (Rec_Id)) | |
3912 | then | |
f4d379b8 HK |
3913 | return False; |
3914 | end if; | |
3915 | ||
70482933 RK |
3916 | -- Otherwise we need to generate an initialization procedure if |
3917 | -- Is_CPP_Class is False and at least one of the following applies: | |
3918 | ||
3919 | -- 1. Discriminants are present, since they need to be initialized | |
3920 | -- with the appropriate discriminant constraint expressions. | |
3921 | -- However, the discriminant of an unchecked union does not | |
3922 | -- count, since the discriminant is not present. | |
3923 | ||
3924 | -- 2. The type is a tagged type, since the implicit Tag component | |
3925 | -- needs to be initialized with a pointer to the dispatch table. | |
3926 | ||
3927 | -- 3. The type contains tasks | |
3928 | ||
3929 | -- 4. One or more components has an initial value | |
3930 | ||
3931 | -- 5. One or more components is for a type which itself requires | |
3932 | -- an initialization procedure. | |
3933 | ||
3934 | -- 6. One or more components is a type that requires simple | |
3935 | -- initialization (see Needs_Simple_Initialization), except | |
758c442c | 3936 | -- that types Tag and Interface_Tag are excluded, since fields |
70482933 RK |
3937 | -- of these types are initialized by other means. |
3938 | ||
3939 | -- 7. The type is the record type built for a task type (since at | |
3940 | -- the very least, Create_Task must be called) | |
3941 | ||
3942 | -- 8. The type is the record type built for a protected type (since | |
3943 | -- at least Initialize_Protection must be called) | |
3944 | ||
3945 | -- 9. The type is marked as a public entity. The reason we add this | |
3946 | -- case (even if none of the above apply) is to properly handle | |
3947 | -- Initialize_Scalars. If a package is compiled without an IS | |
3948 | -- pragma, and the client is compiled with an IS pragma, then | |
3949 | -- the client will think an initialization procedure is present | |
3950 | -- and call it, when in fact no such procedure is required, but | |
3951 | -- since the call is generated, there had better be a routine | |
a90bd866 | 3952 | -- at the other end of the call, even if it does nothing). |
70482933 | 3953 | |
a05e99a2 | 3954 | -- Note: the reason we exclude the CPP_Class case is because in this |
cefce34c JM |
3955 | -- case the initialization is performed by the C++ constructors, and |
3956 | -- the IP is built by Set_CPP_Constructors. | |
70482933 RK |
3957 | |
3958 | if Is_CPP_Class (Rec_Id) then | |
3959 | return False; | |
3960 | ||
47cc8d6b ES |
3961 | elsif Is_Interface (Rec_Id) then |
3962 | return False; | |
3963 | ||
70482933 | 3964 | elsif (Has_Discriminants (Rec_Id) |
ee4eee0a | 3965 | and then not Is_Unchecked_Union (Rec_Id)) |
70482933 RK |
3966 | or else Is_Tagged_Type (Rec_Id) |
3967 | or else Is_Concurrent_Record_Type (Rec_Id) | |
3968 | or else Has_Task (Rec_Id) | |
3969 | then | |
3970 | return True; | |
3971 | end if; | |
3972 | ||
3973 | Id := First_Component (Rec_Id); | |
70482933 RK |
3974 | while Present (Id) loop |
3975 | Comp_Decl := Parent (Id); | |
3976 | Typ := Etype (Id); | |
3977 | ||
3978 | if Present (Expression (Comp_Decl)) | |
3979 | or else Has_Non_Null_Base_Init_Proc (Typ) | |
3980 | or else Component_Needs_Simple_Initialization (Typ) | |
3981 | then | |
3982 | return True; | |
3983 | end if; | |
3984 | ||
3985 | Next_Component (Id); | |
3986 | end loop; | |
3987 | ||
26a29f01 GD |
3988 | -- As explained above, a record initialization procedure is needed |
3989 | -- for public types in case Initialize_Scalars applies to a client. | |
3990 | -- However, such a procedure is not needed in the case where either | |
3991 | -- of restrictions No_Initialize_Scalars or No_Default_Initialization | |
5f143024 | 3992 | -- applies. No_Initialize_Scalars excludes the possibility of using |
26a29f01 GD |
3993 | -- Initialize_Scalars in any partition, and No_Default_Initialization |
3994 | -- implies that no initialization should ever be done for objects of | |
3995 | -- the type, so is incompatible with Initialize_Scalars. | |
3996 | ||
3997 | if not Restriction_Active (No_Initialize_Scalars) | |
3998 | and then not Restriction_Active (No_Default_Initialization) | |
3999 | and then Is_Public (Rec_Id) | |
4000 | then | |
4001 | return True; | |
4002 | end if; | |
4003 | ||
70482933 RK |
4004 | return False; |
4005 | end Requires_Init_Proc; | |
4006 | ||
4007 | -- Start of processing for Build_Record_Init_Proc | |
4008 | ||
4009 | begin | |
4010 | Rec_Type := Defining_Identifier (N); | |
4011 | ||
4012 | -- This may be full declaration of a private type, in which case | |
4013 | -- the visible entity is a record, and the private entity has been | |
4014 | -- exchanged with it in the private part of the current package. | |
4015 | -- The initialization procedure is built for the record type, which | |
4016 | -- is retrievable from the private entity. | |
4017 | ||
4018 | if Is_Incomplete_Or_Private_Type (Rec_Type) then | |
4019 | Rec_Type := Underlying_Type (Rec_Type); | |
4020 | end if; | |
4021 | ||
dda38714 AC |
4022 | -- If we have a variant record with restriction No_Implicit_Conditionals |
4023 | -- in effect, then we skip building the procedure. This is safe because | |
4024 | -- if we can see the restriction, so can any caller, calls to initialize | |
4025 | -- such records are not allowed for variant records if this restriction | |
4026 | -- is active. | |
4027 | ||
4028 | if Has_Variant_Part (Rec_Type) | |
4029 | and then Restriction_Active (No_Implicit_Conditionals) | |
4030 | then | |
4031 | return; | |
4032 | end if; | |
4033 | ||
70482933 RK |
4034 | -- If there are discriminants, build the discriminant map to replace |
4035 | -- discriminants by their discriminals in complex bound expressions. | |
a5ad3248 | 4036 | -- These only arise for the corresponding records of synchronized types. |
70482933 RK |
4037 | |
4038 | if Is_Concurrent_Record_Type (Rec_Type) | |
4039 | and then Has_Discriminants (Rec_Type) | |
4040 | then | |
4041 | declare | |
4042 | Disc : Entity_Id; | |
70482933 RK |
4043 | begin |
4044 | Disc := First_Discriminant (Rec_Type); | |
70482933 RK |
4045 | while Present (Disc) loop |
4046 | Append_Elmt (Disc, Discr_Map); | |
4047 | Append_Elmt (Discriminal (Disc), Discr_Map); | |
4048 | Next_Discriminant (Disc); | |
4049 | end loop; | |
4050 | end; | |
4051 | end if; | |
4052 | ||
4053 | -- Derived types that have no type extension can use the initialization | |
4054 | -- procedure of their parent and do not need a procedure of their own. | |
4055 | -- This is only correct if there are no representation clauses for the | |
4056 | -- type or its parent, and if the parent has in fact been frozen so | |
4057 | -- that its initialization procedure exists. | |
4058 | ||
4059 | if Is_Derived_Type (Rec_Type) | |
4060 | and then not Is_Tagged_Type (Rec_Type) | |
5d09245e | 4061 | and then not Is_Unchecked_Union (Rec_Type) |
70482933 RK |
4062 | and then not Has_New_Non_Standard_Rep (Rec_Type) |
4063 | and then not Parent_Subtype_Renaming_Discrims | |
9f8483ca | 4064 | and then Present (Base_Init_Proc (Etype (Rec_Type))) |
70482933 RK |
4065 | then |
4066 | Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type); | |
4067 | ||
4068 | -- Otherwise if we need an initialization procedure, then build one, | |
4069 | -- mark it as public and inlinable and as having a completion. | |
4070 | ||
5d09245e AC |
4071 | elsif Requires_Init_Proc (Rec_Type) |
4072 | or else Is_Unchecked_Union (Rec_Type) | |
4073 | then | |
f2cbd970 JM |
4074 | Proc_Id := |
4075 | Make_Defining_Identifier (Loc, | |
4076 | Chars => Make_Init_Proc_Name (Rec_Type)); | |
4077 | ||
4078 | -- If No_Default_Initialization restriction is active, then we don't | |
4079 | -- want to build an init_proc, but we need to mark that an init_proc | |
4080 | -- would be needed if this restriction was not active (so that we can | |
4081 | -- detect attempts to call it), so set a dummy init_proc in place. | |
4082 | ||
4083 | if Restriction_Active (No_Default_Initialization) then | |
4084 | Set_Init_Proc (Rec_Type, Proc_Id); | |
4085 | return; | |
4086 | end if; | |
4087 | ||
a05e99a2 | 4088 | Build_Offset_To_Top_Functions; |
cefce34c | 4089 | Build_CPP_Init_Procedure; |
70482933 | 4090 | Build_Init_Procedure; |
70482933 | 4091 | |
0d66b596 | 4092 | Set_Is_Public (Proc_Id, Is_Public (Rec_Ent)); |
70482933 RK |
4093 | Set_Is_Internal (Proc_Id); |
4094 | Set_Has_Completion (Proc_Id); | |
4095 | ||
4096 | if not Debug_Generated_Code then | |
4097 | Set_Debug_Info_Off (Proc_Id); | |
4098 | end if; | |
47cc8d6b | 4099 | |
0d66b596 AC |
4100 | Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Rec_Type)); |
4101 | ||
078b1a5f AC |
4102 | -- Do not build an aggregate if Modify_Tree_For_C, this isn't |
4103 | -- needed and may generate early references to non frozen types | |
4104 | -- since we expand aggregate much more systematically. | |
4105 | ||
4106 | if Modify_Tree_For_C then | |
4107 | return; | |
4108 | end if; | |
4109 | ||
55d4e6c0 ES |
4110 | declare |
4111 | Agg : constant Node_Id := | |
4112 | Build_Equivalent_Record_Aggregate (Rec_Type); | |
4113 | ||
4114 | procedure Collect_Itypes (Comp : Node_Id); | |
4115 | -- Generate references to itypes in the aggregate, because | |
4116 | -- the first use of the aggregate may be in a nested scope. | |
4117 | ||
4118 | -------------------- | |
4119 | -- Collect_Itypes -- | |
4120 | -------------------- | |
4121 | ||
4122 | procedure Collect_Itypes (Comp : Node_Id) is | |
4123 | Ref : Node_Id; | |
4124 | Sub_Aggr : Node_Id; | |
f2cbd970 | 4125 | Typ : constant Entity_Id := Etype (Comp); |
55d4e6c0 ES |
4126 | |
4127 | begin | |
ee4eee0a | 4128 | if Is_Array_Type (Typ) and then Is_Itype (Typ) then |
55d4e6c0 ES |
4129 | Ref := Make_Itype_Reference (Loc); |
4130 | Set_Itype (Ref, Typ); | |
4131 | Append_Freeze_Action (Rec_Type, Ref); | |
4132 | ||
4133 | Ref := Make_Itype_Reference (Loc); | |
4134 | Set_Itype (Ref, Etype (First_Index (Typ))); | |
4135 | Append_Freeze_Action (Rec_Type, Ref); | |
4136 | ||
55d4e6c0 ES |
4137 | -- Recurse on nested arrays |
4138 | ||
46413d9e | 4139 | Sub_Aggr := First (Expressions (Comp)); |
55d4e6c0 ES |
4140 | while Present (Sub_Aggr) loop |
4141 | Collect_Itypes (Sub_Aggr); | |
4142 | Next (Sub_Aggr); | |
4143 | end loop; | |
4144 | end if; | |
4145 | end Collect_Itypes; | |
4146 | ||
4147 | begin | |
4148 | -- If there is a static initialization aggregate for the type, | |
4149 | -- generate itype references for the types of its (sub)components, | |
4150 | -- to prevent out-of-scope errors in the resulting tree. | |
4151 | -- The aggregate may have been rewritten as a Raise node, in which | |
4152 | -- case there are no relevant itypes. | |
4153 | ||
ee4eee0a | 4154 | if Present (Agg) and then Nkind (Agg) = N_Aggregate then |
55d4e6c0 ES |
4155 | Set_Static_Initialization (Proc_Id, Agg); |
4156 | ||
4157 | declare | |
fb8e3581 | 4158 | Comp : Node_Id; |
55d4e6c0 ES |
4159 | begin |
4160 | Comp := First (Component_Associations (Agg)); | |
4161 | while Present (Comp) loop | |
4162 | Collect_Itypes (Expression (Comp)); | |
4163 | Next (Comp); | |
4164 | end loop; | |
4165 | end; | |
4166 | end if; | |
4167 | end; | |
70482933 RK |
4168 | end if; |
4169 | end Build_Record_Init_Proc; | |
4170 | ||
26fd4eae AC |
4171 | ---------------------------- |
4172 | -- Build_Slice_Assignment -- | |
4173 | ---------------------------- | |
4174 | ||
4175 | -- Generates the following subprogram: | |
6e937c1c | 4176 | |
fff7a6d9 | 4177 | -- procedure array_typeSA |
47cc8d6b ES |
4178 | -- (Source, Target : Array_Type, |
4179 | -- Left_Lo, Left_Hi : Index; | |
4180 | -- Right_Lo, Right_Hi : Index; | |
4181 | -- Rev : Boolean) | |
26fd4eae AC |
4182 | -- is |
4183 | -- Li1 : Index; | |
4184 | -- Ri1 : Index; | |
6e937c1c | 4185 | |
26fd4eae | 4186 | -- begin |
f2cbd970 JM |
4187 | -- if Left_Hi < Left_Lo then |
4188 | -- return; | |
4189 | -- end if; | |
4190 | ||
bcb0389e | 4191 | -- if Rev then |
26fd4eae AC |
4192 | -- Li1 := Left_Hi; |
4193 | -- Ri1 := Right_Hi; | |
4194 | -- else | |
4195 | -- Li1 := Left_Lo; | |
4196 | -- Ri1 := Right_Lo; | |
4197 | -- end if; | |
6e937c1c | 4198 | |
26fd4eae | 4199 | -- loop |
47cc8d6b ES |
4200 | -- Target (Li1) := Source (Ri1); |
4201 | ||
4202 | -- if Rev then | |
f2cbd970 | 4203 | -- exit when Li1 = Left_Lo; |
47cc8d6b ES |
4204 | -- Li1 := Index'pred (Li1); |
4205 | -- Ri1 := Index'pred (Ri1); | |
4206 | -- else | |
f2cbd970 | 4207 | -- exit when Li1 = Left_Hi; |
47cc8d6b ES |
4208 | -- Li1 := Index'succ (Li1); |
4209 | -- Ri1 := Index'succ (Ri1); | |
4210 | -- end if; | |
26fd4eae | 4211 | -- end loop; |
fff7a6d9 | 4212 | -- end array_typeSA; |
26fd4eae AC |
4213 | |
4214 | procedure Build_Slice_Assignment (Typ : Entity_Id) is | |
4215 | Loc : constant Source_Ptr := Sloc (Typ); | |
4216 | Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); | |
4217 | ||
191fcb3a RD |
4218 | Larray : constant Entity_Id := Make_Temporary (Loc, 'A'); |
4219 | Rarray : constant Entity_Id := Make_Temporary (Loc, 'R'); | |
4220 | Left_Lo : constant Entity_Id := Make_Temporary (Loc, 'L'); | |
4221 | Left_Hi : constant Entity_Id := Make_Temporary (Loc, 'L'); | |
4222 | Right_Lo : constant Entity_Id := Make_Temporary (Loc, 'R'); | |
4223 | Right_Hi : constant Entity_Id := Make_Temporary (Loc, 'R'); | |
4224 | Rev : constant Entity_Id := Make_Temporary (Loc, 'D'); | |
4225 | -- Formal parameters of procedure | |
4226 | ||
26fd4eae AC |
4227 | Proc_Name : constant Entity_Id := |
4228 | Make_Defining_Identifier (Loc, | |
4229 | Chars => Make_TSS_Name (Typ, TSS_Slice_Assign)); | |
4230 | ||
191fcb3a RD |
4231 | Lnn : constant Entity_Id := Make_Temporary (Loc, 'L'); |
4232 | Rnn : constant Entity_Id := Make_Temporary (Loc, 'R'); | |
6e937c1c | 4233 | -- Subscripts for left and right sides |
26fd4eae | 4234 | |
6e937c1c AC |
4235 | Decls : List_Id; |
4236 | Loops : Node_Id; | |
4237 | Stats : List_Id; | |
26fd4eae AC |
4238 | |
4239 | begin | |
3b42c566 | 4240 | -- Build declarations for indexes |
26fd4eae AC |
4241 | |
4242 | Decls := New_List; | |
4243 | ||
4244 | Append_To (Decls, | |
4245 | Make_Object_Declaration (Loc, | |
4246 | Defining_Identifier => Lnn, | |
4247 | Object_Definition => | |
4248 | New_Occurrence_Of (Index, Loc))); | |
4249 | ||
4250 | Append_To (Decls, | |
4251 | Make_Object_Declaration (Loc, | |
4252 | Defining_Identifier => Rnn, | |
4253 | Object_Definition => | |
4254 | New_Occurrence_Of (Index, Loc))); | |
4255 | ||
4256 | Stats := New_List; | |
4257 | ||
f2cbd970 JM |
4258 | -- Build test for empty slice case |
4259 | ||
4260 | Append_To (Stats, | |
4261 | Make_If_Statement (Loc, | |
4262 | Condition => | |
4263 | Make_Op_Lt (Loc, | |
4264 | Left_Opnd => New_Occurrence_Of (Left_Hi, Loc), | |
4265 | Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)), | |
4266 | Then_Statements => New_List (Make_Simple_Return_Statement (Loc)))); | |
4267 | ||
3b42c566 | 4268 | -- Build initializations for indexes |
26fd4eae AC |
4269 | |
4270 | declare | |
4271 | F_Init : constant List_Id := New_List; | |
4272 | B_Init : constant List_Id := New_List; | |
4273 | ||
4274 | begin | |
4275 | Append_To (F_Init, | |
4276 | Make_Assignment_Statement (Loc, | |
4277 | Name => New_Occurrence_Of (Lnn, Loc), | |
4278 | Expression => New_Occurrence_Of (Left_Lo, Loc))); | |
4279 | ||
4280 | Append_To (F_Init, | |
4281 | Make_Assignment_Statement (Loc, | |
4282 | Name => New_Occurrence_Of (Rnn, Loc), | |
4283 | Expression => New_Occurrence_Of (Right_Lo, Loc))); | |
4284 | ||
4285 | Append_To (B_Init, | |
4286 | Make_Assignment_Statement (Loc, | |
4287 | Name => New_Occurrence_Of (Lnn, Loc), | |
4288 | Expression => New_Occurrence_Of (Left_Hi, Loc))); | |
4289 | ||
4290 | Append_To (B_Init, | |
4291 | Make_Assignment_Statement (Loc, | |
4292 | Name => New_Occurrence_Of (Rnn, Loc), | |
4293 | Expression => New_Occurrence_Of (Right_Hi, Loc))); | |
4294 | ||
4295 | Append_To (Stats, | |
4296 | Make_If_Statement (Loc, | |
4297 | Condition => New_Occurrence_Of (Rev, Loc), | |
4298 | Then_Statements => B_Init, | |
4299 | Else_Statements => F_Init)); | |
4300 | end; | |
4301 | ||
4302 | -- Now construct the assignment statement | |
4303 | ||
4304 | Loops := | |
4305 | Make_Loop_Statement (Loc, | |
4306 | Statements => New_List ( | |
4307 | Make_Assignment_Statement (Loc, | |
4308 | Name => | |
4309 | Make_Indexed_Component (Loc, | |
4310 | Prefix => New_Occurrence_Of (Larray, Loc), | |
4311 | Expressions => New_List (New_Occurrence_Of (Lnn, Loc))), | |
4312 | Expression => | |
4313 | Make_Indexed_Component (Loc, | |
4314 | Prefix => New_Occurrence_Of (Rarray, Loc), | |
4315 | Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))), | |
4316 | End_Label => Empty); | |
4317 | ||
f2cbd970 | 4318 | -- Build the exit condition and increment/decrement statements |
26fd4eae AC |
4319 | |
4320 | declare | |
4321 | F_Ass : constant List_Id := New_List; | |
4322 | B_Ass : constant List_Id := New_List; | |
4323 | ||
4324 | begin | |
4325 | Append_To (F_Ass, | |
4326 | Make_Exit_Statement (Loc, | |
4327 | Condition => | |
f2cbd970 | 4328 | Make_Op_Eq (Loc, |
26fd4eae AC |
4329 | Left_Opnd => New_Occurrence_Of (Lnn, Loc), |
4330 | Right_Opnd => New_Occurrence_Of (Left_Hi, Loc)))); | |
4331 | ||
26fd4eae AC |
4332 | Append_To (F_Ass, |
4333 | Make_Assignment_Statement (Loc, | |
4334 | Name => New_Occurrence_Of (Lnn, Loc), | |
4335 | Expression => | |
4336 | Make_Attribute_Reference (Loc, | |
4337 | Prefix => | |
4338 | New_Occurrence_Of (Index, Loc), | |
4339 | Attribute_Name => Name_Succ, | |
4340 | Expressions => New_List ( | |
4341 | New_Occurrence_Of (Lnn, Loc))))); | |
4342 | ||
4343 | Append_To (F_Ass, | |
4344 | Make_Assignment_Statement (Loc, | |
4345 | Name => New_Occurrence_Of (Rnn, Loc), | |
4346 | Expression => | |
4347 | Make_Attribute_Reference (Loc, | |
4348 | Prefix => | |
4349 | New_Occurrence_Of (Index, Loc), | |
4350 | Attribute_Name => Name_Succ, | |
4351 | Expressions => New_List ( | |
4352 | New_Occurrence_Of (Rnn, Loc))))); | |
4353 | ||
f2cbd970 JM |
4354 | Append_To (B_Ass, |
4355 | Make_Exit_Statement (Loc, | |
4356 | Condition => | |
4357 | Make_Op_Eq (Loc, | |
4358 | Left_Opnd => New_Occurrence_Of (Lnn, Loc), | |
4359 | Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)))); | |
4360 | ||
26fd4eae AC |
4361 | Append_To (B_Ass, |
4362 | Make_Assignment_Statement (Loc, | |
4363 | Name => New_Occurrence_Of (Lnn, Loc), | |
4364 | Expression => | |
4365 | Make_Attribute_Reference (Loc, | |
4366 | Prefix => | |
4367 | New_Occurrence_Of (Index, Loc), | |
4368 | Attribute_Name => Name_Pred, | |
4369 | Expressions => New_List ( | |
4370 | New_Occurrence_Of (Lnn, Loc))))); | |
4371 | ||
4372 | Append_To (B_Ass, | |
4373 | Make_Assignment_Statement (Loc, | |
4374 | Name => New_Occurrence_Of (Rnn, Loc), | |
4375 | Expression => | |
4376 | Make_Attribute_Reference (Loc, | |
4377 | Prefix => | |
4378 | New_Occurrence_Of (Index, Loc), | |
4379 | Attribute_Name => Name_Pred, | |
4380 | Expressions => New_List ( | |
4381 | New_Occurrence_Of (Rnn, Loc))))); | |
4382 | ||
4383 | Append_To (Statements (Loops), | |
4384 | Make_If_Statement (Loc, | |
4385 | Condition => New_Occurrence_Of (Rev, Loc), | |
4386 | Then_Statements => B_Ass, | |
4387 | Else_Statements => F_Ass)); | |
4388 | end; | |
4389 | ||
4390 | Append_To (Stats, Loops); | |
4391 | ||
4392 | declare | |
6e937c1c | 4393 | Spec : Node_Id; |
6dc7a8ab | 4394 | Formals : List_Id; |
26fd4eae AC |
4395 | |
4396 | begin | |
4397 | Formals := New_List ( | |
4398 | Make_Parameter_Specification (Loc, | |
4399 | Defining_Identifier => Larray, | |
4400 | Out_Present => True, | |
4401 | Parameter_Type => | |
e4494292 | 4402 | New_Occurrence_Of (Base_Type (Typ), Loc)), |
26fd4eae AC |
4403 | |
4404 | Make_Parameter_Specification (Loc, | |
4405 | Defining_Identifier => Rarray, | |
4406 | Parameter_Type => | |
e4494292 | 4407 | New_Occurrence_Of (Base_Type (Typ), Loc)), |
26fd4eae AC |
4408 | |
4409 | Make_Parameter_Specification (Loc, | |
4410 | Defining_Identifier => Left_Lo, | |
4411 | Parameter_Type => | |
e4494292 | 4412 | New_Occurrence_Of (Index, Loc)), |
26fd4eae AC |
4413 | |
4414 | Make_Parameter_Specification (Loc, | |
4415 | Defining_Identifier => Left_Hi, | |
4416 | Parameter_Type => | |
e4494292 | 4417 | New_Occurrence_Of (Index, Loc)), |
26fd4eae AC |
4418 | |
4419 | Make_Parameter_Specification (Loc, | |
4420 | Defining_Identifier => Right_Lo, | |
4421 | Parameter_Type => | |
e4494292 | 4422 | New_Occurrence_Of (Index, Loc)), |
26fd4eae AC |
4423 | |
4424 | Make_Parameter_Specification (Loc, | |
4425 | Defining_Identifier => Right_Hi, | |
4426 | Parameter_Type => | |
e4494292 | 4427 | New_Occurrence_Of (Index, Loc))); |
26fd4eae AC |
4428 | |
4429 | Append_To (Formals, | |
4430 | Make_Parameter_Specification (Loc, | |
4431 | Defining_Identifier => Rev, | |
4432 | Parameter_Type => | |
e4494292 | 4433 | New_Occurrence_Of (Standard_Boolean, Loc))); |
26fd4eae AC |
4434 | |
4435 | Spec := | |
4436 | Make_Procedure_Specification (Loc, | |
4437 | Defining_Unit_Name => Proc_Name, | |
4438 | Parameter_Specifications => Formals); | |
4439 | ||
4440 | Discard_Node ( | |
4441 | Make_Subprogram_Body (Loc, | |
4442 | Specification => Spec, | |
4443 | Declarations => Decls, | |
4444 | Handled_Statement_Sequence => | |
4445 | Make_Handled_Sequence_Of_Statements (Loc, | |
4446 | Statements => Stats))); | |
4447 | end; | |
4448 | ||
4449 | Set_TSS (Typ, Proc_Name); | |
4450 | Set_Is_Pure (Proc_Name); | |
4451 | end Build_Slice_Assignment; | |
4452 | ||
d151d6a3 AC |
4453 | ----------------------------- |
4454 | -- Build_Untagged_Equality -- | |
4455 | ----------------------------- | |
4456 | ||
4457 | procedure Build_Untagged_Equality (Typ : Entity_Id) is | |
4458 | Build_Eq : Boolean; | |
4459 | Comp : Entity_Id; | |
4460 | Decl : Node_Id; | |
4461 | Op : Entity_Id; | |
d151d6a3 AC |
4462 | Eq_Op : Entity_Id; |
4463 | ||
4464 | function User_Defined_Eq (T : Entity_Id) return Entity_Id; | |
7a963087 RD |
4465 | -- Check whether the type T has a user-defined primitive equality. If so |
4466 | -- return it, else return Empty. If true for a component of Typ, we have | |
4467 | -- to build the primitive equality for it. | |
d151d6a3 AC |
4468 | |
4469 | --------------------- | |
4470 | -- User_Defined_Eq -- | |
4471 | --------------------- | |
4472 | ||
4473 | function User_Defined_Eq (T : Entity_Id) return Entity_Id is | |
9a39b25f | 4474 | Op : constant Entity_Id := TSS (T, TSS_Composite_Equality); |
d151d6a3 AC |
4475 | |
4476 | begin | |
d151d6a3 AC |
4477 | if Present (Op) then |
4478 | return Op; | |
9a39b25f | 4479 | else |
909ce352 | 4480 | return Get_User_Defined_Equality (T); |
d151d6a3 | 4481 | end if; |
d151d6a3 AC |
4482 | end User_Defined_Eq; |
4483 | ||
4484 | -- Start of processing for Build_Untagged_Equality | |
4485 | ||
4486 | begin | |
4487 | -- If a record component has a primitive equality operation, we must | |
7a963087 | 4488 | -- build the corresponding one for the current type. |
d151d6a3 AC |
4489 | |
4490 | Build_Eq := False; | |
4491 | Comp := First_Component (Typ); | |
4492 | while Present (Comp) loop | |
4493 | if Is_Record_Type (Etype (Comp)) | |
4494 | and then Present (User_Defined_Eq (Etype (Comp))) | |
4495 | then | |
4496 | Build_Eq := True; | |
90fadb50 | 4497 | exit; |
d151d6a3 AC |
4498 | end if; |
4499 | ||
4500 | Next_Component (Comp); | |
4501 | end loop; | |
4502 | ||
4503 | -- If there is a user-defined equality for the type, we do not create | |
4504 | -- the implicit one. | |
4505 | ||
909ce352 EB |
4506 | Eq_Op := Get_User_Defined_Equality (Typ); |
4507 | if Present (Eq_Op) then | |
4508 | if Comes_From_Source (Eq_Op) then | |
d151d6a3 | 4509 | Build_Eq := False; |
909ce352 EB |
4510 | else |
4511 | Eq_Op := Empty; | |
d151d6a3 | 4512 | end if; |
909ce352 | 4513 | end if; |
d151d6a3 AC |
4514 | |
4515 | -- If the type is derived, inherit the operation, if present, from the | |
7a963087 RD |
4516 | -- parent type. It may have been declared after the type derivation. If |
4517 | -- the parent type itself is derived, it may have inherited an operation | |
4518 | -- that has itself been overridden, so update its alias and related | |
4519 | -- flags. Ditto for inequality. | |
d151d6a3 AC |
4520 | |
4521 | if No (Eq_Op) and then Is_Derived_Type (Typ) then | |
909ce352 EB |
4522 | Eq_Op := Get_User_Defined_Equality (Etype (Typ)); |
4523 | if Present (Eq_Op) then | |
4524 | Copy_TSS (Eq_Op, Typ); | |
4525 | Build_Eq := False; | |
d151d6a3 | 4526 | |
909ce352 EB |
4527 | declare |
4528 | Op : constant Entity_Id := User_Defined_Eq (Typ); | |
4529 | NE_Op : constant Entity_Id := Next_Entity (Eq_Op); | |
d151d6a3 | 4530 | |
909ce352 EB |
4531 | begin |
4532 | if Present (Op) then | |
4533 | Set_Alias (Op, Eq_Op); | |
4534 | Set_Is_Abstract_Subprogram | |
4535 | (Op, Is_Abstract_Subprogram (Eq_Op)); | |
d151d6a3 | 4536 | |
909ce352 EB |
4537 | if Chars (Next_Entity (Op)) = Name_Op_Ne then |
4538 | Set_Is_Abstract_Subprogram | |
4539 | (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op)); | |
d151d6a3 | 4540 | end if; |
909ce352 EB |
4541 | end if; |
4542 | end; | |
4543 | end if; | |
d151d6a3 AC |
4544 | end if; |
4545 | ||
7a963087 | 4546 | -- If not inherited and not user-defined, build body as for a type with |
2702882f BD |
4547 | -- components of record type (i.e. a type for which "=" composes when |
4548 | -- used as a component in an outer composite type). | |
d151d6a3 AC |
4549 | |
4550 | if Build_Eq then | |
4551 | Decl := | |
7a963087 | 4552 | Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality)); |
d151d6a3 AC |
4553 | Op := Defining_Entity (Decl); |
4554 | Set_TSS (Typ, Op); | |
4555 | Set_Is_Pure (Op); | |
4556 | ||
4557 | if Is_Library_Level_Entity (Typ) then | |
4558 | Set_Is_Public (Op); | |
4559 | end if; | |
4560 | end if; | |
4561 | end Build_Untagged_Equality; | |
4562 | ||
45ec05e1 | 4563 | ----------------------------------- |
70482933 | 4564 | -- Build_Variant_Record_Equality -- |
45ec05e1 | 4565 | ----------------------------------- |
70482933 RK |
4566 | |
4567 | -- Generates: | |
6e937c1c | 4568 | |
01243764 JM |
4569 | -- function <<Body_Id>> (Left, Right : T) return Boolean is |
4570 | -- [ X : T renames Left; ] | |
4571 | -- [ Y : T renames Right; ] | |
4572 | -- -- The above renamings are generated only if the parameters of | |
4573 | -- -- this built function (which are passed by the caller) are not | |
4574 | -- -- named 'X' and 'Y'; these names are required to reuse several | |
4575 | -- -- expander routines when generating this body. | |
4576 | ||
70482933 RK |
4577 | -- begin |
4578 | -- -- Compare discriminants | |
4579 | ||
45ec05e1 | 4580 | -- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then |
70482933 RK |
4581 | -- return False; |
4582 | -- end if; | |
4583 | ||
4584 | -- -- Compare components | |
4585 | ||
45ec05e1 | 4586 | -- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then |
70482933 RK |
4587 | -- return False; |
4588 | -- end if; | |
4589 | ||
4590 | -- -- Compare variant part | |
4591 | ||
4592 | -- case X.D1 is | |
4593 | -- when V1 => | |
45ec05e1 | 4594 | -- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then |
70482933 RK |
4595 | -- return False; |
4596 | -- end if; | |
4597 | -- ... | |
4598 | -- when Vn => | |
45ec05e1 | 4599 | -- if X.Cn /= Y.Cn or else ... then |
70482933 RK |
4600 | -- return False; |
4601 | -- end if; | |
4602 | -- end case; | |
47cc8d6b | 4603 | |
70482933 RK |
4604 | -- return True; |
4605 | -- end _Equality; | |
4606 | ||
01243764 JM |
4607 | function Build_Variant_Record_Equality |
4608 | (Typ : Entity_Id; | |
4609 | Body_Id : Entity_Id; | |
4610 | Param_Specs : List_Id) return Node_Id | |
4611 | is | |
9ea43db6 HK |
4612 | Loc : constant Source_Ptr := Sloc (Typ); |
4613 | Def : constant Node_Id := Parent (Typ); | |
4614 | Comps : constant Node_Id := Component_List (Type_Definition (Def)); | |
4615 | Left : constant Entity_Id := Defining_Identifier (First (Param_Specs)); | |
4616 | Right : constant Entity_Id := | |
4617 | Defining_Identifier (Next (First (Param_Specs))); | |
4618 | Decls : constant List_Id := New_List; | |
4619 | Stmts : constant List_Id := New_List; | |
4620 | ||
01243764 | 4621 | Subp_Body : Node_Id; |
70482933 RK |
4622 | |
4623 | begin | |
01243764 JM |
4624 | pragma Assert (not Is_Tagged_Type (Typ)); |
4625 | ||
4626 | -- In order to reuse the expander routines Make_Eq_If and Make_Eq_Case | |
4627 | -- the name of the formals must be X and Y; otherwise we generate two | |
4628 | -- renaming declarations for such purpose. | |
4629 | ||
4630 | if Chars (Left) /= Name_X then | |
4631 | Append_To (Decls, | |
4632 | Make_Object_Renaming_Declaration (Loc, | |
4633 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
4634 | Subtype_Mark => New_Occurrence_Of (Typ, Loc), | |
4635 | Name => Make_Identifier (Loc, Chars (Left)))); | |
dda38714 AC |
4636 | end if; |
4637 | ||
01243764 JM |
4638 | if Chars (Right) /= Name_Y then |
4639 | Append_To (Decls, | |
4640 | Make_Object_Renaming_Declaration (Loc, | |
4641 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), | |
4642 | Subtype_Mark => New_Occurrence_Of (Typ, Loc), | |
4643 | Name => Make_Identifier (Loc, Chars (Right)))); | |
70482933 RK |
4644 | end if; |
4645 | ||
5d09245e AC |
4646 | -- Unchecked_Unions require additional machinery to support equality. |
4647 | -- Two extra parameters (A and B) are added to the equality function | |
fa1608c2 ES |
4648 | -- parameter list for each discriminant of the type, in order to |
4649 | -- capture the inferred values of the discriminants in equality calls. | |
4650 | -- The names of the parameters match the names of the corresponding | |
4651 | -- discriminant, with an added suffix. | |
5d09245e AC |
4652 | |
4653 | if Is_Unchecked_Union (Typ) then | |
4654 | declare | |
9ea43db6 HK |
4655 | A : Entity_Id; |
4656 | B : Entity_Id; | |
fa1608c2 ES |
4657 | Discr : Entity_Id; |
4658 | Discr_Type : Entity_Id; | |
fa1608c2 | 4659 | New_Discrs : Elist_Id; |
5d09245e | 4660 | |
fa1608c2 ES |
4661 | begin |
4662 | New_Discrs := New_Elmt_List; | |
5d09245e | 4663 | |
fa1608c2 ES |
4664 | Discr := First_Discriminant (Typ); |
4665 | while Present (Discr) loop | |
4666 | Discr_Type := Etype (Discr); | |
5d09245e | 4667 | |
9ea43db6 HK |
4668 | A := |
4669 | Make_Defining_Identifier (Loc, | |
4670 | Chars => New_External_Name (Chars (Discr), 'A')); | |
4671 | ||
4672 | B := | |
4673 | Make_Defining_Identifier (Loc, | |
4674 | Chars => New_External_Name (Chars (Discr), 'B')); | |
5d09245e | 4675 | |
fa1608c2 | 4676 | -- Add new parameters to the parameter list |
5d09245e | 4677 | |
01243764 | 4678 | Append_To (Param_Specs, |
fa1608c2 ES |
4679 | Make_Parameter_Specification (Loc, |
4680 | Defining_Identifier => A, | |
e4494292 RD |
4681 | Parameter_Type => |
4682 | New_Occurrence_Of (Discr_Type, Loc))); | |
5d09245e | 4683 | |
01243764 | 4684 | Append_To (Param_Specs, |
fa1608c2 ES |
4685 | Make_Parameter_Specification (Loc, |
4686 | Defining_Identifier => B, | |
e4494292 RD |
4687 | Parameter_Type => |
4688 | New_Occurrence_Of (Discr_Type, Loc))); | |
5d09245e | 4689 | |
fa1608c2 | 4690 | Append_Elmt (A, New_Discrs); |
5d09245e | 4691 | |
fa1608c2 ES |
4692 | -- Generate the following code to compare each of the inferred |
4693 | -- discriminants: | |
4694 | ||
4695 | -- if a /= b then | |
4696 | -- return False; | |
4697 | -- end if; | |
4698 | ||
4699 | Append_To (Stmts, | |
4700 | Make_If_Statement (Loc, | |
4701 | Condition => | |
4702 | Make_Op_Ne (Loc, | |
e4494292 RD |
4703 | Left_Opnd => New_Occurrence_Of (A, Loc), |
4704 | Right_Opnd => New_Occurrence_Of (B, Loc)), | |
fa1608c2 ES |
4705 | Then_Statements => New_List ( |
4706 | Make_Simple_Return_Statement (Loc, | |
4707 | Expression => | |
4708 | New_Occurrence_Of (Standard_False, Loc))))); | |
4709 | Next_Discriminant (Discr); | |
4710 | end loop; | |
5d09245e AC |
4711 | |
4712 | -- Generate component-by-component comparison. Note that we must | |
9ea43db6 HK |
4713 | -- propagate the inferred discriminants formals to act as the case |
4714 | -- statement switch. Their value is added when an equality call on | |
4715 | -- unchecked unions is expanded. | |
5d09245e | 4716 | |
37368818 | 4717 | Append_List_To (Stmts, Make_Eq_Case (Typ, Comps, New_Discrs)); |
5d09245e AC |
4718 | end; |
4719 | ||
4720 | -- Normal case (not unchecked union) | |
70482933 | 4721 | |
70482933 RK |
4722 | else |
4723 | Append_To (Stmts, | |
dda38714 AC |
4724 | Make_Eq_If (Typ, Discriminant_Specifications (Def))); |
4725 | Append_List_To (Stmts, Make_Eq_Case (Typ, Comps)); | |
70482933 RK |
4726 | end if; |
4727 | ||
4728 | Append_To (Stmts, | |
04df6250 | 4729 | Make_Simple_Return_Statement (Loc, |
e4494292 | 4730 | Expression => New_Occurrence_Of (Standard_True, Loc))); |
70482933 | 4731 | |
01243764 JM |
4732 | Subp_Body := |
4733 | Make_Subprogram_Body (Loc, | |
9ea43db6 | 4734 | Specification => |
01243764 JM |
4735 | Make_Function_Specification (Loc, |
4736 | Defining_Unit_Name => Body_Id, | |
4737 | Parameter_Specifications => Param_Specs, | |
4738 | Result_Definition => | |
4739 | New_Occurrence_Of (Standard_Boolean, Loc)), | |
4740 | Declarations => Decls, | |
4741 | Handled_Statement_Sequence => | |
4742 | Make_Handled_Sequence_Of_Statements (Loc, | |
4743 | Statements => Stmts)); | |
70482933 | 4744 | |
01243764 | 4745 | return Subp_Body; |
70482933 RK |
4746 | end Build_Variant_Record_Equality; |
4747 | ||
07fc65c4 GB |
4748 | ----------------------------- |
4749 | -- Check_Stream_Attributes -- | |
4750 | ----------------------------- | |
4751 | ||
4752 | procedure Check_Stream_Attributes (Typ : Entity_Id) is | |
fbf5a39b | 4753 | Comp : Entity_Id; |
758c442c GD |
4754 | Par_Read : constant Boolean := |
4755 | Stream_Attribute_Available (Typ, TSS_Stream_Read) | |
4756 | and then not Has_Specified_Stream_Read (Typ); | |
4757 | Par_Write : constant Boolean := | |
4758 | Stream_Attribute_Available (Typ, TSS_Stream_Write) | |
4759 | and then not Has_Specified_Stream_Write (Typ); | |
07fc65c4 | 4760 | |
d2d3604c TQ |
4761 | procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type); |
4762 | -- Check that Comp has a user-specified Nam stream attribute | |
4763 | ||
758c442c GD |
4764 | ---------------- |
4765 | -- Check_Attr -- | |
4766 | ---------------- | |
4767 | ||
d2d3604c TQ |
4768 | procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is |
4769 | begin | |
2d6f6e08 AC |
4770 | -- Move this check to sem??? |
4771 | ||
758c442c | 4772 | if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then |
d2d3604c TQ |
4773 | Error_Msg_Name_1 := Nam; |
4774 | Error_Msg_N | |
4775 | ("|component& in limited extension must have% attribute", Comp); | |
4776 | end if; | |
4777 | end Check_Attr; | |
4778 | ||
758c442c GD |
4779 | -- Start of processing for Check_Stream_Attributes |
4780 | ||
07fc65c4 GB |
4781 | begin |
4782 | if Par_Read or else Par_Write then | |
4783 | Comp := First_Component (Typ); | |
4784 | while Present (Comp) loop | |
4785 | if Comes_From_Source (Comp) | |
d2d3604c | 4786 | and then Original_Record_Component (Comp) = Comp |
07fc65c4 GB |
4787 | and then Is_Limited_Type (Etype (Comp)) |
4788 | then | |
d2d3604c TQ |
4789 | if Par_Read then |
4790 | Check_Attr (Name_Read, TSS_Stream_Read); | |
4791 | end if; | |
4792 | ||
4793 | if Par_Write then | |
4794 | Check_Attr (Name_Write, TSS_Stream_Write); | |
07fc65c4 GB |
4795 | end if; |
4796 | end if; | |
4797 | ||
4798 | Next_Component (Comp); | |
4799 | end loop; | |
4800 | end if; | |
4801 | end Check_Stream_Attributes; | |
4802 | ||
95fef24f AC |
4803 | ---------------------- |
4804 | -- Clean_Task_Names -- | |
4805 | ---------------------- | |
70482933 | 4806 | |
95fef24f AC |
4807 | procedure Clean_Task_Names |
4808 | (Typ : Entity_Id; | |
4809 | Proc_Id : Entity_Id) | |
4810 | is | |
4811 | begin | |
4812 | if Has_Task (Typ) | |
4813 | and then not Restriction_Active (No_Implicit_Heap_Allocations) | |
4814 | and then not Global_Discard_Names | |
4815 | and then Tagged_Type_Expansion | |
4816 | then | |
4817 | Set_Uses_Sec_Stack (Proc_Id); | |
4818 | end if; | |
4819 | end Clean_Task_Names; | |
70482933 | 4820 | |
eb1091dd SB |
4821 | ------------------------------- |
4822 | -- Copy_Discr_Checking_Funcs -- | |
4823 | ------------------------------- | |
4824 | ||
4825 | procedure Copy_Discr_Checking_Funcs (N : Node_Id) is | |
4826 | Typ : constant Entity_Id := Defining_Identifier (N); | |
4827 | Comp : Entity_Id := First_Component (Typ); | |
4828 | Old_Comp : Entity_Id := First_Component | |
4829 | (Base_Type (Underlying_Type (Etype (Typ)))); | |
4830 | begin | |
4831 | while Present (Comp) loop | |
4832 | if Chars (Comp) = Chars (Old_Comp) then | |
4833 | Set_Discriminant_Checking_Func | |
4834 | (Comp, Discriminant_Checking_Func (Old_Comp)); | |
4835 | end if; | |
4836 | ||
4837 | Next_Component (Old_Comp); | |
4838 | Next_Component (Comp); | |
4839 | end loop; | |
4840 | end Copy_Discr_Checking_Funcs; | |
4841 | ||
95fef24f AC |
4842 | ------------------------------ |
4843 | -- Expand_Freeze_Array_Type -- | |
4844 | ------------------------------ | |
70482933 | 4845 | |
95fef24f AC |
4846 | procedure Expand_Freeze_Array_Type (N : Node_Id) is |
4847 | Typ : constant Entity_Id := Entity (N); | |
4848 | Base : constant Entity_Id := Base_Type (Typ); | |
4849 | Comp_Typ : constant Entity_Id := Component_Type (Typ); | |
70482933 | 4850 | |
70482933 | 4851 | begin |
95fef24f | 4852 | if not Is_Bit_Packed_Array (Typ) then |
70482933 | 4853 | |
95fef24f AC |
4854 | -- If the component contains tasks, so does the array type. This may |
4855 | -- not be indicated in the array type because the component may have | |
4856 | -- been a private type at the point of definition. Same if component | |
4857 | -- type is controlled or contains protected objects. | |
70482933 | 4858 | |
124bed29 | 4859 | Propagate_Concurrent_Flags (Base, Comp_Typ); |
95fef24f | 4860 | Set_Has_Controlled_Component |
5a527952 AC |
4861 | (Base, Has_Controlled_Component (Comp_Typ) |
4862 | or else Is_Controlled (Comp_Typ)); | |
70482933 | 4863 | |
95fef24f | 4864 | if No (Init_Proc (Base)) then |
70482933 | 4865 | |
95fef24f AC |
4866 | -- If this is an anonymous array created for a declaration with |
4867 | -- an initial value, its init_proc will never be called. The | |
4868 | -- initial value itself may have been expanded into assignments, | |
4869 | -- in which case the object declaration is carries the | |
4870 | -- No_Initialization flag. | |
70482933 | 4871 | |
95fef24f AC |
4872 | if Is_Itype (Base) |
4873 | and then Nkind (Associated_Node_For_Itype (Base)) = | |
4874 | N_Object_Declaration | |
4875 | and then | |
4876 | (Present (Expression (Associated_Node_For_Itype (Base))) | |
4877 | or else No_Initialization (Associated_Node_For_Itype (Base))) | |
4878 | then | |
4879 | null; | |
70482933 | 4880 | |
95fef24f AC |
4881 | -- We do not need an init proc for string or wide [wide] string, |
4882 | -- since the only time these need initialization in normalize or | |
4883 | -- initialize scalars mode, and these types are treated specially | |
4884 | -- and do not need initialization procedures. | |
70482933 | 4885 | |
95fef24f AC |
4886 | elsif Is_Standard_String_Type (Base) then |
4887 | null; | |
70482933 | 4888 | |
95fef24f | 4889 | -- Otherwise we have to build an init proc for the subtype |
70482933 | 4890 | |
95fef24f AC |
4891 | else |
4892 | Build_Array_Init_Proc (Base, N); | |
4893 | end if; | |
4894 | end if; | |
70482933 | 4895 | |
32b794c8 AC |
4896 | if Typ = Base and then Has_Controlled_Component (Base) then |
4897 | Build_Controlling_Procs (Base); | |
70482933 | 4898 | |
32b794c8 AC |
4899 | if not Is_Limited_Type (Comp_Typ) |
4900 | and then Number_Dimensions (Typ) = 1 | |
95fef24f | 4901 | then |
32b794c8 | 4902 | Build_Slice_Assignment (Typ); |
95fef24f AC |
4903 | end if; |
4904 | end if; | |
70482933 | 4905 | |
95fef24f AC |
4906 | -- For packed case, default initialization, except if the component type |
4907 | -- is itself a packed structure with an initialization procedure, or | |
4908 | -- initialize/normalize scalars active, and we have a base type, or the | |
4909 | -- type is public, because in that case a client might specify | |
4910 | -- Normalize_Scalars and there better be a public Init_Proc for it. | |
70482933 | 4911 | |
95fef24f AC |
4912 | elsif (Present (Init_Proc (Component_Type (Base))) |
4913 | and then No (Base_Init_Proc (Base))) | |
4914 | or else (Init_Or_Norm_Scalars and then Base = Typ) | |
4915 | or else Is_Public (Typ) | |
4916 | then | |
4917 | Build_Array_Init_Proc (Base, N); | |
4918 | end if; | |
95fef24f | 4919 | end Expand_Freeze_Array_Type; |
e530a2d1 | 4920 | |
95fef24f AC |
4921 | ----------------------------------- |
4922 | -- Expand_Freeze_Class_Wide_Type -- | |
4923 | ----------------------------------- | |
70482933 | 4924 | |
95fef24f AC |
4925 | procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is |
4926 | function Is_C_Derivation (Typ : Entity_Id) return Boolean; | |
4927 | -- Given a type, determine whether it is derived from a C or C++ root | |
70482933 | 4928 | |
95fef24f AC |
4929 | --------------------- |
4930 | -- Is_C_Derivation -- | |
4931 | --------------------- | |
a523b302 | 4932 | |
95fef24f AC |
4933 | function Is_C_Derivation (Typ : Entity_Id) return Boolean is |
4934 | T : Entity_Id; | |
70482933 | 4935 | |
95fef24f AC |
4936 | begin |
4937 | T := Typ; | |
4938 | loop | |
4939 | if Is_CPP_Class (T) | |
4940 | or else Convention (T) = Convention_C | |
4941 | or else Convention (T) = Convention_CPP | |
4942 | then | |
4943 | return True; | |
4944 | end if; | |
ea1941af | 4945 | |
95fef24f | 4946 | exit when T = Etype (T); |
1a36a0cd | 4947 | |
95fef24f AC |
4948 | T := Etype (T); |
4949 | end loop; | |
1a36a0cd | 4950 | |
95fef24f AC |
4951 | return False; |
4952 | end Is_C_Derivation; | |
ea1941af | 4953 | |
95fef24f | 4954 | -- Local variables |
70482933 | 4955 | |
95fef24f AC |
4956 | Typ : constant Entity_Id := Entity (N); |
4957 | Root : constant Entity_Id := Root_Type (Typ); | |
70482933 | 4958 | |
95fef24f | 4959 | -- Start of processing for Expand_Freeze_Class_Wide_Type |
ea1941af | 4960 | |
95fef24f AC |
4961 | begin |
4962 | -- Certain run-time configurations and targets do not provide support | |
4963 | -- for controlled types. | |
ea1941af | 4964 | |
95fef24f AC |
4965 | if Restriction_Active (No_Finalization) then |
4966 | return; | |
e192a2cd | 4967 | |
95fef24f AC |
4968 | -- Do not create TSS routine Finalize_Address when dispatching calls are |
4969 | -- disabled since the core of the routine is a dispatching call. | |
ea1941af | 4970 | |
95fef24f AC |
4971 | elsif Restriction_Active (No_Dispatching_Calls) then |
4972 | return; | |
ea1941af | 4973 | |
95fef24f AC |
4974 | -- Do not create TSS routine Finalize_Address for concurrent class-wide |
4975 | -- types. Ignore C, C++, CIL and Java types since it is assumed that the | |
4976 | -- non-Ada side will handle their destruction. | |
e192a2cd | 4977 | |
95fef24f AC |
4978 | elsif Is_Concurrent_Type (Root) |
4979 | or else Is_C_Derivation (Root) | |
4980 | or else Convention (Typ) = Convention_CPP | |
4981 | then | |
4982 | return; | |
ea1941af | 4983 | |
95fef24f AC |
4984 | -- Do not create TSS routine Finalize_Address when compiling in CodePeer |
4985 | -- mode since the routine contains an Unchecked_Conversion. | |
47cc8d6b | 4986 | |
95fef24f AC |
4987 | elsif CodePeer_Mode then |
4988 | return; | |
4989 | end if; | |
47cc8d6b | 4990 | |
95fef24f AC |
4991 | -- Create the body of TSS primitive Finalize_Address. This automatically |
4992 | -- sets the TSS entry for the class-wide type. | |
ea1941af | 4993 | |
95fef24f | 4994 | Make_Finalize_Address_Body (Typ); |
95fef24f | 4995 | end Expand_Freeze_Class_Wide_Type; |
70482933 | 4996 | |
95fef24f AC |
4997 | ------------------------------------ |
4998 | -- Expand_Freeze_Enumeration_Type -- | |
4999 | ------------------------------------ | |
70482933 | 5000 | |
95fef24f AC |
5001 | procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is |
5002 | Typ : constant Entity_Id := Entity (N); | |
5003 | Loc : constant Source_Ptr := Sloc (Typ); | |
70482933 | 5004 | |
95fef24f AC |
5005 | Arr : Entity_Id; |
5006 | Ent : Entity_Id; | |
5007 | Fent : Entity_Id; | |
5008 | Is_Contiguous : Boolean; | |
79e267f9 | 5009 | Index_Typ : Entity_Id; |
95fef24f AC |
5010 | Ityp : Entity_Id; |
5011 | Last_Repval : Uint; | |
5012 | Lst : List_Id; | |
5013 | Num : Nat; | |
5014 | Pos_Expr : Node_Id; | |
70482933 | 5015 | |
95fef24f AC |
5016 | Func : Entity_Id; |
5017 | pragma Warnings (Off, Func); | |
70482933 | 5018 | |
95fef24f | 5019 | begin |
95fef24f | 5020 | -- Various optimizations possible if given representation is contiguous |
70482933 | 5021 | |
95fef24f | 5022 | Is_Contiguous := True; |
70482933 | 5023 | |
95fef24f AC |
5024 | Ent := First_Literal (Typ); |
5025 | Last_Repval := Enumeration_Rep (Ent); | |
79e267f9 | 5026 | Num := 1; |
95fef24f | 5027 | Next_Literal (Ent); |
79e267f9 | 5028 | |
95fef24f AC |
5029 | while Present (Ent) loop |
5030 | if Enumeration_Rep (Ent) - Last_Repval /= 1 then | |
5031 | Is_Contiguous := False; | |
95fef24f AC |
5032 | else |
5033 | Last_Repval := Enumeration_Rep (Ent); | |
5034 | end if; | |
70482933 | 5035 | |
79e267f9 | 5036 | Num := Num + 1; |
95fef24f AC |
5037 | Next_Literal (Ent); |
5038 | end loop; | |
93188a0b | 5039 | |
95fef24f AC |
5040 | if Is_Contiguous then |
5041 | Set_Has_Contiguous_Rep (Typ); | |
79e267f9 EB |
5042 | |
5043 | -- Now build a subtype declaration | |
5044 | ||
5045 | -- subtype typI is new Natural range 0 .. num - 1 | |
5046 | ||
5047 | Index_Typ := | |
5048 | Make_Defining_Identifier (Loc, | |
5049 | Chars => New_External_Name (Chars (Typ), 'I')); | |
5050 | ||
5051 | Append_Freeze_Action (Typ, | |
5052 | Make_Subtype_Declaration (Loc, | |
5053 | Defining_Identifier => Index_Typ, | |
5054 | Subtype_Indication => | |
5055 | Make_Subtype_Indication (Loc, | |
5056 | Subtype_Mark => | |
5057 | New_Occurrence_Of (Standard_Natural, Loc), | |
5058 | Constraint => | |
5059 | Make_Range_Constraint (Loc, | |
5060 | Range_Expression => | |
5061 | Make_Range (Loc, | |
5062 | Low_Bound => | |
5063 | Make_Integer_Literal (Loc, 0), | |
5064 | High_Bound => | |
5065 | Make_Integer_Literal (Loc, Num - 1)))))); | |
5066 | ||
5067 | Set_Enum_Pos_To_Rep (Typ, Index_Typ); | |
e7f11067 | 5068 | |
95fef24f AC |
5069 | else |
5070 | -- Build list of literal references | |
4ac2bbbd | 5071 | |
95fef24f | 5072 | Lst := New_List; |
95fef24f AC |
5073 | Ent := First_Literal (Typ); |
5074 | while Present (Ent) loop | |
5075 | Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent))); | |
95fef24f AC |
5076 | Next_Literal (Ent); |
5077 | end loop; | |
e7f11067 | 5078 | |
79e267f9 | 5079 | -- Now build an array declaration |
e7f11067 | 5080 | |
79e267f9 EB |
5081 | -- typA : constant array (Natural range 0 .. num - 1) of typ := |
5082 | -- (v, v, v, v, v, ....) | |
5083 | ||
5084 | Arr := | |
5085 | Make_Defining_Identifier (Loc, | |
5086 | Chars => New_External_Name (Chars (Typ), 'A')); | |
03eb6036 | 5087 | |
79e267f9 EB |
5088 | Append_Freeze_Action (Typ, |
5089 | Make_Object_Declaration (Loc, | |
5090 | Defining_Identifier => Arr, | |
5091 | Constant_Present => True, | |
5092 | ||
5093 | Object_Definition => | |
5094 | Make_Constrained_Array_Definition (Loc, | |
5095 | Discrete_Subtype_Definitions => New_List ( | |
5096 | Make_Subtype_Indication (Loc, | |
5097 | Subtype_Mark => | |
5098 | New_Occurrence_Of (Standard_Natural, Loc), | |
5099 | Constraint => | |
5100 | Make_Range_Constraint (Loc, | |
5101 | Range_Expression => | |
5102 | Make_Range (Loc, | |
5103 | Low_Bound => | |
5104 | Make_Integer_Literal (Loc, 0), | |
5105 | High_Bound => | |
5106 | Make_Integer_Literal (Loc, Num - 1))))), | |
5107 | ||
5108 | Component_Definition => | |
5109 | Make_Component_Definition (Loc, | |
5110 | Aliased_Present => False, | |
5111 | Subtype_Indication => New_Occurrence_Of (Typ, Loc))), | |
e7f11067 | 5112 | |
79e267f9 EB |
5113 | Expression => |
5114 | Make_Aggregate (Loc, | |
5115 | Expressions => Lst))); | |
e7f11067 | 5116 | |
79e267f9 EB |
5117 | Set_Enum_Pos_To_Rep (Typ, Arr); |
5118 | end if; | |
e7f11067 | 5119 | |
95fef24f AC |
5120 | -- Now we build the function that converts representation values to |
5121 | -- position values. This function has the form: | |
e7f11067 | 5122 | |
95fef24f AC |
5123 | -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is |
5124 | -- begin | |
5125 | -- case ityp!(A) is | |
5126 | -- when enum-lit'Enum_Rep => return posval; | |
5127 | -- when enum-lit'Enum_Rep => return posval; | |
5128 | -- ... | |
5129 | -- when others => | |
5130 | -- [raise Constraint_Error when F "invalid data"] | |
5131 | -- return -1; | |
5132 | -- end case; | |
5133 | -- end; | |
e7f11067 | 5134 | |
95fef24f AC |
5135 | -- Note: the F parameter determines whether the others case (no valid |
5136 | -- representation) raises Constraint_Error or returns a unique value | |
5137 | -- of minus one. The latter case is used, e.g. in 'Valid code. | |
e7f11067 | 5138 | |
95fef24f AC |
5139 | -- Note: the reason we use Enum_Rep values in the case here is to avoid |
5140 | -- the code generator making inappropriate assumptions about the range | |
5141 | -- of the values in the case where the value is invalid. ityp is a | |
5142 | -- signed or unsigned integer type of appropriate width. | |
e7f11067 | 5143 | |
95fef24f AC |
5144 | -- Note: if exceptions are not supported, then we suppress the raise |
5145 | -- and return -1 unconditionally (this is an erroneous program in any | |
5146 | -- case and there is no obligation to raise Constraint_Error here). We | |
5147 | -- also do this if pragma Restrictions (No_Exceptions) is active. | |
e7f11067 | 5148 | |
95fef24f | 5149 | -- Is this right??? What about No_Exception_Propagation??? |
e7f11067 | 5150 | |
c7c7dd3a EB |
5151 | -- The underlying type is signed. Reset the Is_Unsigned_Type explicitly |
5152 | -- because it might have been inherited from the parent type. | |
e7f11067 | 5153 | |
95fef24f | 5154 | if Enumeration_Rep (First_Literal (Typ)) < 0 then |
95fef24f | 5155 | Set_Is_Unsigned_Type (Typ, False); |
95fef24f | 5156 | end if; |
4ac2bbbd | 5157 | |
c7c7dd3a EB |
5158 | Ityp := Integer_Type_For (Esize (Typ), Is_Unsigned_Type (Typ)); |
5159 | ||
95fef24f AC |
5160 | -- The body of the function is a case statement. First collect case |
5161 | -- alternatives, or optimize the contiguous case. | |
4ac2bbbd | 5162 | |
95fef24f | 5163 | Lst := New_List; |
4ac2bbbd | 5164 | |
95fef24f AC |
5165 | -- If representation is contiguous, Pos is computed by subtracting |
5166 | -- the representation of the first literal. | |
4ac2bbbd | 5167 | |
95fef24f AC |
5168 | if Is_Contiguous then |
5169 | Ent := First_Literal (Typ); | |
4ac2bbbd | 5170 | |
95fef24f | 5171 | if Enumeration_Rep (Ent) = Last_Repval then |
4ac2bbbd | 5172 | |
95fef24f | 5173 | -- Another special case: for a single literal, Pos is zero |
4ac2bbbd | 5174 | |
95fef24f | 5175 | Pos_Expr := Make_Integer_Literal (Loc, Uint_0); |
e2bc5465 | 5176 | |
95fef24f AC |
5177 | else |
5178 | Pos_Expr := | |
5179 | Convert_To (Standard_Integer, | |
5180 | Make_Op_Subtract (Loc, | |
5181 | Left_Opnd => | |
5182 | Unchecked_Convert_To | |
5183 | (Ityp, Make_Identifier (Loc, Name_uA)), | |
5184 | Right_Opnd => | |
5185 | Make_Integer_Literal (Loc, | |
5186 | Intval => Enumeration_Rep (First_Literal (Typ))))); | |
5187 | end if; | |
4ac2bbbd | 5188 | |
95fef24f AC |
5189 | Append_To (Lst, |
5190 | Make_Case_Statement_Alternative (Loc, | |
5191 | Discrete_Choices => New_List ( | |
5192 | Make_Range (Sloc (Enumeration_Rep_Expr (Ent)), | |
5193 | Low_Bound => | |
5194 | Make_Integer_Literal (Loc, | |
eedc5882 | 5195 | Intval => Enumeration_Rep (Ent)), |
95fef24f AC |
5196 | High_Bound => |
5197 | Make_Integer_Literal (Loc, Intval => Last_Repval))), | |
7b536495 | 5198 | |
95fef24f AC |
5199 | Statements => New_List ( |
5200 | Make_Simple_Return_Statement (Loc, | |
5201 | Expression => Pos_Expr)))); | |
7b536495 | 5202 | |
95fef24f AC |
5203 | else |
5204 | Ent := First_Literal (Typ); | |
5205 | while Present (Ent) loop | |
5206 | Append_To (Lst, | |
5207 | Make_Case_Statement_Alternative (Loc, | |
5208 | Discrete_Choices => New_List ( | |
5209 | Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)), | |
5210 | Intval => Enumeration_Rep (Ent))), | |
4ac2bbbd | 5211 | |
95fef24f AC |
5212 | Statements => New_List ( |
5213 | Make_Simple_Return_Statement (Loc, | |
5214 | Expression => | |
5215 | Make_Integer_Literal (Loc, | |
5216 | Intval => Enumeration_Pos (Ent)))))); | |
4ac2bbbd | 5217 | |
95fef24f AC |
5218 | Next_Literal (Ent); |
5219 | end loop; | |
5220 | end if; | |
4ac2bbbd | 5221 | |
8d4611f7 AC |
5222 | -- In normal mode, add the others clause with the test. |
5223 | -- If Predicates_Ignored is True, validity checks do not apply to | |
5224 | -- the subtype. | |
4ac2bbbd | 5225 | |
8d4611f7 AC |
5226 | if not No_Exception_Handlers_Set |
5227 | and then not Predicates_Ignored (Typ) | |
5228 | then | |
95fef24f AC |
5229 | Append_To (Lst, |
5230 | Make_Case_Statement_Alternative (Loc, | |
5231 | Discrete_Choices => New_List (Make_Others_Choice (Loc)), | |
32b794c8 | 5232 | Statements => New_List ( |
95fef24f AC |
5233 | Make_Raise_Constraint_Error (Loc, |
5234 | Condition => Make_Identifier (Loc, Name_uF), | |
5235 | Reason => CE_Invalid_Data), | |
5236 | Make_Simple_Return_Statement (Loc, | |
32b794c8 | 5237 | Expression => Make_Integer_Literal (Loc, -1))))); |
4ac2bbbd | 5238 | |
95fef24f AC |
5239 | -- If either of the restrictions No_Exceptions_Handlers/Propagation is |
5240 | -- active then return -1 (we cannot usefully raise Constraint_Error in | |
5241 | -- this case). See description above for further details. | |
4ac2bbbd | 5242 | |
95fef24f AC |
5243 | else |
5244 | Append_To (Lst, | |
5245 | Make_Case_Statement_Alternative (Loc, | |
5246 | Discrete_Choices => New_List (Make_Others_Choice (Loc)), | |
32b794c8 | 5247 | Statements => New_List ( |
95fef24f | 5248 | Make_Simple_Return_Statement (Loc, |
32b794c8 | 5249 | Expression => Make_Integer_Literal (Loc, -1))))); |
95fef24f | 5250 | end if; |
4ac2bbbd | 5251 | |
95fef24f | 5252 | -- Now we can build the function body |
4ac2bbbd | 5253 | |
95fef24f AC |
5254 | Fent := |
5255 | Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos)); | |
4ac2bbbd | 5256 | |
95fef24f AC |
5257 | Func := |
5258 | Make_Subprogram_Body (Loc, | |
5259 | Specification => | |
5260 | Make_Function_Specification (Loc, | |
5261 | Defining_Unit_Name => Fent, | |
5262 | Parameter_Specifications => New_List ( | |
5263 | Make_Parameter_Specification (Loc, | |
5264 | Defining_Identifier => | |
5265 | Make_Defining_Identifier (Loc, Name_uA), | |
5266 | Parameter_Type => New_Occurrence_Of (Typ, Loc)), | |
5267 | Make_Parameter_Specification (Loc, | |
5268 | Defining_Identifier => | |
5269 | Make_Defining_Identifier (Loc, Name_uF), | |
5270 | Parameter_Type => | |
5271 | New_Occurrence_Of (Standard_Boolean, Loc))), | |
4ac2bbbd | 5272 | |
95fef24f | 5273 | Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)), |
4ac2bbbd | 5274 | |
95fef24f | 5275 | Declarations => Empty_List, |
4ac2bbbd | 5276 | |
95fef24f AC |
5277 | Handled_Statement_Sequence => |
5278 | Make_Handled_Sequence_Of_Statements (Loc, | |
5279 | Statements => New_List ( | |
5280 | Make_Case_Statement (Loc, | |
5281 | Expression => | |
5282 | Unchecked_Convert_To | |
5283 | (Ityp, Make_Identifier (Loc, Name_uA)), | |
5284 | Alternatives => Lst)))); | |
4ac2bbbd | 5285 | |
95fef24f | 5286 | Set_TSS (Typ, Fent); |
4ac2bbbd | 5287 | |
95fef24f AC |
5288 | -- Set Pure flag (it will be reset if the current context is not Pure). |
5289 | -- We also pretend there was a pragma Pure_Function so that for purposes | |
5290 | -- of optimization and constant-folding, we will consider the function | |
5291 | -- Pure even if we are not in a Pure context). | |
4ac2bbbd | 5292 | |
95fef24f AC |
5293 | Set_Is_Pure (Fent); |
5294 | Set_Has_Pragma_Pure_Function (Fent); | |
4ac2bbbd | 5295 | |
95fef24f AC |
5296 | -- Unless we are in -gnatD mode, where we are debugging generated code, |
5297 | -- this is an internal entity for which we don't need debug info. | |
4ac2bbbd | 5298 | |
95fef24f AC |
5299 | if not Debug_Generated_Code then |
5300 | Set_Debug_Info_Off (Fent); | |
5301 | end if; | |
4ac2bbbd | 5302 | |
138fc6f1 HK |
5303 | Set_Is_Inlined (Fent); |
5304 | ||
95fef24f AC |
5305 | exception |
5306 | when RE_Not_Available => | |
95fef24f AC |
5307 | return; |
5308 | end Expand_Freeze_Enumeration_Type; | |
4ac2bbbd | 5309 | |
95fef24f AC |
5310 | ------------------------------- |
5311 | -- Expand_Freeze_Record_Type -- | |
5312 | ------------------------------- | |
4ac2bbbd | 5313 | |
95fef24f | 5314 | procedure Expand_Freeze_Record_Type (N : Node_Id) is |
475e1d24 JM |
5315 | |
5316 | procedure Build_Class_Condition_Subprograms (Typ : Entity_Id); | |
5317 | -- Create internal subprograms of Typ primitives that have class-wide | |
5318 | -- preconditions or postconditions; they are invoked by the caller to | |
5319 | -- evaluate the conditions. | |
5320 | ||
01243764 JM |
5321 | procedure Build_Variant_Record_Equality (Typ : Entity_Id); |
5322 | -- Create An Equality function for the untagged variant record Typ and | |
5323 | -- attach it to the TSS list. | |
5324 | ||
475e1d24 JM |
5325 | procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id); |
5326 | -- Register dispatch-table wrappers in the dispatch table of Typ | |
5327 | ||
f1668c3d JM |
5328 | procedure Validate_Tagged_Type_Extra_Formals (Typ : Entity_Id); |
5329 | -- Check extra formals of dispatching primitives of tagged type Typ. | |
5330 | -- Used in pragma Debug. | |
5331 | ||
475e1d24 JM |
5332 | --------------------------------------- |
5333 | -- Build_Class_Condition_Subprograms -- | |
5334 | --------------------------------------- | |
5335 | ||
5336 | procedure Build_Class_Condition_Subprograms (Typ : Entity_Id) is | |
5337 | Prim_List : constant Elist_Id := Primitive_Operations (Typ); | |
5338 | Prim_Elmt : Elmt_Id := First_Elmt (Prim_List); | |
5339 | Prim : Entity_Id; | |
5340 | ||
5341 | begin | |
5342 | while Present (Prim_Elmt) loop | |
5343 | Prim := Node (Prim_Elmt); | |
5344 | ||
5345 | -- Primitive with class-wide preconditions | |
5346 | ||
5347 | if Comes_From_Source (Prim) | |
5348 | and then Has_Significant_Contract (Prim) | |
5349 | and then | |
5350 | (Present (Class_Preconditions (Prim)) | |
5351 | or else Present (Ignored_Class_Preconditions (Prim))) | |
5352 | then | |
5353 | if Expander_Active then | |
5354 | Make_Class_Precondition_Subps (Prim); | |
5355 | end if; | |
5356 | ||
5357 | -- Wrapper of a primitive that has or inherits class-wide | |
5358 | -- preconditions. | |
5359 | ||
5360 | elsif Is_Primitive_Wrapper (Prim) | |
5361 | and then | |
5362 | (Present (Nearest_Class_Condition_Subprogram | |
5363 | (Spec_Id => Prim, | |
5364 | Kind => Class_Precondition)) | |
5365 | or else | |
5366 | Present (Nearest_Class_Condition_Subprogram | |
5367 | (Spec_Id => Prim, | |
5368 | Kind => Ignored_Class_Precondition))) | |
5369 | then | |
5370 | if Expander_Active then | |
5371 | Make_Class_Precondition_Subps (Prim); | |
5372 | end if; | |
5373 | end if; | |
5374 | ||
5375 | Next_Elmt (Prim_Elmt); | |
5376 | end loop; | |
5377 | end Build_Class_Condition_Subprograms; | |
5378 | ||
9ea43db6 HK |
5379 | ----------------------------------- |
5380 | -- Build_Variant_Record_Equality -- | |
5381 | ----------------------------------- | |
5382 | ||
01243764 JM |
5383 | procedure Build_Variant_Record_Equality (Typ : Entity_Id) is |
5384 | Loc : constant Source_Ptr := Sloc (Typ); | |
9ea43db6 | 5385 | F : constant Entity_Id := |
01243764 JM |
5386 | Make_Defining_Identifier (Loc, |
5387 | Chars => Make_TSS_Name (Typ, TSS_Composite_Equality)); | |
5388 | begin | |
5389 | -- For a variant record with restriction No_Implicit_Conditionals | |
5390 | -- in effect we skip building the procedure. This is safe because | |
5391 | -- if we can see the restriction, so can any caller, and calls to | |
5392 | -- equality test routines are not allowed for variant records if | |
5393 | -- this restriction is active. | |
5394 | ||
5395 | if Restriction_Active (No_Implicit_Conditionals) then | |
5396 | return; | |
5397 | end if; | |
5398 | ||
5399 | -- Derived Unchecked_Union types no longer inherit the equality | |
5400 | -- function of their parent. | |
5401 | ||
5402 | if Is_Derived_Type (Typ) | |
5403 | and then not Is_Unchecked_Union (Typ) | |
5404 | and then not Has_New_Non_Standard_Rep (Typ) | |
5405 | then | |
5406 | declare | |
5407 | Parent_Eq : constant Entity_Id := | |
5408 | TSS (Root_Type (Typ), TSS_Composite_Equality); | |
5409 | begin | |
5410 | if Present (Parent_Eq) then | |
5411 | Copy_TSS (Parent_Eq, Typ); | |
5412 | return; | |
5413 | end if; | |
5414 | end; | |
5415 | end if; | |
5416 | ||
5417 | Discard_Node ( | |
5418 | Build_Variant_Record_Equality | |
5419 | (Typ => Typ, | |
5420 | Body_Id => F, | |
5421 | Param_Specs => New_List ( | |
5422 | Make_Parameter_Specification (Loc, | |
9ea43db6 HK |
5423 | Defining_Identifier => |
5424 | Make_Defining_Identifier (Loc, Name_X), | |
01243764 | 5425 | Parameter_Type => New_Occurrence_Of (Typ, Loc)), |
9ea43db6 | 5426 | |
01243764 | 5427 | Make_Parameter_Specification (Loc, |
9ea43db6 HK |
5428 | Defining_Identifier => |
5429 | Make_Defining_Identifier (Loc, Name_Y), | |
01243764 JM |
5430 | Parameter_Type => New_Occurrence_Of (Typ, Loc))))); |
5431 | ||
5432 | Set_TSS (Typ, F); | |
5433 | Set_Is_Pure (F); | |
5434 | ||
5435 | if not Debug_Generated_Code then | |
5436 | Set_Debug_Info_Off (F); | |
5437 | end if; | |
5438 | end Build_Variant_Record_Equality; | |
5439 | ||
475e1d24 JM |
5440 | -------------------------------------- |
5441 | -- Register_Dispatch_Table_Wrappers -- | |
5442 | -------------------------------------- | |
5443 | ||
5444 | procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id) is | |
5445 | Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Typ)); | |
5446 | Subp : Entity_Id; | |
5447 | ||
5448 | begin | |
5449 | while Present (Elmt) loop | |
5450 | Subp := Node (Elmt); | |
5451 | ||
5452 | if Is_Dispatch_Table_Wrapper (Subp) then | |
5453 | Append_Freeze_Actions (Typ, | |
5454 | Register_Primitive (Sloc (Subp), Subp)); | |
5455 | end if; | |
5456 | ||
5457 | Next_Elmt (Elmt); | |
5458 | end loop; | |
5459 | end Register_Dispatch_Table_Wrappers; | |
5460 | ||
f1668c3d JM |
5461 | ---------------------------------------- |
5462 | -- Validate_Tagged_Type_Extra_Formals -- | |
5463 | ---------------------------------------- | |
5464 | ||
5465 | procedure Validate_Tagged_Type_Extra_Formals (Typ : Entity_Id) is | |
5466 | Ovr_Subp : Entity_Id; | |
5467 | Elmt : Elmt_Id; | |
5468 | Subp : Entity_Id; | |
5469 | ||
5470 | begin | |
5471 | pragma Assert (not Is_Class_Wide_Type (Typ)); | |
5472 | ||
5473 | -- No check required if expansion is not active since we never | |
5474 | -- generate extra formals in such case. | |
5475 | ||
5476 | if not Expander_Active then | |
5477 | return; | |
5478 | end if; | |
5479 | ||
5480 | Elmt := First_Elmt (Primitive_Operations (Typ)); | |
5481 | while Present (Elmt) loop | |
5482 | Subp := Node (Elmt); | |
5483 | ||
5484 | -- Extra formals of a dispatching primitive must match: | |
5485 | ||
5486 | -- 1) The extra formals of its covered interface primitive | |
5487 | ||
5488 | if Present (Interface_Alias (Subp)) then | |
5489 | pragma Assert | |
5490 | (Extra_Formals_Match_OK | |
5491 | (E => Interface_Alias (Subp), | |
5492 | Ref_E => Alias (Subp))); | |
5493 | end if; | |
5494 | ||
5495 | -- 2) The extra formals of its renamed primitive | |
5496 | ||
5497 | if Present (Alias (Subp)) then | |
5498 | pragma Assert | |
5499 | (Extra_Formals_Match_OK | |
5500 | (E => Subp, | |
5501 | Ref_E => Ultimate_Alias (Subp))); | |
5502 | end if; | |
5503 | ||
5504 | -- 3) The extra formals of its overridden primitive | |
5505 | ||
5506 | if Present (Overridden_Operation (Subp)) then | |
5507 | Ovr_Subp := Overridden_Operation (Subp); | |
5508 | ||
5509 | -- Handle controlling function wrapper | |
5510 | ||
5511 | if Is_Wrapper (Subp) | |
5512 | and then Ultimate_Alias (Ovr_Subp) = Subp | |
5513 | then | |
5514 | if Present (Overridden_Operation (Ovr_Subp)) then | |
5515 | pragma Assert | |
5516 | (Extra_Formals_Match_OK | |
5517 | (E => Subp, | |
5518 | Ref_E => Overridden_Operation (Ovr_Subp))); | |
5519 | end if; | |
5520 | ||
5521 | else | |
5522 | pragma Assert | |
5523 | (Extra_Formals_Match_OK | |
5524 | (E => Subp, | |
5525 | Ref_E => Ovr_Subp)); | |
5526 | end if; | |
5527 | end if; | |
5528 | ||
5529 | Next_Elmt (Elmt); | |
5530 | end loop; | |
5531 | end Validate_Tagged_Type_Extra_Formals; | |
5532 | ||
01243764 JM |
5533 | -- Local variables |
5534 | ||
95fef24f AC |
5535 | Typ : constant Node_Id := Entity (N); |
5536 | Typ_Decl : constant Node_Id := Parent (Typ); | |
4ac2bbbd | 5537 | |
95fef24f AC |
5538 | Comp : Entity_Id; |
5539 | Comp_Typ : Entity_Id; | |
95fef24f | 5540 | Predef_List : List_Id; |
4ac2bbbd | 5541 | |
ec9c3bd5 | 5542 | Wrapper_Decl_List : List_Id; |
32b794c8 AC |
5543 | Wrapper_Body_List : List_Id := No_List; |
5544 | ||
95fef24f AC |
5545 | Renamed_Eq : Node_Id := Empty; |
5546 | -- Defining unit name for the predefined equality function in the case | |
5547 | -- where the type has a primitive operation that is a renaming of | |
5548 | -- predefined equality (but only if there is also an overriding | |
5549 | -- user-defined equality function). Used to pass this entity from | |
5550 | -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies. | |
4ac2bbbd | 5551 | |
95fef24f | 5552 | -- Start of processing for Expand_Freeze_Record_Type |
4ac2bbbd | 5553 | |
95fef24f | 5554 | begin |
95fef24f AC |
5555 | -- Build discriminant checking functions if not a derived type (for |
5556 | -- derived types that are not tagged types, always use the discriminant | |
5557 | -- checking functions of the parent type). However, for untagged types | |
5558 | -- the derivation may have taken place before the parent was frozen, so | |
5559 | -- we copy explicitly the discriminant checking functions from the | |
5560 | -- parent into the components of the derived type. | |
4ac2bbbd | 5561 | |
eb1091dd | 5562 | Build_Or_Copy_Discr_Checking_Funcs (Typ_Decl); |
4ac2bbbd | 5563 | |
95fef24f AC |
5564 | if Is_Derived_Type (Typ) |
5565 | and then Is_Limited_Type (Typ) | |
5566 | and then Is_Tagged_Type (Typ) | |
5567 | then | |
5568 | Check_Stream_Attributes (Typ); | |
5569 | end if; | |
4ac2bbbd | 5570 | |
95fef24f AC |
5571 | -- Update task, protected, and controlled component flags, because some |
5572 | -- of the component types may have been private at the point of the | |
5573 | -- record declaration. Detect anonymous access-to-controlled components. | |
4ac2bbbd | 5574 | |
95fef24f AC |
5575 | Comp := First_Component (Typ); |
5576 | while Present (Comp) loop | |
5577 | Comp_Typ := Etype (Comp); | |
4ac2bbbd | 5578 | |
124bed29 | 5579 | Propagate_Concurrent_Flags (Typ, Comp_Typ); |
e2bc5465 | 5580 | |
95fef24f AC |
5581 | -- Do not set Has_Controlled_Component on a class-wide equivalent |
5582 | -- type. See Make_CW_Equivalent_Type. | |
cf27c5a2 | 5583 | |
95fef24f AC |
5584 | if not Is_Class_Wide_Equivalent_Type (Typ) |
5585 | and then | |
5586 | (Has_Controlled_Component (Comp_Typ) | |
5587 | or else (Chars (Comp) /= Name_uParent | |
0cb81445 | 5588 | and then Is_Controlled (Comp_Typ))) |
95fef24f AC |
5589 | then |
5590 | Set_Has_Controlled_Component (Typ); | |
5591 | end if; | |
cf27c5a2 | 5592 | |
95fef24f AC |
5593 | Next_Component (Comp); |
5594 | end loop; | |
4ac2bbbd | 5595 | |
95fef24f | 5596 | -- Handle constructors of untagged CPP_Class types |
4ac2bbbd | 5597 | |
95fef24f AC |
5598 | if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then |
5599 | Set_CPP_Constructors (Typ); | |
5600 | end if; | |
e2bc5465 | 5601 | |
95fef24f AC |
5602 | -- Creation of the Dispatch Table. Note that a Dispatch Table is built |
5603 | -- for regular tagged types as well as for Ada types deriving from a C++ | |
5604 | -- Class, but not for tagged types directly corresponding to C++ classes | |
5605 | -- In the later case we assume that it is created in the C++ side and we | |
5606 | -- just use it. | |
e2bc5465 | 5607 | |
95fef24f | 5608 | if Is_Tagged_Type (Typ) then |
4ac2bbbd | 5609 | |
95fef24f | 5610 | -- Add the _Tag component |
4ac2bbbd | 5611 | |
95fef24f AC |
5612 | if Underlying_Type (Etype (Typ)) = Typ then |
5613 | Expand_Tagged_Root (Typ); | |
4ac2bbbd AC |
5614 | end if; |
5615 | ||
95fef24f AC |
5616 | if Is_CPP_Class (Typ) then |
5617 | Set_All_DT_Position (Typ); | |
4ac2bbbd | 5618 | |
95fef24f | 5619 | -- Create the tag entities with a minimum decoration |
4ac2bbbd | 5620 | |
95fef24f AC |
5621 | if Tagged_Type_Expansion then |
5622 | Append_Freeze_Actions (Typ, Make_Tags (Typ)); | |
5623 | end if; | |
e264efcc | 5624 | |
95fef24f | 5625 | Set_CPP_Constructors (Typ); |
e264efcc | 5626 | |
95fef24f AC |
5627 | else |
5628 | if not Building_Static_DT (Typ) then | |
4ac2bbbd | 5629 | |
95fef24f AC |
5630 | -- Usually inherited primitives are not delayed but the first |
5631 | -- Ada extension of a CPP_Class is an exception since the | |
5632 | -- address of the inherited subprogram has to be inserted in | |
5633 | -- the new Ada Dispatch Table and this is a freezing action. | |
4ac2bbbd | 5634 | |
95fef24f AC |
5635 | -- Similarly, if this is an inherited operation whose parent is |
5636 | -- not frozen yet, it is not in the DT of the parent, and we | |
5637 | -- generate an explicit freeze node for the inherited operation | |
5638 | -- so it is properly inserted in the DT of the current type. | |
4ac2bbbd | 5639 | |
95fef24f AC |
5640 | declare |
5641 | Elmt : Elmt_Id; | |
5642 | Subp : Entity_Id; | |
e264efcc | 5643 | |
95fef24f AC |
5644 | begin |
5645 | Elmt := First_Elmt (Primitive_Operations (Typ)); | |
5646 | while Present (Elmt) loop | |
5647 | Subp := Node (Elmt); | |
70482933 | 5648 | |
95fef24f AC |
5649 | if Present (Alias (Subp)) then |
5650 | if Is_CPP_Class (Etype (Typ)) then | |
5651 | Set_Has_Delayed_Freeze (Subp); | |
70482933 | 5652 | |
95fef24f AC |
5653 | elsif Has_Delayed_Freeze (Alias (Subp)) |
5654 | and then not Is_Frozen (Alias (Subp)) | |
5655 | then | |
5656 | Set_Is_Frozen (Subp, False); | |
5657 | Set_Has_Delayed_Freeze (Subp); | |
5658 | end if; | |
5659 | end if; | |
e699b76e | 5660 | |
95fef24f AC |
5661 | Next_Elmt (Elmt); |
5662 | end loop; | |
5663 | end; | |
5664 | end if; | |
e699b76e | 5665 | |
95fef24f AC |
5666 | -- Unfreeze momentarily the type to add the predefined primitives |
5667 | -- operations. The reason we unfreeze is so that these predefined | |
5668 | -- operations will indeed end up as primitive operations (which | |
5669 | -- must be before the freeze point). | |
abcd9db2 | 5670 | |
95fef24f | 5671 | Set_Is_Frozen (Typ, False); |
04df6250 | 5672 | |
95fef24f AC |
5673 | -- Do not add the spec of predefined primitives in case of |
5674 | -- CPP tagged type derivations that have convention CPP. | |
04df6250 | 5675 | |
95fef24f AC |
5676 | if Is_CPP_Class (Root_Type (Typ)) |
5677 | and then Convention (Typ) = Convention_CPP | |
5678 | then | |
5679 | null; | |
5680 | ||
5681 | -- Do not add the spec of the predefined primitives if we are | |
5682 | -- compiling under restriction No_Dispatching_Calls. | |
5683 | ||
5684 | elsif not Restriction_Active (No_Dispatching_Calls) then | |
5685 | Make_Predefined_Primitive_Specs (Typ, Predef_List, Renamed_Eq); | |
5686 | Insert_List_Before_And_Analyze (N, Predef_List); | |
04df6250 TQ |
5687 | end if; |
5688 | ||
95fef24f AC |
5689 | -- Ada 2005 (AI-391): For a nonabstract null extension, create |
5690 | -- wrapper functions for each nonoverridden inherited function | |
5691 | -- with a controlling result of the type. The wrapper for such | |
5692 | -- a function returns an extension aggregate that invokes the | |
5693 | -- parent function. | |
5694 | ||
5695 | if Ada_Version >= Ada_2005 | |
5696 | and then not Is_Abstract_Type (Typ) | |
5697 | and then Is_Null_Extension (Typ) | |
5698 | then | |
5699 | Make_Controlling_Function_Wrappers | |
5700 | (Typ, Wrapper_Decl_List, Wrapper_Body_List); | |
5701 | Insert_List_Before_And_Analyze (N, Wrapper_Decl_List); | |
04df6250 | 5702 | end if; |
04df6250 | 5703 | |
95fef24f AC |
5704 | -- Ada 2005 (AI-251): For a nonabstract type extension, build |
5705 | -- null procedure declarations for each set of homographic null | |
5706 | -- procedures that are inherited from interface types but not | |
5707 | -- overridden. This is done to ensure that the dispatch table | |
5708 | -- entry associated with such null primitives are properly filled. | |
70482933 | 5709 | |
95fef24f AC |
5710 | if Ada_Version >= Ada_2005 |
5711 | and then Etype (Typ) /= Typ | |
5712 | and then not Is_Abstract_Type (Typ) | |
5713 | and then Has_Interfaces (Typ) | |
5714 | then | |
5715 | Insert_Actions (N, Make_Null_Procedure_Specs (Typ)); | |
5716 | end if; | |
70482933 | 5717 | |
95fef24f | 5718 | Set_Is_Frozen (Typ); |
70482933 | 5719 | |
95fef24f AC |
5720 | if not Is_Derived_Type (Typ) |
5721 | or else Is_Tagged_Type (Etype (Typ)) | |
5722 | then | |
5723 | Set_All_DT_Position (Typ); | |
70482933 | 5724 | |
95fef24f AC |
5725 | -- If this is a type derived from an untagged private type whose |
5726 | -- full view is tagged, the type is marked tagged for layout | |
5727 | -- reasons, but it has no dispatch table. | |
70482933 | 5728 | |
95fef24f AC |
5729 | elsif Is_Derived_Type (Typ) |
5730 | and then Is_Private_Type (Etype (Typ)) | |
5731 | and then not Is_Tagged_Type (Etype (Typ)) | |
5732 | then | |
5733 | return; | |
5734 | end if; | |
70482933 | 5735 | |
95fef24f AC |
5736 | -- Create and decorate the tags. Suppress their creation when |
5737 | -- not Tagged_Type_Expansion because the dispatching mechanism is | |
5738 | -- handled internally by the virtual target. | |
dda38714 | 5739 | |
95fef24f AC |
5740 | if Tagged_Type_Expansion then |
5741 | Append_Freeze_Actions (Typ, Make_Tags (Typ)); | |
dda38714 | 5742 | |
95fef24f AC |
5743 | -- Generate dispatch table of locally defined tagged type. |
5744 | -- Dispatch tables of library level tagged types are built | |
5a06e886 | 5745 | -- later (see Build_Static_Dispatch_Tables). |
dda38714 | 5746 | |
95fef24f AC |
5747 | if not Building_Static_DT (Typ) then |
5748 | Append_Freeze_Actions (Typ, Make_DT (Typ)); | |
475e1d24 JM |
5749 | |
5750 | -- Register dispatch table wrappers in the dispatch table. | |
5751 | -- It could not be done when these wrappers were built | |
5752 | -- because, at that stage, the dispatch table was not | |
5753 | -- available. | |
5754 | ||
5755 | Register_Dispatch_Table_Wrappers (Typ); | |
dda38714 | 5756 | end if; |
95fef24f | 5757 | end if; |
e606088a | 5758 | |
95fef24f AC |
5759 | -- If the type has unknown discriminants, propagate dispatching |
5760 | -- information to its underlying record view, which does not get | |
5761 | -- its own dispatch table. | |
de4899bb | 5762 | |
95fef24f AC |
5763 | if Is_Derived_Type (Typ) |
5764 | and then Has_Unknown_Discriminants (Typ) | |
5765 | and then Present (Underlying_Record_View (Typ)) | |
de4899bb | 5766 | then |
95fef24f AC |
5767 | declare |
5768 | Rep : constant Entity_Id := Underlying_Record_View (Typ); | |
5769 | begin | |
5770 | Set_Access_Disp_Table | |
5771 | (Rep, Access_Disp_Table (Typ)); | |
5772 | Set_Dispatch_Table_Wrappers | |
5773 | (Rep, Dispatch_Table_Wrappers (Typ)); | |
5774 | Set_Direct_Primitive_Operations | |
5775 | (Rep, Direct_Primitive_Operations (Typ)); | |
5776 | end; | |
5777 | end if; | |
5778 | ||
5779 | -- Make sure that the primitives Initialize, Adjust and Finalize | |
5780 | -- are Frozen before other TSS subprograms. We don't want them | |
5781 | -- Frozen inside. | |
5782 | ||
5783 | if Is_Controlled (Typ) then | |
5784 | if not Is_Limited_Type (Typ) then | |
5785 | Append_Freeze_Actions (Typ, | |
5786 | Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ)); | |
07a64c02 AC |
5787 | end if; |
5788 | ||
95fef24f AC |
5789 | Append_Freeze_Actions (Typ, |
5790 | Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ)); | |
5791 | ||
5792 | Append_Freeze_Actions (Typ, | |
5793 | Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ)); | |
5794 | end if; | |
5795 | ||
5796 | -- Freeze rest of primitive operations. There is no need to handle | |
5797 | -- the predefined primitives if we are compiling under restriction | |
5798 | -- No_Dispatching_Calls. | |
5799 | ||
5800 | if not Restriction_Active (No_Dispatching_Calls) then | |
5801 | Append_Freeze_Actions (Typ, Predefined_Primitive_Freeze (Typ)); | |
de4899bb | 5802 | end if; |
e606088a AC |
5803 | end if; |
5804 | ||
95fef24f AC |
5805 | -- In the untagged case, ever since Ada 83 an equality function must |
5806 | -- be provided for variant records that are not unchecked unions. | |
5807 | -- In Ada 2012 the equality function composes, and thus must be built | |
5808 | -- explicitly just as for tagged records. | |
70482933 | 5809 | |
95fef24f AC |
5810 | elsif Has_Discriminants (Typ) |
5811 | and then not Is_Limited_Type (Typ) | |
5812 | then | |
5813 | declare | |
5814 | Comps : constant Node_Id := | |
5815 | Component_List (Type_Definition (Typ_Decl)); | |
5816 | begin | |
5817 | if Present (Comps) | |
5818 | and then Present (Variant_Part (Comps)) | |
5819 | then | |
5820 | Build_Variant_Record_Equality (Typ); | |
5821 | end if; | |
5822 | end; | |
758c442c | 5823 | |
95fef24f | 5824 | -- Otherwise create primitive equality operation (AI05-0123) |
a05e99a2 | 5825 | |
95fef24f AC |
5826 | -- This is done unconditionally to ensure that tools can be linked |
5827 | -- properly with user programs compiled with older language versions. | |
5828 | -- In addition, this is needed because "=" composes for bounded strings | |
5829 | -- in all language versions (see Exp_Ch4.Expand_Composite_Equality). | |
a05e99a2 | 5830 | |
95fef24f AC |
5831 | elsif Comes_From_Source (Typ) |
5832 | and then Convention (Typ) = Convention_Ada | |
5833 | and then not Is_Limited_Type (Typ) | |
5834 | then | |
5835 | Build_Untagged_Equality (Typ); | |
5836 | end if; | |
758c442c | 5837 | |
95fef24f AC |
5838 | -- Before building the record initialization procedure, if we are |
5839 | -- dealing with a concurrent record value type, then we must go through | |
5840 | -- the discriminants, exchanging discriminals between the concurrent | |
5841 | -- type and the concurrent record value type. See the section "Handling | |
5842 | -- of Discriminants" in the Einfo spec for details. | |
70482933 | 5843 | |
95fef24f AC |
5844 | if Is_Concurrent_Record_Type (Typ) |
5845 | and then Has_Discriminants (Typ) | |
5846 | then | |
5847 | declare | |
5848 | Ctyp : constant Entity_Id := | |
5849 | Corresponding_Concurrent_Type (Typ); | |
5850 | Conc_Discr : Entity_Id; | |
5851 | Rec_Discr : Entity_Id; | |
5852 | Temp : Entity_Id; | |
70482933 | 5853 | |
95fef24f AC |
5854 | begin |
5855 | Conc_Discr := First_Discriminant (Ctyp); | |
5856 | Rec_Discr := First_Discriminant (Typ); | |
5857 | while Present (Conc_Discr) loop | |
5858 | Temp := Discriminal (Conc_Discr); | |
5859 | Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); | |
5860 | Set_Discriminal (Rec_Discr, Temp); | |
70482933 | 5861 | |
95fef24f AC |
5862 | Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); |
5863 | Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); | |
70482933 | 5864 | |
95fef24f AC |
5865 | Next_Discriminant (Conc_Discr); |
5866 | Next_Discriminant (Rec_Discr); | |
5867 | end loop; | |
5868 | end; | |
5869 | end if; | |
70482933 | 5870 | |
95fef24f AC |
5871 | if Has_Controlled_Component (Typ) then |
5872 | Build_Controlling_Procs (Typ); | |
5873 | end if; | |
3476f949 | 5874 | |
95fef24f | 5875 | Adjust_Discriminants (Typ); |
3476f949 | 5876 | |
95fef24f AC |
5877 | -- Do not need init for interfaces on virtual targets since they're |
5878 | -- abstract. | |
9fbb3ae6 | 5879 | |
95fef24f AC |
5880 | if Tagged_Type_Expansion or else not Is_Interface (Typ) then |
5881 | Build_Record_Init_Proc (Typ_Decl, Typ); | |
5882 | end if; | |
9fbb3ae6 | 5883 | |
95fef24f AC |
5884 | -- For tagged type that are not interfaces, build bodies of primitive |
5885 | -- operations. Note: do this after building the record initialization | |
5886 | -- procedure, since the primitive operations may need the initialization | |
5887 | -- routine. There is no need to add predefined primitives of interfaces | |
5888 | -- because all their predefined primitives are abstract. | |
0e41a941 | 5889 | |
95fef24f | 5890 | if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then |
8e983d80 | 5891 | |
95fef24f AC |
5892 | -- Do not add the body of predefined primitives in case of CPP tagged |
5893 | -- type derivations that have convention CPP. | |
8e983d80 | 5894 | |
95fef24f AC |
5895 | if Is_CPP_Class (Root_Type (Typ)) |
5896 | and then Convention (Typ) = Convention_CPP | |
0e41a941 | 5897 | then |
95fef24f | 5898 | null; |
0e41a941 | 5899 | |
95fef24f AC |
5900 | -- Do not add the body of the predefined primitives if we are |
5901 | -- compiling under restriction No_Dispatching_Calls or if we are | |
5902 | -- compiling a CPP tagged type. | |
dfcfdc0a | 5903 | |
95fef24f | 5904 | elsif not Restriction_Active (No_Dispatching_Calls) then |
dfcfdc0a | 5905 | |
95fef24f AC |
5906 | -- Create the body of TSS primitive Finalize_Address. This must |
5907 | -- be done before the bodies of all predefined primitives are | |
5908 | -- created. If Typ is limited, Stream_Input and Stream_Read may | |
5909 | -- produce build-in-place allocations and for those the expander | |
5910 | -- needs Finalize_Address. | |
0e41a941 | 5911 | |
95fef24f AC |
5912 | Make_Finalize_Address_Body (Typ); |
5913 | Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq); | |
5914 | Append_Freeze_Actions (Typ, Predef_List); | |
5915 | end if; | |
0e41a941 | 5916 | |
95fef24f AC |
5917 | -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden |
5918 | -- inherited functions, then add their bodies to the freeze actions. | |
0e41a941 | 5919 | |
ec9c3bd5 | 5920 | Append_Freeze_Actions (Typ, Wrapper_Body_List); |
f1668c3d | 5921 | end if; |
0e41a941 | 5922 | |
f1668c3d JM |
5923 | -- Create extra formals for the primitive operations of the type. |
5924 | -- This must be done before analyzing the body of the initialization | |
5925 | -- procedure, because a self-referential type might call one of these | |
5926 | -- primitives in the body of the init_proc itself. | |
5927 | -- | |
5928 | -- This is not needed: | |
5929 | -- 1) If expansion is disabled, because extra formals are only added | |
5930 | -- when we are generating code. | |
5931 | -- | |
5932 | -- 2) For types with foreign convention since primitives with foreign | |
5933 | -- convention don't have extra formals and AI95-117 requires that | |
5934 | -- all primitives of a tagged type inherit the convention. | |
0e41a941 | 5935 | |
f1668c3d JM |
5936 | if Expander_Active |
5937 | and then Is_Tagged_Type (Typ) | |
5938 | and then not Has_Foreign_Convention (Typ) | |
5939 | then | |
95fef24f AC |
5940 | declare |
5941 | Elmt : Elmt_Id; | |
f1668c3d | 5942 | E : Entity_Id; |
0e41a941 | 5943 | |
95fef24f | 5944 | begin |
f1668c3d JM |
5945 | -- Add extra formals to primitive operations |
5946 | ||
95fef24f AC |
5947 | Elmt := First_Elmt (Primitive_Operations (Typ)); |
5948 | while Present (Elmt) loop | |
f1668c3d JM |
5949 | Create_Extra_Formals (Node (Elmt)); |
5950 | Next_Elmt (Elmt); | |
5951 | end loop; | |
5952 | ||
5953 | -- Add extra formals to renamings of primitive operations. The | |
5954 | -- addition of extra formals is done in two steps to minimize | |
5955 | -- the compile time required for this action; the evaluation of | |
5956 | -- Find_Dispatching_Type() and Contains() is only done here for | |
5957 | -- renamings that are not primitive operations. | |
5958 | ||
5959 | E := First_Entity (Scope (Typ)); | |
5960 | while Present (E) loop | |
5961 | if Is_Dispatching_Operation (E) | |
5962 | and then Present (Alias (E)) | |
5963 | and then Find_Dispatching_Type (E) = Typ | |
5964 | and then not Contains (Primitive_Operations (Typ), E) | |
95fef24f | 5965 | then |
f1668c3d | 5966 | Create_Extra_Formals (E); |
95fef24f | 5967 | end if; |
0e41a941 | 5968 | |
f1668c3d | 5969 | Next_Entity (E); |
95fef24f | 5970 | end loop; |
f1668c3d JM |
5971 | |
5972 | pragma Debug (Validate_Tagged_Type_Extra_Formals (Typ)); | |
95fef24f | 5973 | end; |
95fef24f | 5974 | end if; |
475e1d24 JM |
5975 | |
5976 | -- Build internal subprograms of primitives with class-wide | |
5977 | -- pre/postconditions. | |
5978 | ||
5979 | if Is_Tagged_Type (Typ) then | |
5980 | Build_Class_Condition_Subprograms (Typ); | |
5981 | end if; | |
95fef24f | 5982 | end Expand_Freeze_Record_Type; |
0e41a941 | 5983 | |
95fef24f AC |
5984 | ------------------------------------ |
5985 | -- Expand_N_Full_Type_Declaration -- | |
5986 | ------------------------------------ | |
0e41a941 | 5987 | |
95fef24f AC |
5988 | procedure Expand_N_Full_Type_Declaration (N : Node_Id) is |
5989 | procedure Build_Master (Ptr_Typ : Entity_Id); | |
5990 | -- Create the master associated with Ptr_Typ | |
d2d9cc22 | 5991 | |
95fef24f AC |
5992 | ------------------ |
5993 | -- Build_Master -- | |
5994 | ------------------ | |
70482933 | 5995 | |
95fef24f AC |
5996 | procedure Build_Master (Ptr_Typ : Entity_Id) is |
5997 | Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ); | |
70482933 | 5998 | |
95fef24f AC |
5999 | begin |
6000 | -- If the designated type is an incomplete view coming from a | |
6001 | -- limited-with'ed package, we need to use the nonlimited view in | |
6002 | -- case it has tasks. | |
70482933 | 6003 | |
2db2527a | 6004 | if Is_Incomplete_Type (Desig_Typ) |
95fef24f AC |
6005 | and then Present (Non_Limited_View (Desig_Typ)) |
6006 | then | |
6007 | Desig_Typ := Non_Limited_View (Desig_Typ); | |
6008 | end if; | |
199c6a10 | 6009 | |
95fef24f AC |
6010 | -- Anonymous access types are created for the components of the |
6011 | -- record parameter for an entry declaration. No master is created | |
6012 | -- for such a type. | |
199c6a10 | 6013 | |
a7837c08 | 6014 | if Has_Task (Desig_Typ) then |
95fef24f AC |
6015 | Build_Master_Entity (Ptr_Typ); |
6016 | Build_Master_Renaming (Ptr_Typ); | |
d79e621a | 6017 | |
95fef24f AC |
6018 | -- Create a class-wide master because a Master_Id must be generated |
6019 | -- for access-to-limited-class-wide types whose root may be extended | |
6020 | -- with task components. | |
d79e621a | 6021 | |
95fef24f AC |
6022 | -- Note: This code covers access-to-limited-interfaces because they |
6023 | -- can be used to reference tasks implementing them. | |
c7532b2d | 6024 | |
830c5948 GD |
6025 | -- Suppress the master creation for access types created for entry |
6026 | -- formal parameters (parameter block component types). Seems like | |
6027 | -- suppression should be more general for compiler-generated types, | |
a7837c08 JM |
6028 | -- but testing Comes_From_Source may be too general in this case |
6029 | -- (affects some test output)??? | |
830c5948 GD |
6030 | |
6031 | elsif not Is_Param_Block_Component_Type (Ptr_Typ) | |
6032 | and then Is_Limited_Class_Wide_Type (Desig_Typ) | |
95fef24f AC |
6033 | then |
6034 | Build_Class_Wide_Master (Ptr_Typ); | |
6035 | end if; | |
6036 | end Build_Master; | |
edab6088 | 6037 | |
95fef24f | 6038 | -- Local declarations |
edab6088 | 6039 | |
95fef24f AC |
6040 | Def_Id : constant Entity_Id := Defining_Identifier (N); |
6041 | B_Id : constant Entity_Id := Base_Type (Def_Id); | |
6042 | FN : Node_Id; | |
6043 | Par_Id : Entity_Id; | |
edab6088 | 6044 | |
95fef24f | 6045 | -- Start of processing for Expand_N_Full_Type_Declaration |
70482933 | 6046 | |
95fef24f AC |
6047 | begin |
6048 | if Is_Access_Type (Def_Id) then | |
6049 | Build_Master (Def_Id); | |
70482933 | 6050 | |
95fef24f AC |
6051 | if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then |
6052 | Expand_Access_Protected_Subprogram_Type (N); | |
6053 | end if; | |
cc9b1e1c | 6054 | |
95fef24f | 6055 | -- Array of anonymous access-to-task pointers |
cd2c6027 | 6056 | |
95fef24f AC |
6057 | elsif Ada_Version >= Ada_2005 |
6058 | and then Is_Array_Type (Def_Id) | |
6059 | and then Is_Access_Type (Component_Type (Def_Id)) | |
6060 | and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type | |
6061 | then | |
6062 | Build_Master (Component_Type (Def_Id)); | |
cd2c6027 | 6063 | |
95fef24f AC |
6064 | elsif Has_Task (Def_Id) then |
6065 | Expand_Previous_Access_Type (Def_Id); | |
70482933 | 6066 | |
95fef24f AC |
6067 | -- Check the components of a record type or array of records for |
6068 | -- anonymous access-to-task pointers. | |
f5037886 | 6069 | |
95fef24f AC |
6070 | elsif Ada_Version >= Ada_2005 |
6071 | and then (Is_Record_Type (Def_Id) | |
6072 | or else | |
6073 | (Is_Array_Type (Def_Id) | |
6074 | and then Is_Record_Type (Component_Type (Def_Id)))) | |
6075 | then | |
6076 | declare | |
6077 | Comp : Entity_Id; | |
6078 | First : Boolean; | |
a6b13d32 | 6079 | M_Id : Entity_Id := Empty; |
95fef24f | 6080 | Typ : Entity_Id; |
f5037886 | 6081 | |
95fef24f AC |
6082 | begin |
6083 | if Is_Array_Type (Def_Id) then | |
6084 | Comp := First_Entity (Component_Type (Def_Id)); | |
6085 | else | |
6086 | Comp := First_Entity (Def_Id); | |
6087 | end if; | |
236fecbf | 6088 | |
95fef24f AC |
6089 | -- Examine all components looking for anonymous access-to-task |
6090 | -- types. | |
236fecbf | 6091 | |
95fef24f AC |
6092 | First := True; |
6093 | while Present (Comp) loop | |
6094 | Typ := Etype (Comp); | |
236fecbf | 6095 | |
95fef24f | 6096 | if Ekind (Typ) = E_Anonymous_Access_Type |
95260403 JM |
6097 | and then Might_Have_Tasks |
6098 | (Available_View (Designated_Type (Typ))) | |
95fef24f AC |
6099 | and then No (Master_Id (Typ)) |
6100 | then | |
6101 | -- Ensure that the record or array type have a _master | |
236fecbf | 6102 | |
95fef24f AC |
6103 | if First then |
6104 | Build_Master_Entity (Def_Id); | |
6105 | Build_Master_Renaming (Typ); | |
6106 | M_Id := Master_Id (Typ); | |
236fecbf | 6107 | |
95fef24f | 6108 | First := False; |
adc876a8 | 6109 | |
95fef24f | 6110 | -- Reuse the same master to service any additional types |
adc876a8 | 6111 | |
95fef24f | 6112 | else |
a6b13d32 | 6113 | pragma Assert (Present (M_Id)); |
95fef24f AC |
6114 | Set_Master_Id (Typ, M_Id); |
6115 | end if; | |
6116 | end if; | |
adc876a8 | 6117 | |
95fef24f AC |
6118 | Next_Entity (Comp); |
6119 | end loop; | |
6120 | end; | |
6121 | end if; | |
adc876a8 | 6122 | |
95fef24f | 6123 | Par_Id := Etype (B_Id); |
adc876a8 | 6124 | |
95fef24f AC |
6125 | -- The parent type is private then we need to inherit any TSS operations |
6126 | -- from the full view. | |
70482933 | 6127 | |
131c9aff | 6128 | if Is_Private_Type (Par_Id) |
95fef24f AC |
6129 | and then Present (Full_View (Par_Id)) |
6130 | then | |
6131 | Par_Id := Base_Type (Full_View (Par_Id)); | |
6132 | end if; | |
fbf5a39b | 6133 | |
42fe7c9a | 6134 | if Nkind (Type_Definition (N)) = N_Derived_Type_Definition |
95fef24f AC |
6135 | and then not Is_Tagged_Type (Def_Id) |
6136 | and then Present (Freeze_Node (Par_Id)) | |
6137 | and then Present (TSS_Elist (Freeze_Node (Par_Id))) | |
6138 | then | |
6139 | Ensure_Freeze_Node (B_Id); | |
6140 | FN := Freeze_Node (B_Id); | |
fbf5a39b | 6141 | |
95fef24f AC |
6142 | if No (TSS_Elist (FN)) then |
6143 | Set_TSS_Elist (FN, New_Elmt_List); | |
6144 | end if; | |
2820d220 | 6145 | |
95fef24f AC |
6146 | declare |
6147 | T_E : constant Elist_Id := TSS_Elist (FN); | |
6148 | Elmt : Elmt_Id; | |
2820d220 | 6149 | |
95fef24f AC |
6150 | begin |
6151 | Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id))); | |
6152 | while Present (Elmt) loop | |
6153 | if Chars (Node (Elmt)) /= Name_uInit then | |
6154 | Append_Elmt (Node (Elmt), T_E); | |
fbf5a39b | 6155 | end if; |
70482933 | 6156 | |
95fef24f AC |
6157 | Next_Elmt (Elmt); |
6158 | end loop; | |
70482933 | 6159 | |
95fef24f AC |
6160 | -- If the derived type itself is private with a full view, then |
6161 | -- associate the full view with the inherited TSS_Elist as well. | |
6162 | ||
131c9aff | 6163 | if Is_Private_Type (B_Id) |
95fef24f | 6164 | and then Present (Full_View (B_Id)) |
70482933 | 6165 | then |
95fef24f AC |
6166 | Ensure_Freeze_Node (Base_Type (Full_View (B_Id))); |
6167 | Set_TSS_Elist | |
6168 | (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN)); | |
70482933 | 6169 | end if; |
95fef24f AC |
6170 | end; |
6171 | end if; | |
6172 | end Expand_N_Full_Type_Declaration; | |
fbf5a39b | 6173 | |
95fef24f AC |
6174 | --------------------------------- |
6175 | -- Expand_N_Object_Declaration -- | |
6176 | --------------------------------- | |
fbf5a39b | 6177 | |
95fef24f AC |
6178 | procedure Expand_N_Object_Declaration (N : Node_Id) is |
6179 | Loc : constant Source_Ptr := Sloc (N); | |
6180 | Def_Id : constant Entity_Id := Defining_Identifier (N); | |
6181 | Expr : constant Node_Id := Expression (N); | |
6182 | Obj_Def : constant Node_Id := Object_Definition (N); | |
6183 | Typ : constant Entity_Id := Etype (Def_Id); | |
6184 | Base_Typ : constant Entity_Id := Base_Type (Typ); | |
aa683f5c | 6185 | Next_N : constant Node_Id := Next (N); |
d1f453b7 | 6186 | |
8313c5f6 EB |
6187 | Special_Ret_Obj : constant Boolean := Is_Special_Return_Object (Def_Id); |
6188 | -- If this is a special return object, it will be allocated differently | |
6189 | -- and ultimately rewritten as a renaming, so initialization activities | |
6190 | -- need to be deferred until after that is done. | |
6191 | ||
133a8e63 EB |
6192 | Func_Id : constant Entity_Id := |
6193 | (if Special_Ret_Obj then Return_Applies_To (Scope (Def_Id)) else Empty); | |
6194 | -- The function if this is a special return object, otherwise Empty | |
6195 | ||
95fef24f AC |
6196 | function Build_Equivalent_Aggregate return Boolean; |
6197 | -- If the object has a constrained discriminated type and no initial | |
6198 | -- value, it may be possible to build an equivalent aggregate instead, | |
6199 | -- and prevent an actual call to the initialization procedure. | |
d1f453b7 | 6200 | |
4844a259 EB |
6201 | function Build_Heap_Or_Pool_Allocator |
6202 | (Temp_Id : Entity_Id; | |
6203 | Temp_Typ : Entity_Id; | |
4844a259 EB |
6204 | Ret_Typ : Entity_Id; |
6205 | Alloc_Expr : Node_Id) return Node_Id; | |
6206 | -- Create the statements necessary to allocate a return object on the | |
6207 | -- heap or user-defined storage pool. The object may need finalization | |
6208 | -- actions depending on the return type. | |
6209 | -- | |
6210 | -- * Controlled case | |
6211 | -- | |
6212 | -- if BIPfinalizationmaster = null then | |
6213 | -- Temp_Id := <Alloc_Expr>; | |
6214 | -- else | |
6215 | -- declare | |
6216 | -- type Ptr_Typ is access Ret_Typ; | |
6217 | -- for Ptr_Typ'Storage_Pool use | |
6218 | -- Base_Pool (BIPfinalizationmaster.all).all; | |
6219 | -- Local : Ptr_Typ; | |
6220 | -- | |
6221 | -- begin | |
6222 | -- procedure Allocate (...) is | |
6223 | -- begin | |
6224 | -- System.Storage_Pools.Subpools.Allocate_Any (...); | |
6225 | -- end Allocate; | |
6226 | -- | |
6227 | -- Local := <Alloc_Expr>; | |
6228 | -- Temp_Id := Temp_Typ (Local); | |
6229 | -- end; | |
6230 | -- end if; | |
6231 | -- | |
6232 | -- * Non-controlled case | |
6233 | -- | |
6234 | -- Temp_Id := <Alloc_Expr>; | |
6235 | -- | |
6236 | -- Temp_Id is the temporary which is used to reference the internally | |
6237 | -- created object in all allocation forms. Temp_Typ is the type of the | |
6238 | -- temporary. Func_Id is the enclosing function. Ret_Typ is the return | |
6239 | -- type of Func_Id. Alloc_Expr is the actual allocator. | |
6240 | ||
bad0a3df PMR |
6241 | procedure Count_Default_Sized_Task_Stacks |
6242 | (Typ : Entity_Id; | |
6243 | Pri_Stacks : out Int; | |
6244 | Sec_Stacks : out Int); | |
6245 | -- Count the number of default-sized primary and secondary task stacks | |
6246 | -- required for task objects contained within type Typ. If the number of | |
6247 | -- task objects contained within the type is not known at compile time | |
6248 | -- the procedure will return the stack counts of zero. | |
6249 | ||
95fef24f AC |
6250 | procedure Default_Initialize_Object (After : Node_Id); |
6251 | -- Generate all default initialization actions for object Def_Id. Any | |
6252 | -- new code is inserted after node After. | |
d1f453b7 | 6253 | |
ea588d41 EB |
6254 | procedure Initialize_Return_Object |
6255 | (Tag_Assign : Node_Id; | |
6256 | Adj_Call : Node_Id; | |
6257 | Expr : Node_Id; | |
6258 | Init_Stmt : Node_Id; | |
6259 | After : Node_Id); | |
6260 | -- Generate all initialization actions for return object Def_Id. Any | |
6261 | -- new code is inserted after node After. | |
6262 | ||
8daf80ff EB |
6263 | function Is_Renamable_Function_Call (Expr : Node_Id) return Boolean; |
6264 | -- If we are not at library level and the object declaration originally | |
6265 | -- appears in the form: | |
6266 | ||
6267 | -- Obj : Typ := Func (...); | |
6268 | ||
6269 | -- and has been rewritten as the dereference of a captured reference | |
6270 | -- to the function result built either on the primary or the secondary | |
6271 | -- stack, then the declaration can be rewritten as the renaming of this | |
6272 | -- dereference: | |
6273 | ||
6274 | -- type Ann is access all Typ; | |
6275 | -- Rnn : constant Axx := Func (...)'reference; | |
6276 | -- Obj : Typ renames Rnn.all; | |
6277 | ||
6278 | -- This will avoid making an extra copy and, in the case where Typ needs | |
6279 | -- finalization, a pair of calls to the Adjust and Finalize primitives, | |
6280 | -- or Deep_Adjust and Deep_Finalize routines, depending on whether Typ | |
6281 | -- has components that themselves need finalization. | |
6282 | ||
6283 | -- However, in the case of a special return object, we need to make sure | |
6284 | -- that the object Rnn is recognized by the Is_Related_To_Func_Return | |
6285 | -- predicate; otherwise, if it is of a type that needs finalization, | |
6286 | -- then Requires_Cleanup_Actions would return true because of this and | |
6287 | -- Build_Finalizer would finalize it prematurely because of this (see | |
6288 | -- also Expand_Simple_Function_Return for the same test in the case of | |
6289 | -- a simple return). | |
6290 | ||
6291 | -- Finally, in the case of a special return object, we also need to make | |
6292 | -- sure that the two functions return on the same stack, otherwise we | |
6293 | -- would create a dangling reference. | |
6294 | ||
ea588d41 EB |
6295 | function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id; |
6296 | -- Make an allocator for a return object initialized with Expr | |
6297 | ||
aa683f5c EB |
6298 | function OK_To_Rename_Ref (N : Node_Id) return Boolean; |
6299 | -- Return True if N denotes an entity with OK_To_Rename set | |
d1f453b7 | 6300 | |
95fef24f AC |
6301 | -------------------------------- |
6302 | -- Build_Equivalent_Aggregate -- | |
6303 | -------------------------------- | |
d1f453b7 | 6304 | |
95fef24f AC |
6305 | function Build_Equivalent_Aggregate return Boolean is |
6306 | Aggr : Node_Id; | |
6307 | Comp : Entity_Id; | |
6308 | Discr : Elmt_Id; | |
6309 | Full_Type : Entity_Id; | |
d1f453b7 | 6310 | |
95fef24f AC |
6311 | begin |
6312 | Full_Type := Typ; | |
d1f453b7 | 6313 | |
95fef24f AC |
6314 | if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then |
6315 | Full_Type := Full_View (Typ); | |
6316 | end if; | |
d1f453b7 | 6317 | |
95fef24f AC |
6318 | -- Only perform this transformation if Elaboration_Code is forbidden |
6319 | -- or undesirable, and if this is a global entity of a constrained | |
6320 | -- record type. | |
e526d0c7 | 6321 | |
95fef24f AC |
6322 | -- If Initialize_Scalars might be active this transformation cannot |
6323 | -- be performed either, because it will lead to different semantics | |
6324 | -- or because elaboration code will in fact be created. | |
e526d0c7 | 6325 | |
95fef24f AC |
6326 | if Ekind (Full_Type) /= E_Record_Subtype |
6327 | or else not Has_Discriminants (Full_Type) | |
6328 | or else not Is_Constrained (Full_Type) | |
6329 | or else Is_Controlled (Full_Type) | |
6330 | or else Is_Limited_Type (Full_Type) | |
6331 | or else not Restriction_Active (No_Initialize_Scalars) | |
6332 | then | |
6333 | return False; | |
6334 | end if; | |
e526d0c7 | 6335 | |
95fef24f AC |
6336 | if Ekind (Current_Scope) = E_Package |
6337 | and then | |
6338 | (Restriction_Active (No_Elaboration_Code) | |
6339 | or else Is_Preelaborated (Current_Scope)) | |
6340 | then | |
6341 | -- Building a static aggregate is possible if the discriminants | |
6342 | -- have static values and the other components have static | |
6343 | -- defaults or none. | |
e526d0c7 | 6344 | |
95fef24f AC |
6345 | Discr := First_Elmt (Discriminant_Constraint (Full_Type)); |
6346 | while Present (Discr) loop | |
6347 | if not Is_OK_Static_Expression (Node (Discr)) then | |
6348 | return False; | |
6349 | end if; | |
6350 | ||
6351 | Next_Elmt (Discr); | |
6352 | end loop; | |
6353 | ||
6354 | -- Check that initialized components are OK, and that non- | |
6355 | -- initialized components do not require a call to their own | |
6356 | -- initialization procedure. | |
6357 | ||
6358 | Comp := First_Component (Full_Type); | |
6359 | while Present (Comp) loop | |
04598eb0 | 6360 | if Present (Expression (Parent (Comp))) |
95fef24f AC |
6361 | and then |
6362 | not Is_OK_Static_Expression (Expression (Parent (Comp))) | |
6363 | then | |
6364 | return False; | |
6365 | ||
6366 | elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then | |
6367 | return False; | |
e526d0c7 | 6368 | |
e526d0c7 | 6369 | end if; |
70482933 | 6370 | |
95fef24f AC |
6371 | Next_Component (Comp); |
6372 | end loop; | |
d15f9422 | 6373 | |
95fef24f AC |
6374 | -- Everything is static, assemble the aggregate, discriminant |
6375 | -- values first. | |
d15f9422 | 6376 | |
95fef24f AC |
6377 | Aggr := |
6378 | Make_Aggregate (Loc, | |
6379 | Expressions => New_List, | |
6380 | Component_Associations => New_List); | |
996c8821 | 6381 | |
95fef24f AC |
6382 | Discr := First_Elmt (Discriminant_Constraint (Full_Type)); |
6383 | while Present (Discr) loop | |
6384 | Append_To (Expressions (Aggr), New_Copy (Node (Discr))); | |
6385 | Next_Elmt (Discr); | |
6386 | end loop; | |
996c8821 | 6387 | |
95fef24f | 6388 | -- Now collect values of initialized components |
d15f9422 | 6389 | |
95fef24f AC |
6390 | Comp := First_Component (Full_Type); |
6391 | while Present (Comp) loop | |
04598eb0 | 6392 | if Present (Expression (Parent (Comp))) then |
95fef24f AC |
6393 | Append_To (Component_Associations (Aggr), |
6394 | Make_Component_Association (Loc, | |
6395 | Choices => New_List (New_Occurrence_Of (Comp, Loc)), | |
6396 | Expression => New_Copy_Tree | |
6397 | (Expression (Parent (Comp))))); | |
6398 | end if; | |
996c8821 | 6399 | |
95fef24f AC |
6400 | Next_Component (Comp); |
6401 | end loop; | |
996c8821 | 6402 | |
95fef24f AC |
6403 | -- Finally, box-initialize remaining components |
6404 | ||
6405 | Append_To (Component_Associations (Aggr), | |
6406 | Make_Component_Association (Loc, | |
6407 | Choices => New_List (Make_Others_Choice (Loc)), | |
6408 | Expression => Empty)); | |
6409 | Set_Box_Present (Last (Component_Associations (Aggr))); | |
6410 | Set_Expression (N, Aggr); | |
996c8821 | 6411 | |
95fef24f AC |
6412 | if Typ /= Full_Type then |
6413 | Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type))); | |
6414 | Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr)); | |
6415 | Analyze_And_Resolve (Aggr, Typ); | |
d15f9422 | 6416 | else |
95fef24f | 6417 | Analyze_And_Resolve (Aggr, Full_Type); |
d15f9422 AC |
6418 | end if; |
6419 | ||
95fef24f | 6420 | return True; |
d15f9422 | 6421 | |
95fef24f AC |
6422 | else |
6423 | return False; | |
6424 | end if; | |
6425 | end Build_Equivalent_Aggregate; | |
d15f9422 | 6426 | |
4844a259 EB |
6427 | ---------------------------------- |
6428 | -- Build_Heap_Or_Pool_Allocator -- | |
6429 | ---------------------------------- | |
6430 | ||
6431 | function Build_Heap_Or_Pool_Allocator | |
6432 | (Temp_Id : Entity_Id; | |
6433 | Temp_Typ : Entity_Id; | |
4844a259 EB |
6434 | Ret_Typ : Entity_Id; |
6435 | Alloc_Expr : Node_Id) return Node_Id | |
6436 | is | |
6437 | begin | |
6438 | pragma Assert (Is_Build_In_Place_Function (Func_Id)); | |
6439 | ||
6440 | -- Processing for objects that require finalization actions | |
6441 | ||
6442 | if Needs_Finalization (Ret_Typ) then | |
6443 | declare | |
6444 | Decls : constant List_Id := New_List; | |
6445 | Fin_Mas_Id : constant Entity_Id := | |
6446 | Build_In_Place_Formal (Func_Id, BIP_Finalization_Master); | |
6447 | Orig_Expr : constant Node_Id := New_Copy_Tree (Alloc_Expr); | |
6448 | Stmts : constant List_Id := New_List; | |
6449 | Local_Id : Entity_Id; | |
6450 | Pool_Id : Entity_Id; | |
6451 | Ptr_Typ : Entity_Id; | |
6452 | ||
6453 | begin | |
6454 | -- Generate: | |
6455 | -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all; | |
6456 | ||
6457 | Pool_Id := Make_Temporary (Loc, 'P'); | |
6458 | ||
6459 | Append_To (Decls, | |
6460 | Make_Object_Renaming_Declaration (Loc, | |
6461 | Defining_Identifier => Pool_Id, | |
6462 | Subtype_Mark => | |
6463 | New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc), | |
6464 | Name => | |
6465 | Make_Explicit_Dereference (Loc, | |
6466 | Prefix => | |
6467 | Make_Function_Call (Loc, | |
6468 | Name => | |
6469 | New_Occurrence_Of (RTE (RE_Base_Pool), Loc), | |
6470 | Parameter_Associations => New_List ( | |
6471 | Make_Explicit_Dereference (Loc, | |
6472 | Prefix => | |
6473 | New_Occurrence_Of (Fin_Mas_Id, Loc))))))); | |
6474 | ||
6475 | -- Create an access type which uses the storage pool of the | |
6476 | -- caller's master. This additional type is necessary because | |
6477 | -- the finalization master cannot be associated with the type | |
6478 | -- of the temporary. Otherwise the secondary stack allocation | |
6479 | -- will fail. | |
6480 | ||
6481 | -- Generate: | |
6482 | -- type Ptr_Typ is access Ret_Typ; | |
6483 | ||
6484 | Ptr_Typ := Make_Temporary (Loc, 'P'); | |
6485 | ||
6486 | Append_To (Decls, | |
6487 | Make_Full_Type_Declaration (Loc, | |
6488 | Defining_Identifier => Ptr_Typ, | |
6489 | Type_Definition => | |
6490 | Make_Access_To_Object_Definition (Loc, | |
6491 | Subtype_Indication => | |
6492 | New_Occurrence_Of (Ret_Typ, Loc)))); | |
6493 | ||
6494 | -- Perform minor decoration in order to set the master and the | |
6495 | -- storage pool attributes. | |
6496 | ||
6497 | Mutate_Ekind (Ptr_Typ, E_Access_Type); | |
6498 | Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); | |
6499 | Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); | |
6500 | ||
6501 | -- Create the temporary, generate: | |
6502 | -- Local_Id : Ptr_Typ; | |
6503 | ||
6504 | Local_Id := Make_Temporary (Loc, 'T'); | |
6505 | ||
6506 | Append_To (Decls, | |
6507 | Make_Object_Declaration (Loc, | |
6508 | Defining_Identifier => Local_Id, | |
6509 | Object_Definition => | |
6510 | New_Occurrence_Of (Ptr_Typ, Loc))); | |
6511 | ||
6512 | -- Allocate the object, generate: | |
6513 | -- Local_Id := <Alloc_Expr>; | |
6514 | ||
6515 | Append_To (Stmts, | |
6516 | Make_Assignment_Statement (Loc, | |
6517 | Name => New_Occurrence_Of (Local_Id, Loc), | |
6518 | Expression => Alloc_Expr)); | |
6519 | ||
6520 | -- Generate: | |
6521 | -- Temp_Id := Temp_Typ (Local_Id); | |
6522 | ||
6523 | Append_To (Stmts, | |
6524 | Make_Assignment_Statement (Loc, | |
6525 | Name => New_Occurrence_Of (Temp_Id, Loc), | |
6526 | Expression => | |
6527 | Unchecked_Convert_To (Temp_Typ, | |
6528 | New_Occurrence_Of (Local_Id, Loc)))); | |
6529 | ||
6530 | -- Wrap the allocation in a block. This is further conditioned | |
6531 | -- by checking the caller finalization master at runtime. A | |
6532 | -- null value indicates a non-existent master, most likely due | |
6533 | -- to a Finalize_Storage_Only allocation. | |
6534 | ||
6535 | -- Generate: | |
6536 | -- if BIPfinalizationmaster = null then | |
6537 | -- Temp_Id := <Orig_Expr>; | |
6538 | -- else | |
6539 | -- declare | |
6540 | -- <Decls> | |
6541 | -- begin | |
6542 | -- <Stmts> | |
6543 | -- end; | |
6544 | -- end if; | |
6545 | ||
6546 | return | |
6547 | Make_If_Statement (Loc, | |
6548 | Condition => | |
6549 | Make_Op_Eq (Loc, | |
6550 | Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc), | |
6551 | Right_Opnd => Make_Null (Loc)), | |
6552 | ||
6553 | Then_Statements => New_List ( | |
6554 | Make_Assignment_Statement (Loc, | |
6555 | Name => New_Occurrence_Of (Temp_Id, Loc), | |
6556 | Expression => Orig_Expr)), | |
6557 | ||
6558 | Else_Statements => New_List ( | |
6559 | Make_Block_Statement (Loc, | |
6560 | Declarations => Decls, | |
6561 | Handled_Statement_Sequence => | |
6562 | Make_Handled_Sequence_Of_Statements (Loc, | |
6563 | Statements => Stmts)))); | |
6564 | end; | |
6565 | ||
6566 | -- For all other cases, generate: | |
6567 | -- Temp_Id := <Alloc_Expr>; | |
6568 | ||
6569 | else | |
6570 | return | |
6571 | Make_Assignment_Statement (Loc, | |
6572 | Name => New_Occurrence_Of (Temp_Id, Loc), | |
6573 | Expression => Alloc_Expr); | |
6574 | end if; | |
6575 | end Build_Heap_Or_Pool_Allocator; | |
6576 | ||
bad0a3df PMR |
6577 | ------------------------------------- |
6578 | -- Count_Default_Sized_Task_Stacks -- | |
6579 | ------------------------------------- | |
6580 | ||
6581 | procedure Count_Default_Sized_Task_Stacks | |
6582 | (Typ : Entity_Id; | |
6583 | Pri_Stacks : out Int; | |
6584 | Sec_Stacks : out Int) | |
6585 | is | |
6586 | Component : Entity_Id; | |
e201023c | 6587 | |
bad0a3df PMR |
6588 | begin |
6589 | -- To calculate the number of default-sized task stacks required for | |
6590 | -- an object of Typ, a depth-first recursive traversal of the AST | |
6591 | -- from the Typ entity node is undertaken. Only type nodes containing | |
6592 | -- task objects are visited. | |
6593 | ||
6594 | Pri_Stacks := 0; | |
6595 | Sec_Stacks := 0; | |
6596 | ||
6597 | if not Has_Task (Typ) then | |
6598 | return; | |
6599 | end if; | |
6600 | ||
6601 | case Ekind (Typ) is | |
e201023c PMR |
6602 | when E_Task_Subtype |
6603 | | E_Task_Type | |
bad0a3df PMR |
6604 | => |
6605 | -- A task type is found marking the bottom of the descent. If | |
6606 | -- the type has no representation aspect for the corresponding | |
6607 | -- stack then that stack is using the default size. | |
6608 | ||
6609 | if Present (Get_Rep_Item (Typ, Name_Storage_Size)) then | |
6610 | Pri_Stacks := 0; | |
6611 | else | |
6612 | Pri_Stacks := 1; | |
6613 | end if; | |
6614 | ||
6615 | if Present (Get_Rep_Item (Typ, Name_Secondary_Stack_Size)) then | |
6616 | Sec_Stacks := 0; | |
6617 | else | |
6618 | Sec_Stacks := 1; | |
6619 | end if; | |
6620 | ||
e201023c PMR |
6621 | when E_Array_Subtype |
6622 | | E_Array_Type | |
bad0a3df PMR |
6623 | => |
6624 | -- First find the number of default stacks contained within an | |
6625 | -- array component. | |
6626 | ||
6627 | Count_Default_Sized_Task_Stacks | |
6628 | (Component_Type (Typ), | |
6629 | Pri_Stacks, | |
6630 | Sec_Stacks); | |
6631 | ||
6632 | -- Then multiply the result by the size of the array | |
6633 | ||
6634 | declare | |
6635 | Quantity : constant Int := Number_Of_Elements_In_Array (Typ); | |
6636 | -- Number_Of_Elements_In_Array is non-trival, consequently | |
6637 | -- its result is captured as an optimization. | |
6638 | ||
6639 | begin | |
6640 | Pri_Stacks := Pri_Stacks * Quantity; | |
6641 | Sec_Stacks := Sec_Stacks * Quantity; | |
6642 | end; | |
6643 | ||
e201023c | 6644 | when E_Protected_Subtype |
bad0a3df | 6645 | | E_Protected_Type |
e201023c PMR |
6646 | | E_Record_Subtype |
6647 | | E_Record_Type | |
bad0a3df PMR |
6648 | => |
6649 | Component := First_Component_Or_Discriminant (Typ); | |
6650 | ||
6651 | -- Recursively descend each component of the composite type | |
6652 | -- looking for tasks, but only if the component is marked as | |
6653 | -- having a task. | |
6654 | ||
6655 | while Present (Component) loop | |
6656 | if Has_Task (Etype (Component)) then | |
6657 | declare | |
e201023c PMR |
6658 | P : Int; |
6659 | S : Int; | |
6660 | ||
bad0a3df PMR |
6661 | begin |
6662 | Count_Default_Sized_Task_Stacks | |
6663 | (Etype (Component), P, S); | |
6664 | Pri_Stacks := Pri_Stacks + P; | |
6665 | Sec_Stacks := Sec_Stacks + S; | |
6666 | end; | |
6667 | end if; | |
6668 | ||
6669 | Next_Component_Or_Discriminant (Component); | |
6670 | end loop; | |
6671 | ||
e201023c PMR |
6672 | when E_Limited_Private_Subtype |
6673 | | E_Limited_Private_Type | |
bad0a3df | 6674 | | E_Record_Subtype_With_Private |
e201023c | 6675 | | E_Record_Type_With_Private |
bad0a3df PMR |
6676 | => |
6677 | -- Switch to the full view of the private type to continue | |
6678 | -- search. | |
6679 | ||
6680 | Count_Default_Sized_Task_Stacks | |
6681 | (Full_View (Typ), Pri_Stacks, Sec_Stacks); | |
6682 | ||
6683 | -- Other types should not contain tasks | |
6684 | ||
6685 | when others => | |
6686 | raise Program_Error; | |
6687 | end case; | |
6688 | end Count_Default_Sized_Task_Stacks; | |
6689 | ||
95fef24f AC |
6690 | ------------------------------- |
6691 | -- Default_Initialize_Object -- | |
6692 | ------------------------------- | |
d15f9422 | 6693 | |
95fef24f AC |
6694 | procedure Default_Initialize_Object (After : Node_Id) is |
6695 | function New_Object_Reference return Node_Id; | |
6696 | -- Return a new reference to Def_Id with attributes Assignment_OK and | |
6697 | -- Must_Not_Freeze already set. | |
e477d718 | 6698 | |
529749b9 HK |
6699 | function Simple_Initialization_OK |
6700 | (Init_Typ : Entity_Id) return Boolean; | |
6701 | -- Determine whether object declaration N with entity Def_Id needs | |
6702 | -- simple initialization, assuming that it is of type Init_Typ. | |
6703 | ||
95fef24f AC |
6704 | -------------------------- |
6705 | -- New_Object_Reference -- | |
6706 | -------------------------- | |
e477d718 | 6707 | |
95fef24f AC |
6708 | function New_Object_Reference return Node_Id is |
6709 | Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc); | |
e477d718 | 6710 | |
e477d718 | 6711 | begin |
95fef24f AC |
6712 | -- The call to the type init proc or [Deep_]Finalize must not |
6713 | -- freeze the related object as the call is internally generated. | |
6714 | -- This way legal rep clauses that apply to the object will not be | |
6715 | -- flagged. Note that the initialization call may be removed if | |
6716 | -- pragma Import is encountered or moved to the freeze actions of | |
6717 | -- the object because of an address clause. | |
e477d718 | 6718 | |
95fef24f AC |
6719 | Set_Assignment_OK (Obj_Ref); |
6720 | Set_Must_Not_Freeze (Obj_Ref); | |
e477d718 | 6721 | |
95fef24f AC |
6722 | return Obj_Ref; |
6723 | end New_Object_Reference; | |
e477d718 | 6724 | |
529749b9 HK |
6725 | ------------------------------ |
6726 | -- Simple_Initialization_OK -- | |
6727 | ------------------------------ | |
6728 | ||
6729 | function Simple_Initialization_OK | |
6730 | (Init_Typ : Entity_Id) return Boolean | |
6731 | is | |
6732 | begin | |
6733 | -- Do not consider the object declaration if it comes with an | |
6734 | -- initialization expression, or is internal in which case it | |
6735 | -- will be assigned later. | |
6736 | ||
6737 | return | |
6738 | not Is_Internal (Def_Id) | |
6739 | and then not Has_Init_Expression (N) | |
6740 | and then Needs_Simple_Initialization | |
6741 | (Typ => Init_Typ, | |
6742 | Consider_IS => | |
6743 | Initialize_Scalars | |
6744 | and then No (Following_Address_Clause (N))); | |
6745 | end Simple_Initialization_OK; | |
6746 | ||
95fef24f | 6747 | -- Local variables |
e606088a | 6748 | |
7bf911b5 HK |
6749 | Exceptions_OK : constant Boolean := |
6750 | not Restriction_Active (No_Exception_Propagation); | |
6751 | ||
bb072d1c AC |
6752 | Aggr_Init : Node_Id; |
6753 | Comp_Init : List_Id := No_List; | |
90e491a7 | 6754 | Fin_Block : Node_Id; |
bb072d1c AC |
6755 | Fin_Call : Node_Id; |
6756 | Init_Stmts : List_Id := No_List; | |
6757 | Obj_Init : Node_Id := Empty; | |
6758 | Obj_Ref : Node_Id; | |
70482933 | 6759 | |
95fef24f | 6760 | -- Start of processing for Default_Initialize_Object |
70482933 | 6761 | |
95fef24f AC |
6762 | begin |
6763 | -- Default initialization is suppressed for objects that are already | |
6764 | -- known to be imported (i.e. whose declaration specifies the Import | |
6765 | -- aspect). Note that for objects with a pragma Import, we generate | |
6766 | -- initialization here, and then remove it downstream when processing | |
6767 | -- the pragma. It is also suppressed for variables for which a pragma | |
6768 | -- Suppress_Initialization has been explicitly given | |
70482933 | 6769 | |
95fef24f AC |
6770 | if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then |
6771 | return; | |
448a1eb3 | 6772 | |
804ec349 GD |
6773 | -- Nothing to do if the object being initialized is of a task type |
6774 | -- and restriction No_Tasking is in effect, because this is a direct | |
448a1eb3 AC |
6775 | -- violation of the restriction. |
6776 | ||
6777 | elsif Is_Task_Type (Base_Typ) | |
6778 | and then Restriction_Active (No_Tasking) | |
6779 | then | |
6780 | return; | |
95fef24f | 6781 | end if; |
3476f949 | 6782 | |
7bf911b5 | 6783 | -- The expansion performed by this routine is as follows: |
70482933 | 6784 | |
7bf911b5 HK |
6785 | -- begin |
6786 | -- Abort_Defer; | |
6787 | -- Type_Init_Proc (Obj); | |
6788 | ||
6789 | -- begin | |
6790 | -- [Deep_]Initialize (Obj); | |
6791 | ||
6792 | -- exception | |
6793 | -- when others => | |
6794 | -- [Deep_]Finalize (Obj, Self => False); | |
6795 | -- raise; | |
6796 | -- end; | |
6797 | -- at end | |
6798 | -- Abort_Undefer_Direct; | |
6799 | -- end; | |
9e92ad49 | 6800 | |
7bf911b5 | 6801 | -- Initialize the components of the object |
70482933 | 6802 | |
95fef24f AC |
6803 | if Has_Non_Null_Base_Init_Proc (Typ) |
6804 | and then not No_Initialization (N) | |
6805 | and then not Initialization_Suppressed (Typ) | |
6806 | then | |
6807 | -- Do not initialize the components if No_Default_Initialization | |
3b26fe82 HK |
6808 | -- applies as the actual restriction check will occur later when |
6809 | -- the object is frozen as it is not known yet whether the object | |
6810 | -- is imported or not. | |
70482933 | 6811 | |
95fef24f | 6812 | if not Restriction_Active (No_Default_Initialization) then |
70482933 | 6813 | |
95fef24f AC |
6814 | -- If the values of the components are compile-time known, use |
6815 | -- their prebuilt aggregate form directly. | |
1a36a0cd | 6816 | |
95fef24f | 6817 | Aggr_Init := Static_Initialization (Base_Init_Proc (Typ)); |
1a36a0cd | 6818 | |
95fef24f | 6819 | if Present (Aggr_Init) then |
3b26fe82 HK |
6820 | Set_Expression (N, |
6821 | New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope)); | |
1a36a0cd | 6822 | |
95fef24f AC |
6823 | -- If type has discriminants, try to build an equivalent |
6824 | -- aggregate using discriminant values from the declaration. | |
6825 | -- This is a useful optimization, in particular if restriction | |
6826 | -- No_Elaboration_Code is active. | |
1a36a0cd | 6827 | |
95fef24f AC |
6828 | elsif Build_Equivalent_Aggregate then |
6829 | null; | |
70482933 | 6830 | |
529749b9 | 6831 | -- Optimize the default initialization of an array object when |
40016fa7 | 6832 | -- pragma Initialize_Scalars or Normalize_Scalars is in effect. |
529749b9 HK |
6833 | -- Construct an in-place initialization aggregate which may be |
6834 | -- convert into a fast memset by the backend. | |
6835 | ||
6836 | elsif Init_Or_Norm_Scalars | |
6837 | and then Is_Array_Type (Typ) | |
40016fa7 HK |
6838 | |
6839 | -- The array must lack atomic components because they are | |
6840 | -- treated as non-static, and as a result the backend will | |
6841 | -- not initialize the memory in one go. | |
6842 | ||
529749b9 | 6843 | and then not Has_Atomic_Components (Typ) |
40016fa7 HK |
6844 | |
6845 | -- The array must not be packed because the invalid values | |
6846 | -- in System.Scalar_Values are multiples of Storage_Unit. | |
6847 | ||
529749b9 | 6848 | and then not Is_Packed (Typ) |
40016fa7 HK |
6849 | |
6850 | -- The array must have static non-empty ranges, otherwise | |
6851 | -- the backend cannot initialize the memory in one go. | |
6852 | ||
529749b9 | 6853 | and then Has_Static_Non_Empty_Array_Bounds (Typ) |
40016fa7 HK |
6854 | |
6855 | -- The optimization is only relevant for arrays of scalar | |
6856 | -- types. | |
6857 | ||
529749b9 | 6858 | and then Is_Scalar_Type (Component_Type (Typ)) |
40016fa7 HK |
6859 | |
6860 | -- Similar to regular array initialization using a type | |
6861 | -- init proc, predicate checks are not performed because the | |
6862 | -- initialization values are intentionally invalid, and may | |
6863 | -- violate the predicate. | |
6864 | ||
6865 | and then not Has_Predicates (Component_Type (Typ)) | |
6866 | ||
603c253d SB |
6867 | -- Array default component value takes precedence over |
6868 | -- Init_Or_Norm_Scalars. | |
6869 | ||
6870 | and then No (Find_Aspect (Typ, | |
6871 | Aspect_Default_Component_Value)) | |
6872 | ||
40016fa7 HK |
6873 | -- The component type must have a single initialization value |
6874 | ||
529749b9 HK |
6875 | and then Simple_Initialization_OK (Component_Type (Typ)) |
6876 | then | |
6877 | Set_No_Initialization (N, False); | |
6878 | Set_Expression (N, | |
6879 | Get_Simple_Init_Val | |
6880 | (Typ => Typ, | |
6881 | N => Obj_Def, | |
b23cdc01 BD |
6882 | Size => (if Known_Esize (Def_Id) then Esize (Def_Id) |
6883 | else Uint_0))); | |
529749b9 | 6884 | |
bf5899e7 HK |
6885 | Analyze_And_Resolve |
6886 | (Expression (N), Typ, Suppress => All_Checks); | |
529749b9 | 6887 | |
7bf911b5 HK |
6888 | -- Otherwise invoke the type init proc, generate: |
6889 | -- Type_Init_Proc (Obj); | |
70482933 | 6890 | |
95fef24f AC |
6891 | else |
6892 | Obj_Ref := New_Object_Reference; | |
70482933 | 6893 | |
95fef24f AC |
6894 | if Comes_From_Source (Def_Id) then |
6895 | Initialization_Warning (Obj_Ref); | |
6896 | end if; | |
70482933 | 6897 | |
95fef24f AC |
6898 | Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ); |
6899 | end if; | |
6900 | end if; | |
70482933 | 6901 | |
95fef24f | 6902 | -- Provide a default value if the object needs simple initialization |
70482933 | 6903 | |
529749b9 | 6904 | elsif Simple_Initialization_OK (Typ) then |
95fef24f | 6905 | Set_No_Initialization (N, False); |
663afa9f | 6906 | Set_Expression (N, |
3b26fe82 HK |
6907 | Get_Simple_Init_Val |
6908 | (Typ => Typ, | |
6909 | N => Obj_Def, | |
b23cdc01 BD |
6910 | Size => |
6911 | (if Known_Esize (Def_Id) then Esize (Def_Id) else Uint_0))); | |
663afa9f | 6912 | |
95fef24f AC |
6913 | Analyze_And_Resolve (Expression (N), Typ); |
6914 | end if; | |
70482933 | 6915 | |
7bf911b5 HK |
6916 | -- Initialize the object, generate: |
6917 | -- [Deep_]Initialize (Obj); | |
6918 | ||
6919 | if Needs_Finalization (Typ) and then not No_Initialization (N) then | |
6920 | Obj_Init := | |
6921 | Make_Init_Call | |
fff7a6d9 | 6922 | (Obj_Ref => New_Object_Reference, |
7bf911b5 HK |
6923 | Typ => Typ); |
6924 | end if; | |
6925 | ||
6926 | -- Build a special finalization block when both the object and its | |
6927 | -- controlled components are to be initialized. The block finalizes | |
6928 | -- the components if the object initialization fails. Generate: | |
70482933 | 6929 | |
95fef24f | 6930 | -- begin |
7bf911b5 HK |
6931 | -- <Obj_Init> |
6932 | ||
95fef24f AC |
6933 | -- exception |
6934 | -- when others => | |
7bf911b5 | 6935 | -- <Fin_Call> |
95fef24f AC |
6936 | -- raise; |
6937 | -- end; | |
70482933 | 6938 | |
95fef24f AC |
6939 | if Has_Controlled_Component (Typ) |
6940 | and then Present (Comp_Init) | |
6941 | and then Present (Obj_Init) | |
7bf911b5 | 6942 | and then Exceptions_OK |
95fef24f | 6943 | then |
7bf911b5 | 6944 | Init_Stmts := Comp_Init; |
3476f949 | 6945 | |
95fef24f AC |
6946 | Fin_Call := |
6947 | Make_Final_Call | |
6948 | (Obj_Ref => New_Object_Reference, | |
6949 | Typ => Typ, | |
6950 | Skip_Self => True); | |
3476f949 | 6951 | |
95fef24f | 6952 | if Present (Fin_Call) then |
967947ed PMR |
6953 | |
6954 | -- Do not emit warnings related to the elaboration order when a | |
6955 | -- controlled object is declared before the body of Finalize is | |
6956 | -- seen. | |
6957 | ||
6958 | if Legacy_Elaboration_Checks then | |
6959 | Set_No_Elaboration_Check (Fin_Call); | |
6960 | end if; | |
6961 | ||
90e491a7 | 6962 | Fin_Block := |
95fef24f AC |
6963 | Make_Block_Statement (Loc, |
6964 | Declarations => No_List, | |
70482933 | 6965 | |
95fef24f AC |
6966 | Handled_Statement_Sequence => |
6967 | Make_Handled_Sequence_Of_Statements (Loc, | |
6968 | Statements => New_List (Obj_Init), | |
70482933 | 6969 | |
95fef24f AC |
6970 | Exception_Handlers => New_List ( |
6971 | Make_Exception_Handler (Loc, | |
6972 | Exception_Choices => New_List ( | |
6973 | Make_Others_Choice (Loc)), | |
70482933 | 6974 | |
95fef24f AC |
6975 | Statements => New_List ( |
6976 | Fin_Call, | |
90e491a7 PMR |
6977 | Make_Raise_Statement (Loc)))))); |
6978 | ||
6979 | -- Signal the ABE mechanism that the block carries out | |
6980 | -- initialization actions. | |
6981 | ||
6982 | Set_Is_Initialization_Block (Fin_Block); | |
6983 | ||
6984 | Append_To (Init_Stmts, Fin_Block); | |
95fef24f | 6985 | end if; |
70482933 | 6986 | |
7bf911b5 HK |
6987 | -- Otherwise finalization is not required, the initialization calls |
6988 | -- are passed to the abort block building circuitry, generate: | |
70482933 | 6989 | |
95fef24f | 6990 | -- Type_Init_Proc (Obj); |
7bf911b5 | 6991 | -- [Deep_]Initialize (Obj); |
70482933 | 6992 | |
95fef24f AC |
6993 | else |
6994 | if Present (Comp_Init) then | |
7bf911b5 | 6995 | Init_Stmts := Comp_Init; |
95fef24f | 6996 | end if; |
70482933 | 6997 | |
95fef24f | 6998 | if Present (Obj_Init) then |
7bf911b5 HK |
6999 | if No (Init_Stmts) then |
7000 | Init_Stmts := New_List; | |
95fef24f | 7001 | end if; |
70482933 | 7002 | |
7bf911b5 | 7003 | Append_To (Init_Stmts, Obj_Init); |
70482933 RK |
7004 | end if; |
7005 | end if; | |
7006 | ||
7bf911b5 | 7007 | -- Build an abort block to protect the initialization calls |
760804f3 | 7008 | |
7bf911b5 HK |
7009 | if Abort_Allowed |
7010 | and then Present (Comp_Init) | |
7011 | and then Present (Obj_Init) | |
7012 | then | |
7013 | -- Generate: | |
7014 | -- Abort_Defer; | |
760804f3 | 7015 | |
7bf911b5 | 7016 | Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); |
fbf5a39b | 7017 | |
7bf911b5 HK |
7018 | -- When exceptions are propagated, abort deferral must take place |
7019 | -- in the presence of initialization or finalization exceptions. | |
7020 | -- Generate: | |
fbf5a39b | 7021 | |
7bf911b5 HK |
7022 | -- begin |
7023 | -- Abort_Defer; | |
7024 | -- <Init_Stmts> | |
7025 | -- at end | |
7026 | -- Abort_Undefer_Direct; | |
7027 | -- end; | |
67336960 | 7028 | |
7bf911b5 | 7029 | if Exceptions_OK then |
bb072d1c AC |
7030 | Init_Stmts := New_List ( |
7031 | Build_Abort_Undefer_Block (Loc, | |
7032 | Stmts => Init_Stmts, | |
7033 | Context => N)); | |
df3e68b1 | 7034 | |
7bf911b5 | 7035 | -- Otherwise exceptions are not propagated. Generate: |
df3e68b1 | 7036 | |
7bf911b5 HK |
7037 | -- Abort_Defer; |
7038 | -- <Init_Stmts> | |
7039 | -- Abort_Undefer; | |
df3e68b1 | 7040 | |
7bf911b5 HK |
7041 | else |
7042 | Append_To (Init_Stmts, | |
7043 | Build_Runtime_Call (Loc, RE_Abort_Undefer)); | |
7044 | end if; | |
95fef24f | 7045 | end if; |
df3e68b1 | 7046 | |
7bf911b5 HK |
7047 | -- Insert the whole initialization sequence into the tree. If the |
7048 | -- object has a delayed freeze, as will be the case when it has | |
7049 | -- aspect specifications, the initialization sequence is part of | |
7050 | -- the freeze actions. | |
df3e68b1 | 7051 | |
7bf911b5 HK |
7052 | if Present (Init_Stmts) then |
7053 | if Has_Delayed_Freeze (Def_Id) then | |
7054 | Append_Freeze_Actions (Def_Id, Init_Stmts); | |
7055 | else | |
7056 | Insert_Actions_After (After, Init_Stmts); | |
7057 | end if; | |
95fef24f AC |
7058 | end if; |
7059 | end Default_Initialize_Object; | |
df3e68b1 | 7060 | |
ea588d41 EB |
7061 | ------------------------------ |
7062 | -- Initialize_Return_Object -- | |
7063 | ------------------------------ | |
7064 | ||
7065 | procedure Initialize_Return_Object | |
7066 | (Tag_Assign : Node_Id; | |
7067 | Adj_Call : Node_Id; | |
7068 | Expr : Node_Id; | |
7069 | Init_Stmt : Node_Id; | |
7070 | After : Node_Id) | |
7071 | is | |
7072 | begin | |
7073 | if Present (Tag_Assign) then | |
7074 | Insert_Action_After (After, Tag_Assign); | |
7075 | end if; | |
7076 | ||
7077 | if Present (Adj_Call) then | |
7078 | Insert_Action_After (After, Adj_Call); | |
7079 | end if; | |
7080 | ||
7081 | if No (Expr) then | |
7082 | Default_Initialize_Object (After); | |
7083 | ||
7084 | elsif Is_Delayed_Aggregate (Expr) | |
7085 | and then not No_Initialization (N) | |
7086 | then | |
7087 | Convert_Aggr_In_Object_Decl (N); | |
7088 | ||
7089 | elsif Present (Init_Stmt) then | |
7090 | Insert_Action_After (After, Init_Stmt); | |
7091 | Set_Expression (N, Empty); | |
7092 | end if; | |
7093 | end Initialize_Return_Object; | |
7094 | ||
8daf80ff EB |
7095 | -------------------------------- |
7096 | -- Is_Renamable_Function_Call -- | |
7097 | -------------------------------- | |
7098 | ||
7099 | function Is_Renamable_Function_Call (Expr : Node_Id) return Boolean is | |
7100 | begin | |
7101 | return not Is_Library_Level_Entity (Def_Id) | |
7102 | and then Is_Captured_Function_Call (Expr) | |
7103 | and then (not Special_Ret_Obj | |
7104 | or else | |
7105 | (Is_Related_To_Func_Return (Entity (Prefix (Expr))) | |
7106 | and then Needs_Secondary_Stack (Etype (Expr)) = | |
7107 | Needs_Secondary_Stack (Etype (Func_Id)))); | |
7108 | end Is_Renamable_Function_Call; | |
7109 | ||
ea588d41 EB |
7110 | ------------------------------- |
7111 | -- Make_Allocator_For_Return -- | |
7112 | ------------------------------- | |
7113 | ||
7114 | function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id is | |
8daf80ff EB |
7115 | Alloc : Node_Id; |
7116 | Alloc_Expr : Entity_Id; | |
ea588d41 EB |
7117 | |
7118 | begin | |
7119 | -- If the return object's declaration includes an expression and the | |
7120 | -- declaration isn't marked as No_Initialization, then we generate an | |
7121 | -- allocator with a qualified expression. Although this is necessary | |
7122 | -- only in the case where the result type is an interface (or class- | |
7123 | -- wide interface), we do it in all cases for the sake of consistency | |
7124 | -- instead of subsequently generating a separate assignment. | |
7125 | ||
7126 | if Present (Expr) | |
7127 | and then not Is_Delayed_Aggregate (Expr) | |
7128 | and then not No_Initialization (N) | |
7129 | then | |
7130 | -- Ada 2005 (AI95-344): If the result type is class-wide, insert | |
7131 | -- a check that the level of the return expression's underlying | |
7132 | -- type is not deeper than the level of the master enclosing the | |
7133 | -- function. | |
7134 | ||
7135 | -- AI12-043: The check is made immediately after the return object | |
7136 | -- is created. | |
7137 | ||
7138 | if Is_Class_Wide_Type (Etype (Func_Id)) then | |
7139 | Apply_CW_Accessibility_Check (Expr, Func_Id); | |
7140 | end if; | |
7141 | ||
8daf80ff EB |
7142 | Alloc_Expr := New_Copy_Tree (Expr); |
7143 | ||
9cfa7d7e | 7144 | -- In the constrained array case, deal with a potential sliding. |
8daf80ff | 7145 | -- In the interface case, put back a conversion that we may have |
9cfa7d7e | 7146 | -- removed earlier in the processing. |
8daf80ff | 7147 | |
9cfa7d7e EB |
7148 | if (Ekind (Typ) = E_Array_Subtype |
7149 | or else (Is_Interface (Typ) | |
7150 | and then Is_Class_Wide_Type (Etype (Alloc_Expr)))) | |
8daf80ff EB |
7151 | and then Typ /= Etype (Alloc_Expr) |
7152 | then | |
7153 | Alloc_Expr := Convert_To (Typ, Alloc_Expr); | |
7154 | end if; | |
7155 | ||
ea588d41 EB |
7156 | -- We always use the type of the expression for the qualified |
7157 | -- expression, rather than the return object's type. We cannot | |
7158 | -- always use the return object's type because the expression | |
8d1c1b02 | 7159 | -- might be of a specific type and the return object might not. |
ea588d41 EB |
7160 | |
7161 | Alloc := | |
7162 | Make_Allocator (Loc, | |
7163 | Expression => | |
7164 | Make_Qualified_Expression (Loc, | |
7165 | Subtype_Mark => | |
8daf80ff EB |
7166 | New_Occurrence_Of (Etype (Alloc_Expr), Loc), |
7167 | Expression => Alloc_Expr)); | |
ea588d41 EB |
7168 | |
7169 | else | |
7170 | Alloc := | |
7171 | Make_Allocator (Loc, | |
7172 | Expression => New_Occurrence_Of (Typ, Loc)); | |
7173 | ||
7174 | -- If the return object requires default initialization, then it | |
7175 | -- will happen later following the elaboration of the renaming. | |
7176 | -- If we don't turn it off here, then the object will be default | |
7177 | -- initialized twice. | |
7178 | ||
7179 | Set_No_Initialization (Alloc); | |
7180 | end if; | |
7181 | ||
7182 | -- Set the flag indicating that the allocator is made for a special | |
7183 | -- return object. This is used to bypass various legality checks as | |
7184 | -- well as to make sure that the result is not adjusted twice. | |
7185 | ||
7186 | Set_For_Special_Return_Object (Alloc); | |
7187 | ||
7188 | return Alloc; | |
7189 | end Make_Allocator_For_Return; | |
7190 | ||
aa683f5c EB |
7191 | ---------------------- |
7192 | -- OK_To_Rename_Ref -- | |
7193 | ---------------------- | |
24d2fbbe | 7194 | |
aa683f5c | 7195 | function OK_To_Rename_Ref (N : Node_Id) return Boolean is |
682c09ce | 7196 | begin |
aa683f5c EB |
7197 | return Is_Entity_Name (N) |
7198 | and then Ekind (Entity (N)) = E_Variable | |
7199 | and then OK_To_Rename (Entity (N)); | |
7200 | end OK_To_Rename_Ref; | |
f553e7bc | 7201 | |
95fef24f | 7202 | -- Local variables |
9534ab17 | 7203 | |
ea588d41 EB |
7204 | Adj_Call : Node_Id := Empty; |
7205 | Expr_Q : Node_Id := Empty; | |
7206 | Tag_Assign : Node_Id := Empty; | |
9534ab17 | 7207 | |
95fef24f AC |
7208 | Init_After : Node_Id := N; |
7209 | -- Node after which the initialization actions are to be inserted. This | |
7210 | -- is normally N, except for the case of a shared passive variable, in | |
7211 | -- which case the init proc call must be inserted only after the bodies | |
7212 | -- of the shared variable procedures have been seen. | |
df3e68b1 | 7213 | |
aa683f5c EB |
7214 | Rewrite_As_Renaming : Boolean := False; |
7215 | -- Whether to turn the declaration into a renaming at the end | |
7216 | ||
95fef24f | 7217 | -- Start of processing for Expand_N_Object_Declaration |
df3e68b1 | 7218 | |
95fef24f AC |
7219 | begin |
7220 | -- Don't do anything for deferred constants. All proper actions will be | |
7221 | -- expanded during the full declaration. | |
9534ab17 | 7222 | |
95fef24f | 7223 | if No (Expr) and Constant_Present (N) then |
9534ab17 | 7224 | return; |
df3e68b1 HK |
7225 | end if; |
7226 | ||
95fef24f AC |
7227 | -- The type of the object cannot be abstract. This is diagnosed at the |
7228 | -- point the object is frozen, which happens after the declaration is | |
7229 | -- fully expanded, so simply return now. | |
df3e68b1 | 7230 | |
95fef24f AC |
7231 | if Is_Abstract_Type (Typ) then |
7232 | return; | |
7233 | end if; | |
df3e68b1 | 7234 | |
15529d0a PMR |
7235 | -- No action needed for the internal imported dummy object added by |
7236 | -- Make_DT to compute the offset of the components that reference | |
7237 | -- secondary dispatch tables; required to avoid never-ending loop | |
7238 | -- processing this internal object declaration. | |
7239 | ||
7240 | if Tagged_Type_Expansion | |
7241 | and then Is_Internal (Def_Id) | |
7242 | and then Is_Imported (Def_Id) | |
7243 | and then Related_Type (Def_Id) = Implementation_Base_Type (Typ) | |
7244 | then | |
7245 | return; | |
7246 | end if; | |
7247 | ||
95fef24f | 7248 | -- Make shared memory routines for shared passive variable |
fbf5a39b | 7249 | |
95fef24f AC |
7250 | if Is_Shared_Passive (Def_Id) then |
7251 | Init_After := Make_Shared_Var_Procs (N); | |
fbf5a39b AC |
7252 | end if; |
7253 | ||
a7837c08 | 7254 | -- If tasks are being declared, make sure we have an activation chain |
95fef24f | 7255 | -- defined for the tasks (has no effect if we already have one), and |
a7837c08 JM |
7256 | -- also that a Master variable is established (and that the appropriate |
7257 | -- enclosing construct is established as a task master). | |
70482933 | 7258 | |
4844a259 EB |
7259 | if Has_Task (Typ) or else Might_Have_Tasks (Typ) then |
7260 | Build_Activation_Chain_Entity (N); | |
7261 | ||
7262 | if Has_Task (Typ) then | |
7263 | Build_Master_Entity (Def_Id); | |
7264 | ||
7265 | -- Handle objects initialized with BIP function calls | |
7266 | ||
7267 | elsif Present (Expr) then | |
7268 | Expr_Q := Unqualify (Expr); | |
7269 | ||
7270 | if Is_Build_In_Place_Function_Call (Expr_Q) | |
7271 | or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) | |
7272 | or else (Nkind (Expr_Q) = N_Reference | |
7273 | and then | |
7274 | Is_Build_In_Place_Function_Call (Prefix (Expr_Q))) | |
7275 | then | |
7276 | Build_Master_Entity (Def_Id); | |
7277 | end if; | |
7278 | end if; | |
7279 | end if; | |
70482933 | 7280 | |
bad0a3df PMR |
7281 | -- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations |
7282 | -- restrictions are active then default-sized secondary stacks are | |
7283 | -- generated by the binder and allocated by SS_Init. To provide the | |
7284 | -- binder the number of stacks to generate, the number of default-sized | |
7285 | -- stacks required for task objects contained within the object | |
7286 | -- declaration N is calculated here as it is at this point where | |
7287 | -- unconstrained types become constrained. The result is stored in the | |
7288 | -- enclosing unit's Unit_Record. | |
7289 | ||
7290 | -- Note if N is an array object declaration that has an initialization | |
7291 | -- expression, a second object declaration for the initialization | |
7292 | -- expression is created by the compiler. To prevent double counting | |
7293 | -- of the stacks in this scenario, the stacks of the first array are | |
7294 | -- not counted. | |
7295 | ||
95260403 | 7296 | if Might_Have_Tasks (Typ) |
bad0a3df PMR |
7297 | and then not Restriction_Active (No_Secondary_Stack) |
7298 | and then (Restriction_Active (No_Implicit_Heap_Allocations) | |
7299 | or else Restriction_Active (No_Implicit_Task_Allocations)) | |
4a08c95c | 7300 | and then not (Ekind (Typ) in E_Array_Type | E_Array_Subtype |
8f563162 | 7301 | and then Has_Init_Expression (N)) |
bad0a3df PMR |
7302 | then |
7303 | declare | |
7304 | PS_Count, SS_Count : Int := 0; | |
7305 | begin | |
7306 | Count_Default_Sized_Task_Stacks (Typ, PS_Count, SS_Count); | |
7307 | Increment_Primary_Stack_Count (PS_Count); | |
7308 | Increment_Sec_Stack_Count (SS_Count); | |
7309 | end; | |
7310 | end if; | |
7311 | ||
95fef24f | 7312 | -- Default initialization required, and no expression present |
70482933 | 7313 | |
95fef24f | 7314 | if No (Expr) then |
95fef24f AC |
7315 | -- If we have a type with a variant part, the initialization proc |
7316 | -- will contain implicit tests of the discriminant values, which | |
7317 | -- counts as a violation of the restriction No_Implicit_Conditionals. | |
70482933 | 7318 | |
95fef24f AC |
7319 | if Has_Variant_Part (Typ) then |
7320 | declare | |
7321 | Msg : Boolean; | |
70482933 | 7322 | |
95fef24f AC |
7323 | begin |
7324 | Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def); | |
70482933 | 7325 | |
95fef24f AC |
7326 | if Msg then |
7327 | Error_Msg_N | |
7328 | ("\initialization of variant record tests discriminants", | |
7329 | Obj_Def); | |
7330 | return; | |
7331 | end if; | |
7332 | end; | |
7333 | end if; | |
70482933 | 7334 | |
95fef24f AC |
7335 | -- For the default initialization case, if we have a private type |
7336 | -- with invariants, and invariant checks are enabled, then insert an | |
7337 | -- invariant check after the object declaration. Note that it is OK | |
7338 | -- to clobber the object with an invalid value since if the exception | |
7339 | -- is raised, then the object will go out of scope. In the case where | |
7340 | -- an array object is initialized with an aggregate, the expression | |
7341 | -- is removed. Check flag Has_Init_Expression to avoid generating a | |
7342 | -- junk invariant check and flag No_Initialization to avoid checking | |
7343 | -- an uninitialized object such as a compiler temporary used for an | |
7344 | -- aggregate. | |
70482933 | 7345 | |
95fef24f AC |
7346 | if Has_Invariants (Base_Typ) |
7347 | and then Present (Invariant_Procedure (Base_Typ)) | |
7348 | and then not Has_Init_Expression (N) | |
7349 | and then not No_Initialization (N) | |
7350 | then | |
7351 | -- If entity has an address clause or aspect, make invariant | |
7352 | -- call into a freeze action for the explicit freeze node for | |
7353 | -- object. Otherwise insert invariant check after declaration. | |
70482933 | 7354 | |
95fef24f AC |
7355 | if Present (Following_Address_Clause (N)) |
7356 | or else Has_Aspect (Def_Id, Aspect_Address) | |
7357 | then | |
7358 | Ensure_Freeze_Node (Def_Id); | |
7359 | Set_Has_Delayed_Freeze (Def_Id); | |
7360 | Set_Is_Frozen (Def_Id, False); | |
70482933 | 7361 | |
95fef24f AC |
7362 | if not Partial_View_Has_Unknown_Discr (Typ) then |
7363 | Append_Freeze_Action (Def_Id, | |
7364 | Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); | |
7365 | end if; | |
70482933 | 7366 | |
95fef24f AC |
7367 | elsif not Partial_View_Has_Unknown_Discr (Typ) then |
7368 | Insert_After (N, | |
7369 | Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); | |
7370 | end if; | |
7371 | end if; | |
47cc8d6b | 7372 | |
8313c5f6 | 7373 | if not Special_Ret_Obj then |
4844a259 EB |
7374 | Default_Initialize_Object (Init_After); |
7375 | end if; | |
70482933 | 7376 | |
95fef24f | 7377 | -- Generate attribute for Persistent_BSS if needed |
70482933 | 7378 | |
95fef24f AC |
7379 | if Persistent_BSS_Mode |
7380 | and then Comes_From_Source (N) | |
7381 | and then Is_Potentially_Persistent_Type (Typ) | |
7382 | and then not Has_Init_Expression (N) | |
7383 | and then Is_Library_Level_Entity (Def_Id) | |
7384 | then | |
7385 | declare | |
7386 | Prag : Node_Id; | |
7387 | begin | |
7388 | Prag := | |
7389 | Make_Linker_Section_Pragma | |
7390 | (Def_Id, Sloc (N), ".persistent.bss"); | |
7391 | Insert_After (N, Prag); | |
7392 | Analyze (Prag); | |
7393 | end; | |
7394 | end if; | |
70482933 | 7395 | |
95fef24f | 7396 | -- If access type, then we know it is null if not initialized |
70482933 | 7397 | |
95fef24f AC |
7398 | if Is_Access_Type (Typ) then |
7399 | Set_Is_Known_Null (Def_Id); | |
70482933 RK |
7400 | end if; |
7401 | ||
95fef24f | 7402 | -- Explicit initialization present |
70482933 RK |
7403 | |
7404 | else | |
95fef24f AC |
7405 | -- Obtain actual expression from qualified expression |
7406 | ||
fff7a6d9 | 7407 | Expr_Q := Unqualify (Expr); |
70482933 | 7408 | |
95fef24f AC |
7409 | -- When we have the appropriate type of aggregate in the expression |
7410 | -- (it has been determined during analysis of the aggregate by | |
7411 | -- setting the delay flag), let's perform in place assignment and | |
7412 | -- thus avoid creating a temporary. | |
fbf5a39b | 7413 | |
95fef24f | 7414 | if Is_Delayed_Aggregate (Expr_Q) then |
41a59f6b | 7415 | |
89beb653 HK |
7416 | -- An aggregate that must be built in place is not resolved and |
7417 | -- expanded until the enclosing construct is expanded. This will | |
a3559241 | 7418 | -- happen when the aggregate is limited and the declared object |
e0909200 JM |
7419 | -- has a following address clause; it happens also when generating |
7420 | -- C code for an aggregate that has an alignment or address clause | |
a671959b ES |
7421 | -- (see Analyze_Object_Declaration). Resolution is done without |
7422 | -- expansion because it will take place when the declaration | |
7423 | -- itself is expanded. | |
41a59f6b | 7424 | |
e0909200 JM |
7425 | if (Is_Limited_Type (Typ) or else Modify_Tree_For_C) |
7426 | and then not Analyzed (Expr) | |
7427 | then | |
a671959b | 7428 | Expander_Mode_Save_And_Set (False); |
41a59f6b | 7429 | Resolve (Expr, Typ); |
a671959b | 7430 | Expander_Mode_Restore; |
41a59f6b ES |
7431 | end if; |
7432 | ||
8313c5f6 | 7433 | if not Special_Ret_Obj then |
4844a259 EB |
7434 | Convert_Aggr_In_Object_Decl (N); |
7435 | end if; | |
fbf5a39b | 7436 | |
95fef24f AC |
7437 | -- Ada 2005 (AI-318-02): If the initialization expression is a call |
7438 | -- to a build-in-place function, then access to the declared object | |
7439 | -- must be passed to the function. Currently we limit such functions | |
7440 | -- to those with constrained limited result subtypes, but eventually | |
7441 | -- plan to expand the allowed forms of functions that are treated as | |
7442 | -- build-in-place. | |
fbf5a39b | 7443 | |
d4dfb005 | 7444 | elsif Is_Build_In_Place_Function_Call (Expr_Q) then |
95fef24f | 7445 | Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q); |
fbf5a39b | 7446 | |
95fef24f AC |
7447 | -- The previous call expands the expression initializing the |
7448 | -- built-in-place object into further code that will be analyzed | |
7449 | -- later. No further expansion needed here. | |
fbf5a39b | 7450 | |
95fef24f | 7451 | return; |
fbf5a39b | 7452 | |
5168a9b3 PMR |
7453 | -- This is the same as the previous 'elsif', except that the call has |
7454 | -- been transformed by other expansion activities into something like | |
7455 | -- F(...)'Reference. | |
7456 | ||
7457 | elsif Nkind (Expr_Q) = N_Reference | |
7458 | and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q)) | |
7459 | and then not Is_Expanded_Build_In_Place_Call | |
3fc40cd7 | 7460 | (Unqual_Conv (Prefix (Expr_Q))) |
5168a9b3 PMR |
7461 | then |
7462 | Make_Build_In_Place_Call_In_Anonymous_Context (Prefix (Expr_Q)); | |
7463 | ||
7464 | -- The previous call expands the expression initializing the | |
7465 | -- built-in-place object into further code that will be analyzed | |
7466 | -- later. No further expansion needed here. | |
7467 | ||
7468 | return; | |
7469 | ||
4ac62786 AC |
7470 | -- Ada 2005 (AI-318-02): Specialization of the previous case for |
7471 | -- expressions containing a build-in-place function call whose | |
7472 | -- returned object covers interface types, and Expr_Q has calls to | |
7473 | -- Ada.Tags.Displace to displace the pointer to the returned build- | |
7474 | -- in-place object to reference the secondary dispatch table of a | |
7475 | -- covered interface type. | |
7476 | ||
d4dfb005 | 7477 | elsif Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) then |
4ac62786 AC |
7478 | Make_Build_In_Place_Iface_Call_In_Object_Declaration (N, Expr_Q); |
7479 | ||
7480 | -- The previous call expands the expression initializing the | |
7481 | -- built-in-place object into further code that will be analyzed | |
7482 | -- later. No further expansion needed here. | |
7483 | ||
7484 | return; | |
7485 | ||
95fef24f AC |
7486 | -- Ada 2005 (AI-251): Rewrite the expression that initializes a |
7487 | -- class-wide interface object to ensure that we copy the full | |
7488 | -- object, unless we are targetting a VM where interfaces are handled | |
7489 | -- by VM itself. Note that if the root type of Typ is an ancestor of | |
7490 | -- Expr's type, both types share the same dispatch table and there is | |
7491 | -- no need to displace the pointer. | |
fbf5a39b | 7492 | |
95fef24f | 7493 | elsif Is_Interface (Typ) |
fbf5a39b | 7494 | |
95fef24f AC |
7495 | -- Avoid never-ending recursion because if Equivalent_Type is set |
7496 | -- then we've done it already and must not do it again. | |
fbf5a39b | 7497 | |
95fef24f AC |
7498 | and then not |
7499 | (Nkind (Obj_Def) = N_Identifier | |
7500 | and then Present (Equivalent_Type (Entity (Obj_Def)))) | |
7501 | then | |
7502 | pragma Assert (Is_Class_Wide_Type (Typ)); | |
fbf5a39b | 7503 | |
8daf80ff EB |
7504 | -- If the original node of the expression was a conversion |
7505 | -- to this specific class-wide interface type then restore | |
7506 | -- the original node because we must copy the object before | |
7507 | -- displacing the pointer to reference the secondary tag | |
7508 | -- component. This code must be kept synchronized with the | |
7509 | -- expansion done by routine Expand_Interface_Conversion | |
7510 | ||
7511 | if not Comes_From_Source (Expr) | |
7512 | and then Nkind (Expr) = N_Explicit_Dereference | |
7513 | and then Nkind (Original_Node (Expr)) = N_Type_Conversion | |
7514 | and then Etype (Original_Node (Expr)) = Typ | |
7515 | then | |
7516 | Rewrite (Expr, Original_Node (Expression (N))); | |
7517 | end if; | |
7518 | ||
7519 | -- Avoid expansion of redundant interface conversion | |
7520 | ||
7521 | if Nkind (Expr) = N_Type_Conversion | |
7522 | and then Etype (Expr) = Typ | |
7523 | then | |
7524 | Expr_Q := Expression (Expr); | |
7525 | else | |
7526 | Expr_Q := Expr; | |
7527 | end if; | |
7528 | ||
39a7b603 | 7529 | -- We may use a renaming if the initialization expression is a |
8daf80ff EB |
7530 | -- captured function call that meets a few conditions. |
7531 | ||
7532 | Rewrite_As_Renaming := Is_Renamable_Function_Call (Expr_Q); | |
7533 | ||
ea588d41 | 7534 | -- If the object is a special return object, then bypass special |
95fef24f | 7535 | -- treatment of class-wide interface initialization below. In this |
8daf80ff EB |
7536 | -- case, the expansion of the return object will take care of this |
7537 | -- initialization via the expansion of the allocator. | |
fbf5a39b | 7538 | |
8daf80ff | 7539 | if Special_Ret_Obj and then not Rewrite_As_Renaming then |
d990f34e EB |
7540 | |
7541 | -- If the type needs finalization and is not inherently | |
7542 | -- limited, then the target is adjusted after the copy | |
7543 | -- and attached to the finalization list. | |
7544 | ||
7545 | if Needs_Finalization (Typ) | |
7546 | and then not Is_Limited_View (Typ) | |
7547 | then | |
7548 | Adj_Call := | |
7549 | Make_Adjust_Call ( | |
7550 | Obj_Ref => New_Occurrence_Of (Def_Id, Loc), | |
7551 | Typ => Base_Typ); | |
7552 | end if; | |
fbf5a39b | 7553 | |
1f038e84 EB |
7554 | -- Renaming an expression of the object's type is immediate |
7555 | ||
7556 | elsif Rewrite_As_Renaming | |
7557 | and then Base_Type (Etype (Expr_Q)) = Base_Type (Typ) | |
7558 | then | |
7559 | null; | |
7560 | ||
95fef24f AC |
7561 | elsif Tagged_Type_Expansion then |
7562 | declare | |
09e01753 EB |
7563 | Iface : constant Entity_Id := Root_Type (Typ); |
7564 | ||
7565 | Expr_Typ : Entity_Id; | |
7566 | New_Expr : Node_Id; | |
7567 | Obj_Id : Entity_Id; | |
7568 | Ptr_Obj_Decl : Node_Id; | |
7569 | Ptr_Obj_Id : Entity_Id; | |
7570 | Tag_Comp : Node_Id; | |
fbf5a39b | 7571 | |
95fef24f | 7572 | begin |
8daf80ff EB |
7573 | Expr_Typ := Base_Type (Etype (Expr_Q)); |
7574 | if Is_Class_Wide_Type (Expr_Typ) then | |
7575 | Expr_Typ := Root_Type (Expr_Typ); | |
95fef24f | 7576 | end if; |
70482933 | 7577 | |
8daf80ff | 7578 | -- Rename limited objects since they cannot be copied |
70482933 | 7579 | |
8daf80ff EB |
7580 | if Is_Limited_Record (Expr_Typ) then |
7581 | Rewrite_As_Renaming := True; | |
95fef24f | 7582 | end if; |
70482933 | 7583 | |
8daf80ff | 7584 | Obj_Id := Make_Temporary (Loc, 'D', Expr_Q); |
70482933 | 7585 | |
95fef24f | 7586 | -- Replace |
8daf80ff EB |
7587 | -- IW : I'Class := Expr; |
7588 | -- by | |
7589 | -- Dnn : Tag renames Tag_Ptr!(Expr'Address).all; | |
7590 | -- type Ityp is not null access I'Class; | |
7591 | -- Rnn : constant Ityp := | |
7592 | -- Ityp!(Displace (Dnn'Address, I'Tag)); | |
7593 | -- IW : I'Class renames Rnn.all; | |
7594 | ||
39a7b603 | 7595 | if Rewrite_As_Renaming then |
8daf80ff EB |
7596 | New_Expr := |
7597 | Make_Explicit_Dereference (Loc, | |
7598 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), | |
7599 | Make_Attribute_Reference (Loc, | |
7600 | Prefix => Relocate_Node (Expr_Q), | |
7601 | Attribute_Name => Name_Address))); | |
7602 | ||
7603 | -- Suppress junk access checks on RE_Tag_Ptr | |
7604 | ||
7605 | Insert_Action (N, | |
7606 | Make_Object_Renaming_Declaration (Loc, | |
7607 | Defining_Identifier => Obj_Id, | |
7608 | Subtype_Mark => | |
7609 | New_Occurrence_Of (RTE (RE_Tag), Loc), | |
7610 | Name => New_Expr), | |
7611 | Suppress => Access_Check); | |
7612 | ||
7613 | -- Dynamically reference the tag associated with the | |
7614 | -- interface. | |
7615 | ||
7616 | Tag_Comp := | |
7617 | Make_Function_Call (Loc, | |
7618 | Name => New_Occurrence_Of (RTE (RE_Displace), Loc), | |
7619 | Parameter_Associations => New_List ( | |
7620 | Make_Attribute_Reference (Loc, | |
7621 | Prefix => New_Occurrence_Of (Obj_Id, Loc), | |
7622 | Attribute_Name => Name_Address), | |
7623 | New_Occurrence_Of | |
7624 | (Node (First_Elmt (Access_Disp_Table (Iface))), | |
7625 | Loc))); | |
7626 | ||
39a7b603 EB |
7627 | -- Replace |
7628 | -- IW : I'Class := Expr; | |
7629 | -- by | |
7630 | -- Dnn : Typ := Expr; | |
7631 | -- type Ityp is not null access I'Class; | |
7632 | -- Rnn : constant Ityp := Ityp (Dnn.I_Tag'Address); | |
7633 | -- IW : I'Class renames Rnn.all; | |
7634 | ||
7635 | elsif Has_Tag_Of_Type (Expr_Q) | |
7636 | and then Interface_Present_In_Ancestor (Expr_Typ, Typ) | |
7637 | and then (Expr_Typ = Etype (Expr_Typ) | |
7638 | or else not | |
7639 | Is_Variable_Size_Record (Etype (Expr_Typ))) | |
7640 | then | |
7641 | Insert_Action (N, | |
7642 | Make_Object_Declaration (Loc, | |
7643 | Defining_Identifier => Obj_Id, | |
7644 | Object_Definition => | |
7645 | New_Occurrence_Of (Expr_Typ, Loc), | |
7646 | Expression => Relocate_Node (Expr_Q))); | |
7647 | ||
7648 | -- Statically reference the tag associated with the | |
7649 | -- interface | |
7650 | ||
7651 | Tag_Comp := | |
7652 | Make_Selected_Component (Loc, | |
7653 | Prefix => New_Occurrence_Of (Obj_Id, Loc), | |
7654 | Selector_Name => | |
7655 | New_Occurrence_Of | |
7656 | (Find_Interface_Tag (Expr_Typ, Iface), Loc)); | |
7657 | ||
8daf80ff EB |
7658 | -- Replace |
7659 | -- IW : I'Class := Expr; | |
95fef24f AC |
7660 | -- by |
7661 | -- type Equiv_Record is record ... end record; | |
7662 | -- implicit subtype CW is <Class_Wide_Subtype>; | |
8daf80ff | 7663 | -- Dnn : CW := CW!(Expr); |
95fef24f | 7664 | -- type Ityp is not null access I'Class; |
09e01753 | 7665 | -- Rnn : constant Ityp := |
8daf80ff | 7666 | -- Ityp!(Displace (Dnn'Address, I'Tag)); |
09e01753 | 7667 | -- IW : I'Class renames Rnn.all; |
39231404 | 7668 | |
95fef24f AC |
7669 | else |
7670 | -- Generate the equivalent record type and update the | |
7671 | -- subtype indication to reference it. | |
70482933 | 7672 | |
95fef24f AC |
7673 | Expand_Subtype_From_Expr |
7674 | (N => N, | |
7675 | Unc_Type => Typ, | |
7676 | Subtype_Indic => Obj_Def, | |
09e01753 | 7677 | Exp => Expr_Q); |
39231404 | 7678 | |
95fef24f | 7679 | -- For interface types we use 'Address which displaces |
8daf80ff | 7680 | -- the pointer to the base of the object (if required). |
70482933 | 7681 | |
8daf80ff | 7682 | if Is_Interface (Etype (Expr_Q)) then |
95fef24f AC |
7683 | New_Expr := |
7684 | Unchecked_Convert_To (Etype (Obj_Def), | |
7685 | Make_Explicit_Dereference (Loc, | |
7686 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), | |
7687 | Make_Attribute_Reference (Loc, | |
09e01753 | 7688 | Prefix => Relocate_Node (Expr_Q), |
95fef24f | 7689 | Attribute_Name => Name_Address)))); |
04df6250 | 7690 | |
8daf80ff | 7691 | -- For other types, no displacement is needed |
95fef24f | 7692 | |
09e01753 | 7693 | else |
8daf80ff | 7694 | New_Expr := Relocate_Node (Expr_Q); |
95fef24f AC |
7695 | end if; |
7696 | ||
8daf80ff EB |
7697 | -- Suppress junk access checks on RE_Tag_Ptr |
7698 | ||
7699 | Insert_Action (N, | |
7700 | Make_Object_Declaration (Loc, | |
7701 | Defining_Identifier => Obj_Id, | |
7702 | Object_Definition => | |
7703 | New_Occurrence_Of (Etype (Obj_Def), Loc), | |
7704 | Expression => New_Expr), | |
7705 | Suppress => Access_Check); | |
7706 | ||
95fef24f AC |
7707 | -- Dynamically reference the tag associated with the |
7708 | -- interface. | |
7709 | ||
7710 | Tag_Comp := | |
7711 | Make_Function_Call (Loc, | |
7712 | Name => New_Occurrence_Of (RTE (RE_Displace), Loc), | |
7713 | Parameter_Associations => New_List ( | |
7714 | Make_Attribute_Reference (Loc, | |
7715 | Prefix => New_Occurrence_Of (Obj_Id, Loc), | |
7716 | Attribute_Name => Name_Address), | |
7717 | New_Occurrence_Of | |
7718 | (Node (First_Elmt (Access_Disp_Table (Iface))), | |
7719 | Loc))); | |
7720 | end if; | |
7721 | ||
09e01753 EB |
7722 | -- As explained in Exp_Disp, we use Convert_Tag_To_Interface |
7723 | -- to do the final conversion, but we insert an intermediate | |
7724 | -- temporary before the dereference so that we can process | |
7725 | -- the expansion as part of the analysis of the declaration | |
7726 | -- of this temporary, and then rewrite manually the original | |
7727 | -- object as the simple renaming of this dereference. | |
95fef24f | 7728 | |
09e01753 EB |
7729 | Tag_Comp := Convert_Tag_To_Interface (Typ, Tag_Comp); |
7730 | pragma Assert (Nkind (Tag_Comp) = N_Explicit_Dereference | |
7731 | and then | |
7732 | Nkind (Prefix (Tag_Comp)) = N_Unchecked_Type_Conversion); | |
95fef24f | 7733 | |
09e01753 | 7734 | Ptr_Obj_Id := Make_Temporary (Loc, 'R'); |
daf82dd8 | 7735 | |
09e01753 EB |
7736 | Ptr_Obj_Decl := |
7737 | Make_Object_Declaration (Loc, | |
7738 | Defining_Identifier => Ptr_Obj_Id, | |
7739 | Constant_Present => True, | |
7740 | Object_Definition => | |
7741 | New_Occurrence_Of | |
7742 | (Entity (Subtype_Mark (Prefix (Tag_Comp))), Loc), | |
7743 | Expression => Prefix (Tag_Comp)); | |
daf82dd8 | 7744 | |
09e01753 | 7745 | Insert_Action (N, Ptr_Obj_Decl, Suppress => All_Checks); |
daf82dd8 | 7746 | |
09e01753 EB |
7747 | Set_Prefix (Tag_Comp, New_Occurrence_Of (Ptr_Obj_Id, Loc)); |
7748 | Expr_Q := Tag_Comp; | |
7749 | Set_Etype (Expr_Q, Typ); | |
8daf80ff | 7750 | Set_Parent (Expr_Q, N); |
daf82dd8 | 7751 | |
09e01753 | 7752 | Rewrite_As_Renaming := True; |
95fef24f | 7753 | end; |
95fef24f | 7754 | |
4844a259 EB |
7755 | else |
7756 | return; | |
7757 | end if; | |
95fef24f AC |
7758 | |
7759 | -- Common case of explicit object initialization | |
7760 | ||
7761 | else | |
3b4c6e67 EB |
7762 | -- Small optimization: if the expression is a function call and |
7763 | -- the object is stand-alone, not declared at library level and of | |
7764 | -- a class-wide type, then we capture the result of the call into | |
7765 | -- a temporary, with the benefit that, if the result's type does | |
7766 | -- not need finalization, nothing will be finalized and, if it | |
7767 | -- does, the temporary only will be finalized by means of a direct | |
7768 | -- call to the Finalize primitive if the result's type is not a | |
7769 | -- class-wide type; whereas, in both cases, the stand-alone object | |
7770 | -- itself would be finalized by means of a dispatching call to the | |
7771 | -- Deep_Finalize routine. | |
7772 | ||
7773 | if Nkind (Expr_Q) = N_Function_Call | |
7774 | and then not Special_Ret_Obj | |
7775 | and then not Is_Library_Level_Entity (Def_Id) | |
7776 | and then Is_Class_Wide_Type (Typ) | |
7777 | then | |
7778 | Remove_Side_Effects (Expr_Q); | |
7779 | end if; | |
7780 | ||
95fef24f AC |
7781 | -- In most cases, we must check that the initial value meets any |
7782 | -- constraint imposed by the declared type. However, there is one | |
7783 | -- very important exception to this rule. If the entity has an | |
7784 | -- unconstrained nominal subtype, then it acquired its constraints | |
7785 | -- from the expression in the first place, and not only does this | |
7786 | -- mean that the constraint check is not needed, but an attempt to | |
7787 | -- perform the constraint check can cause order of elaboration | |
7788 | -- problems. | |
7789 | ||
7790 | if not Is_Constr_Subt_For_U_Nominal (Typ) then | |
7791 | ||
7792 | -- If this is an allocator for an aggregate that has been | |
7793 | -- allocated in place, delay checks until assignments are | |
7794 | -- made, because the discriminants are not initialized. | |
7795 | ||
3fc40cd7 PMR |
7796 | if Nkind (Expr) = N_Allocator |
7797 | and then No_Initialization (Expr) | |
95fef24f AC |
7798 | then |
7799 | null; | |
7800 | ||
7801 | -- Otherwise apply a constraint check now if no prev error | |
7802 | ||
7803 | elsif Nkind (Expr) /= N_Error then | |
7804 | Apply_Constraint_Check (Expr, Typ); | |
7805 | ||
7806 | -- Deal with possible range check | |
7807 | ||
7808 | if Do_Range_Check (Expr) then | |
70482933 | 7809 | |
95fef24f | 7810 | -- If assignment checks are suppressed, turn off flag |
a05e99a2 | 7811 | |
95fef24f AC |
7812 | if Suppress_Assignment_Checks (N) then |
7813 | Set_Do_Range_Check (Expr, False); | |
ce2b6ba5 | 7814 | |
95fef24f | 7815 | -- Otherwise generate the range check |
70482933 | 7816 | |
95fef24f AC |
7817 | else |
7818 | Generate_Range_Check | |
7819 | (Expr, Typ, CE_Range_Check_Failed); | |
7820 | end if; | |
7821 | end if; | |
7822 | end if; | |
7823 | end if; | |
70482933 | 7824 | |
95fef24f AC |
7825 | -- For tagged types, when an init value is given, the tag has to |
7826 | -- be re-initialized separately in order to avoid the propagation | |
7827 | -- of a wrong tag coming from a view conversion unless the type | |
7828 | -- is class wide (in this case the tag comes from the init value). | |
7829 | -- Suppress the tag assignment when not Tagged_Type_Expansion | |
7830 | -- because tags are represented implicitly in objects. Ditto for | |
7831 | -- types that are CPP_CLASS, and for initializations that are | |
7832 | -- aggregates, because they have to have the right tag. | |
70482933 | 7833 | |
95fef24f AC |
7834 | -- The re-assignment of the tag has to be done even if the object |
7835 | -- is a constant. The assignment must be analyzed after the | |
7836 | -- declaration. If an address clause follows, this is handled as | |
7837 | -- part of the freeze actions for the object, otherwise insert | |
7838 | -- tag assignment here. | |
70482933 | 7839 | |
95fef24f | 7840 | Tag_Assign := Make_Tag_Assignment (N); |
70482933 | 7841 | |
95fef24f AC |
7842 | if Present (Tag_Assign) then |
7843 | if Present (Following_Address_Clause (N)) then | |
7844 | Ensure_Freeze_Node (Def_Id); | |
8313c5f6 | 7845 | elsif not Special_Ret_Obj then |
95fef24f AC |
7846 | Insert_Action_After (Init_After, Tag_Assign); |
7847 | end if; | |
70482933 | 7848 | |
95fef24f AC |
7849 | -- Handle C++ constructor calls. Note that we do not check that |
7850 | -- Typ is a tagged type since the equivalent Ada type of a C++ | |
7851 | -- class that has no virtual methods is an untagged limited | |
7852 | -- record type. | |
996c8821 | 7853 | |
95fef24f | 7854 | elsif Is_CPP_Constructor_Call (Expr) then |
ea588d41 EB |
7855 | declare |
7856 | Id_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc); | |
04df6250 | 7857 | |
ea588d41 EB |
7858 | begin |
7859 | -- The call to the initialization procedure does NOT freeze | |
7860 | -- the object being initialized. | |
96e90ac1 | 7861 | |
ea588d41 EB |
7862 | Set_Must_Not_Freeze (Id_Ref); |
7863 | Set_Assignment_OK (Id_Ref); | |
70482933 | 7864 | |
ea588d41 EB |
7865 | Insert_Actions_After (Init_After, |
7866 | Build_Initialization_Call (Loc, Id_Ref, Typ, | |
7867 | Constructor_Ref => Expr)); | |
80fa4617 | 7868 | |
ea588d41 EB |
7869 | -- We remove here the original call to the constructor |
7870 | -- to avoid its management in the backend | |
3647ca26 | 7871 | |
ea588d41 EB |
7872 | Set_Expression (N, Empty); |
7873 | return; | |
7874 | end; | |
3647ca26 | 7875 | |
95fef24f | 7876 | -- Handle initialization of limited tagged types |
70482933 | 7877 | |
95fef24f AC |
7878 | elsif Is_Tagged_Type (Typ) |
7879 | and then Is_Class_Wide_Type (Typ) | |
7880 | and then Is_Limited_Record (Typ) | |
774454ac | 7881 | and then not Is_Limited_Interface (Typ) |
95fef24f AC |
7882 | then |
7883 | -- Given that the type is limited we cannot perform a copy. If | |
7884 | -- Expr_Q is the reference to a variable we mark the variable | |
7885 | -- as OK_To_Rename to expand this declaration into a renaming | |
41a59f6b | 7886 | -- declaration (see below). |
70482933 | 7887 | |
95fef24f AC |
7888 | if Is_Entity_Name (Expr_Q) then |
7889 | Set_OK_To_Rename (Entity (Expr_Q)); | |
7b4db06c | 7890 | |
95fef24f AC |
7891 | -- If we cannot convert the expression into a renaming we must |
7892 | -- consider it an internal error because the backend does not | |
e783561e BD |
7893 | -- have support to handle it. But avoid crashing on a raise |
7894 | -- expression or conditional expression. | |
7b4db06c | 7895 | |
e783561e BD |
7896 | elsif Nkind (Original_Node (Expr_Q)) not in |
7897 | N_Raise_Expression | N_If_Expression | N_Case_Expression | |
7898 | then | |
95fef24f AC |
7899 | raise Program_Error; |
7900 | end if; | |
70482933 | 7901 | |
95fef24f AC |
7902 | -- For discrete types, set the Is_Known_Valid flag if the |
7903 | -- initializing value is known to be valid. Only do this for | |
7904 | -- source assignments, since otherwise we can end up turning | |
7905 | -- on the known valid flag prematurely from inserted code. | |
758c442c | 7906 | |
95fef24f AC |
7907 | elsif Comes_From_Source (N) |
7908 | and then Is_Discrete_Type (Typ) | |
7909 | and then Expr_Known_Valid (Expr) | |
2749e4ab | 7910 | and then Safe_To_Capture_Value (N, Def_Id) |
95fef24f AC |
7911 | then |
7912 | Set_Is_Known_Valid (Def_Id); | |
a05e99a2 | 7913 | |
ea588d41 EB |
7914 | -- For access types, set the Is_Known_Non_Null flag if the |
7915 | -- initializing value is known to be non-null. We can also | |
7916 | -- set Can_Never_Be_Null if this is a constant. | |
70482933 | 7917 | |
ea588d41 EB |
7918 | elsif Is_Access_Type (Typ) and then Known_Non_Null (Expr) then |
7919 | Set_Is_Known_Non_Null (Def_Id, True); | |
47cc8d6b | 7920 | |
ea588d41 EB |
7921 | if Constant_Present (N) then |
7922 | Set_Can_Never_Be_Null (Def_Id); | |
95fef24f | 7923 | end if; |
47cc8d6b ES |
7924 | end if; |
7925 | ||
95fef24f AC |
7926 | -- If validity checking on copies, validate initial expression. |
7927 | -- But skip this if declaration is for a generic type, since it | |
7928 | -- makes no sense to validate generic types. Not clear if this | |
7929 | -- can happen for legal programs, but it definitely can arise | |
7930 | -- from previous instantiation errors. | |
70482933 | 7931 | |
95fef24f | 7932 | if Validity_Checks_On |
a5150cb1 | 7933 | and then Comes_From_Source (N) |
95fef24f | 7934 | and then Validity_Check_Copies |
dee004a9 | 7935 | and then not Is_Generic_Type (Typ) |
95fef24f AC |
7936 | then |
7937 | Ensure_Valid (Expr); | |
ea588d41 | 7938 | |
2749e4ab AO |
7939 | if Safe_To_Capture_Value (N, Def_Id) then |
7940 | Set_Is_Known_Valid (Def_Id); | |
7941 | end if; | |
95fef24f | 7942 | end if; |
aa683f5c EB |
7943 | |
7944 | -- Now determine whether we will use a renaming | |
7945 | ||
7946 | Rewrite_As_Renaming := | |
7947 | ||
69a70b0a | 7948 | -- The declaration cannot be rewritten if it has got constraints |
aa683f5c | 7949 | |
69a70b0a | 7950 | Is_Entity_Name (Original_Node (Obj_Def)) |
aa683f5c | 7951 | |
24993939 | 7952 | -- Nor if it is effectively an unconstrained declaration |
aa683f5c | 7953 | |
24993939 EB |
7954 | and then not (Is_Array_Type (Typ) |
7955 | and then Is_Constr_Subt_For_UN_Aliased (Typ)) | |
aa683f5c | 7956 | |
39a7b603 | 7957 | -- We may use a renaming if the initialization expression is a |
8daf80ff | 7958 | -- captured function call that meets a few conditions. |
133a8e63 | 7959 | |
69a70b0a | 7960 | and then |
8daf80ff | 7961 | (Is_Renamable_Function_Call (Expr_Q) |
69a70b0a | 7962 | |
8daf80ff | 7963 | -- Or else if it is a variable with OK_To_Rename set |
aa683f5c | 7964 | |
8313c5f6 EB |
7965 | or else (OK_To_Rename_Ref (Expr_Q) |
7966 | and then not Special_Ret_Obj) | |
aa683f5c | 7967 | |
8daf80ff | 7968 | -- Or else if it is a slice of such a variable |
aa683f5c | 7969 | |
69a70b0a | 7970 | or else (Nkind (Expr_Q) = N_Slice |
8313c5f6 EB |
7971 | and then OK_To_Rename_Ref (Prefix (Expr_Q)) |
7972 | and then not Special_Ret_Obj)); | |
aa683f5c EB |
7973 | |
7974 | -- If the type needs finalization and is not inherently limited, | |
7975 | -- then the target is adjusted after the copy and attached to the | |
7976 | -- finalization list. However, no adjustment is needed in the case | |
7977 | -- where the object has been initialized by a call to a function | |
7978 | -- returning on the primary stack (see Expand_Ctrl_Function_Call) | |
7979 | -- since no copy occurred, given that the type is by-reference. | |
7980 | -- Similarly, no adjustment is needed if we are going to rewrite | |
7981 | -- the object declaration into a renaming declaration. | |
7982 | ||
7983 | if Needs_Finalization (Typ) | |
7984 | and then not Is_Limited_View (Typ) | |
7985 | and then Nkind (Expr_Q) /= N_Function_Call | |
7986 | and then not Rewrite_As_Renaming | |
7987 | then | |
7988 | Adj_Call := | |
7989 | Make_Adjust_Call ( | |
7990 | Obj_Ref => New_Occurrence_Of (Def_Id, Loc), | |
7991 | Typ => Base_Typ); | |
7992 | ||
8313c5f6 | 7993 | if Present (Adj_Call) and then not Special_Ret_Obj then |
aa683f5c EB |
7994 | Insert_Action_After (Init_After, Adj_Call); |
7995 | end if; | |
7996 | end if; | |
95fef24f | 7997 | end if; |
e6f69614 | 7998 | |
d4dfb005 BD |
7999 | -- Cases where the back end cannot handle the initialization |
8000 | -- directly. In such cases, we expand an assignment that will | |
8001 | -- be appropriately handled by Expand_N_Assignment_Statement. | |
47cc8d6b | 8002 | |
95fef24f AC |
8003 | -- The exclusion of the unconstrained case is wrong, but for now it |
8004 | -- is too much trouble ??? | |
47cc8d6b | 8005 | |
95fef24f AC |
8006 | if (Is_Possibly_Unaligned_Slice (Expr) |
8007 | or else (Is_Possibly_Unaligned_Object (Expr) | |
8008 | and then not Represented_As_Scalar (Etype (Expr)))) | |
8009 | and then not (Is_Array_Type (Etype (Expr)) | |
8010 | and then not Is_Constrained (Etype (Expr))) | |
8011 | then | |
8012 | declare | |
8013 | Stat : constant Node_Id := | |
8014 | Make_Assignment_Statement (Loc, | |
8015 | Name => New_Occurrence_Of (Def_Id, Loc), | |
8016 | Expression => Relocate_Node (Expr)); | |
8017 | begin | |
95fef24f AC |
8018 | Set_Assignment_OK (Name (Stat)); |
8019 | Set_No_Ctrl_Actions (Stat); | |
4844a259 EB |
8020 | Insert_Action_After (Init_After, Stat); |
8021 | Set_Expression (N, Empty); | |
8022 | Set_No_Initialization (N); | |
95fef24f AC |
8023 | end; |
8024 | end if; | |
95fef24f | 8025 | end if; |
e5a58fac | 8026 | |
24d2fbbe | 8027 | if Nkind (Obj_Def) = N_Access_Definition |
dee004a9 | 8028 | and then not Is_Local_Anonymous_Access (Typ) |
95fef24f AC |
8029 | then |
8030 | -- An Ada 2012 stand-alone object of an anonymous access type | |
ee4eee0a | 8031 | |
95fef24f AC |
8032 | declare |
8033 | Loc : constant Source_Ptr := Sloc (N); | |
ee4eee0a | 8034 | |
95fef24f AC |
8035 | Level : constant Entity_Id := |
8036 | Make_Defining_Identifier (Sloc (N), | |
8037 | Chars => | |
8038 | New_External_Name (Chars (Def_Id), Suffix => "L")); | |
70482933 | 8039 | |
95fef24f | 8040 | Level_Decl : Node_Id; |
948590aa | 8041 | Level_Expr : Node_Id; |
f4d379b8 | 8042 | |
95fef24f | 8043 | begin |
2e02ab86 | 8044 | Mutate_Ekind (Level, Ekind (Def_Id)); |
95fef24f AC |
8045 | Set_Etype (Level, Standard_Natural); |
8046 | Set_Scope (Level, Scope (Def_Id)); | |
04df6250 | 8047 | |
948590aa | 8048 | -- Set accessibility level of null |
70482933 | 8049 | |
948590aa | 8050 | if No (Expr) then |
95fef24f | 8051 | Level_Expr := |
d7e20130 JS |
8052 | Make_Integer_Literal |
8053 | (Loc, Scope_Depth (Standard_Standard)); | |
39f346aa | 8054 | |
948590aa JS |
8055 | -- When the expression of the object is a function which returns |
8056 | -- an anonymous access type the master of the call is the object | |
8057 | -- being initialized instead of the type. | |
8058 | ||
8059 | elsif Nkind (Expr) = N_Function_Call | |
8060 | and then Ekind (Etype (Name (Expr))) = E_Anonymous_Access_Type | |
8061 | then | |
66e97274 JS |
8062 | Level_Expr := Accessibility_Level |
8063 | (Def_Id, Object_Decl_Level); | |
948590aa JS |
8064 | |
8065 | -- General case | |
8066 | ||
95fef24f | 8067 | else |
66e97274 | 8068 | Level_Expr := Accessibility_Level (Expr, Dynamic_Level); |
39f346aa ES |
8069 | end if; |
8070 | ||
95fef24f AC |
8071 | Level_Decl := |
8072 | Make_Object_Declaration (Loc, | |
8073 | Defining_Identifier => Level, | |
8074 | Object_Definition => | |
8075 | New_Occurrence_Of (Standard_Natural, Loc), | |
8076 | Expression => Level_Expr, | |
8077 | Constant_Present => Constant_Present (N), | |
8078 | Has_Init_Expression => True); | |
70482933 | 8079 | |
95fef24f | 8080 | Insert_Action_After (Init_After, Level_Decl); |
70482933 | 8081 | |
95fef24f AC |
8082 | Set_Extra_Accessibility (Def_Id, Level); |
8083 | end; | |
8084 | end if; | |
70482933 | 8085 | |
95fef24f AC |
8086 | -- If the object is default initialized and its type is subject to |
8087 | -- pragma Default_Initial_Condition, add a runtime check to verify | |
8088 | -- the assumption of the pragma (SPARK RM 7.3.3). Generate: | |
70482933 | 8089 | |
f63d601b | 8090 | -- <Base_Typ>DIC (<Base_Typ> (Def_Id)); |
70482933 | 8091 | |
95fef24f | 8092 | -- Note that the check is generated for source objects only |
70482933 | 8093 | |
95fef24f | 8094 | if Comes_From_Source (Def_Id) |
f63d601b HK |
8095 | and then Has_DIC (Typ) |
8096 | and then Present (DIC_Procedure (Typ)) | |
f7937111 | 8097 | and then not Has_Null_Body (DIC_Procedure (Typ)) |
95fef24f | 8098 | and then not Has_Init_Expression (N) |
2237f94d | 8099 | and then No (Expr) |
a6c46713 | 8100 | and then not Is_Imported (Def_Id) |
70482933 RK |
8101 | then |
8102 | declare | |
f7937111 GD |
8103 | DIC_Call : constant Node_Id := |
8104 | Build_DIC_Call | |
8105 | (Loc, New_Occurrence_Of (Def_Id, Loc), Typ); | |
70482933 | 8106 | begin |
95fef24f AC |
8107 | if Present (Next_N) then |
8108 | Insert_Before_And_Analyze (Next_N, DIC_Call); | |
b878c938 | 8109 | |
95fef24f AC |
8110 | -- The object declaration is the last node in a declarative or a |
8111 | -- statement list. | |
40f07b4b | 8112 | |
95fef24f AC |
8113 | else |
8114 | Append_To (List_Containing (N), DIC_Call); | |
8115 | Analyze (DIC_Call); | |
8116 | end if; | |
8117 | end; | |
70482933 RK |
8118 | end if; |
8119 | ||
4844a259 EB |
8120 | -- If this is the return object of a build-in-place function, locate the |
8121 | -- implicit BIPaccess parameter designating the caller-supplied return | |
8122 | -- object and convert the declaration to a renaming of a dereference of | |
8123 | -- this parameter. If the declaration includes an expression, add an | |
8124 | -- assignment statement to ensure the return object gets initialized. | |
8125 | ||
8126 | -- Result : T [:= <expression>]; | |
8127 | ||
8128 | -- is converted to | |
8129 | ||
8130 | -- Result : T renames BIPaccess.all; | |
8131 | -- [Result := <expression>;] | |
8132 | ||
8133 | -- in the constrained case, or to | |
8134 | ||
8135 | -- type Txx is access all ...; | |
8136 | -- Rxx : Txx := null; | |
8137 | ||
8138 | -- if BIPalloc = 1 then | |
8139 | -- Rxx := BIPaccess; | |
dee004a9 | 8140 | -- Rxx.all := <expression>; |
4844a259 | 8141 | -- elsif BIPalloc = 2 then |
dee004a9 | 8142 | -- Rxx := new <expression-type>'(<expression>)[storage_pool = |
4844a259 EB |
8143 | -- system__secondary_stack__ss_pool][procedure_to_call = |
8144 | -- system__secondary_stack__ss_allocate]; | |
8145 | -- elsif BIPalloc = 3 then | |
dee004a9 | 8146 | -- Rxx := new <expression-type>'(<expression>) |
4844a259 EB |
8147 | -- elsif BIPalloc = 4 then |
8148 | -- Pxx : system__storage_pools__root_storage_pool renames | |
8149 | -- BIPstoragepool.all; | |
dee004a9 | 8150 | -- Rxx := new <expression-type>'(<expression>)[storage_pool = |
4844a259 EB |
8151 | -- Pxx][procedure_to_call = |
8152 | -- system__storage_pools__allocate_any]; | |
8153 | -- else | |
8154 | -- [program_error "build in place mismatch"] | |
8155 | -- end if; | |
8156 | ||
8157 | -- Result : T renames Rxx.all; | |
4844a259 EB |
8158 | |
8159 | -- in the unconstrained case. | |
8160 | ||
8161 | if Is_Build_In_Place_Return_Object (Def_Id) then | |
8162 | declare | |
8daf80ff EB |
8163 | Init_Stmt : Node_Id; |
8164 | Obj_Acc_Formal : Entity_Id; | |
4844a259 EB |
8165 | |
8166 | begin | |
8167 | -- Retrieve the implicit access parameter passed by the caller | |
8168 | ||
8169 | Obj_Acc_Formal := | |
8170 | Build_In_Place_Formal (Func_Id, BIP_Object_Access); | |
8171 | ||
8172 | -- If the return object's declaration includes an expression | |
8173 | -- and the declaration isn't marked as No_Initialization, then | |
8174 | -- we need to generate an assignment to the object and insert | |
8175 | -- it after the declaration before rewriting it as a renaming | |
8176 | -- (otherwise we'll lose the initialization). The case where | |
8177 | -- the result type is an interface (or class-wide interface) | |
8178 | -- is also excluded because the context of the function call | |
8179 | -- must be unconstrained, so the initialization will always | |
8180 | -- be done as part of an allocator evaluation (storage pool | |
8181 | -- or secondary stack), never to a constrained target object | |
8182 | -- passed in by the caller. Besides the assignment being | |
8183 | -- unneeded in this case, it avoids problems with trying to | |
8184 | -- generate a dispatching assignment when the return expression | |
8185 | -- is a nonlimited descendant of a limited interface (the | |
8186 | -- interface has no assignment operation). | |
8187 | ||
8188 | if Present (Expr_Q) | |
8189 | and then not Is_Delayed_Aggregate (Expr_Q) | |
8190 | and then not No_Initialization (N) | |
dee004a9 | 8191 | and then not Is_Interface (Typ) |
4844a259 | 8192 | then |
dee004a9 | 8193 | if Is_Class_Wide_Type (Typ) |
4844a259 EB |
8194 | and then not Is_Class_Wide_Type (Etype (Expr_Q)) |
8195 | then | |
8196 | Init_Stmt := | |
8197 | Make_Assignment_Statement (Loc, | |
8198 | Name => New_Occurrence_Of (Def_Id, Loc), | |
8199 | Expression => | |
8200 | Make_Type_Conversion (Loc, | |
8201 | Subtype_Mark => | |
dee004a9 | 8202 | New_Occurrence_Of (Typ, Loc), |
4844a259 EB |
8203 | Expression => New_Copy_Tree (Expr_Q))); |
8204 | ||
8205 | else | |
8206 | Init_Stmt := | |
8207 | Make_Assignment_Statement (Loc, | |
8208 | Name => New_Occurrence_Of (Def_Id, Loc), | |
8209 | Expression => New_Copy_Tree (Expr_Q)); | |
8210 | end if; | |
8211 | ||
8212 | Set_Assignment_OK (Name (Init_Stmt)); | |
8213 | Set_No_Ctrl_Actions (Init_Stmt); | |
8214 | ||
8215 | else | |
8216 | Init_Stmt := Empty; | |
8217 | end if; | |
8218 | ||
8219 | -- When the function's subtype is unconstrained, a run-time | |
8220 | -- test may be needed to decide the form of allocation to use | |
8221 | -- for the return object. The function has an implicit formal | |
8222 | -- parameter indicating this. If the BIP_Alloc_Form formal has | |
8223 | -- the value one, then the caller has passed access to an | |
8224 | -- existing object for use as the return object. If the value | |
8225 | -- is two, then the return object must be allocated on the | |
baa3015d EB |
8226 | -- secondary stack. If the value is three, then the return |
8227 | -- object must be allocated on the heap. Otherwise, the object | |
8228 | -- must be allocated in a storage pool. We generate an if | |
8229 | -- statement to test the BIP_Alloc_Form formal and initialize | |
8230 | -- a local access value appropriately. | |
4844a259 EB |
8231 | |
8232 | if Needs_BIP_Alloc_Form (Func_Id) then | |
8233 | declare | |
8234 | Desig_Typ : constant Entity_Id := | |
dee004a9 EB |
8235 | (if Ekind (Typ) = E_Array_Subtype |
8236 | then Etype (Func_Id) else Typ); | |
4844a259 EB |
8237 | -- Ensure that the we use a fat pointer when allocating |
8238 | -- an unconstrained array on the heap. In this case the | |
dee004a9 EB |
8239 | -- result object's type is a constrained array type even |
8240 | -- though the function's type is unconstrained. | |
ea588d41 | 8241 | |
4844a259 EB |
8242 | Obj_Alloc_Formal : constant Entity_Id := |
8243 | Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); | |
8244 | Pool_Id : constant Entity_Id := | |
8245 | Make_Temporary (Loc, 'P'); | |
8246 | ||
dee004a9 | 8247 | Acc_Typ : Entity_Id; |
4844a259 | 8248 | Alloc_Obj_Decl : Node_Id; |
dee004a9 EB |
8249 | Alloc_Obj_Id : Entity_Id; |
8250 | Alloc_Stmt : Node_Id; | |
4844a259 EB |
8251 | Guard_Except : Node_Id; |
8252 | Heap_Allocator : Node_Id; | |
4844a259 | 8253 | Pool_Allocator : Node_Id; |
dee004a9 EB |
8254 | Pool_Decl : Node_Id; |
8255 | Ptr_Typ_Decl : Node_Id; | |
4844a259 EB |
8256 | SS_Allocator : Node_Id; |
8257 | ||
8258 | begin | |
8259 | -- Create an access type designating the function's | |
8260 | -- result subtype. | |
8261 | ||
dee004a9 | 8262 | Acc_Typ := Make_Temporary (Loc, 'A'); |
4844a259 | 8263 | |
dee004a9 | 8264 | Ptr_Typ_Decl := |
4844a259 | 8265 | Make_Full_Type_Declaration (Loc, |
dee004a9 | 8266 | Defining_Identifier => Acc_Typ, |
4844a259 EB |
8267 | Type_Definition => |
8268 | Make_Access_To_Object_Definition (Loc, | |
8269 | All_Present => True, | |
8270 | Subtype_Indication => | |
8271 | New_Occurrence_Of (Desig_Typ, Loc))); | |
8272 | ||
dee004a9 | 8273 | Insert_Action (N, Ptr_Typ_Decl, Suppress => All_Checks); |
4844a259 EB |
8274 | |
8275 | -- Create an access object that will be initialized to an | |
8276 | -- access value denoting the return object, either coming | |
8277 | -- from an implicit access value passed in by the caller | |
8278 | -- or from the result of an allocator. | |
8279 | ||
8280 | Alloc_Obj_Id := Make_Temporary (Loc, 'R'); | |
4844a259 EB |
8281 | |
8282 | Alloc_Obj_Decl := | |
8283 | Make_Object_Declaration (Loc, | |
8284 | Defining_Identifier => Alloc_Obj_Id, | |
8285 | Object_Definition => | |
dee004a9 | 8286 | New_Occurrence_Of (Acc_Typ, Loc)); |
4844a259 | 8287 | |
dee004a9 | 8288 | Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks); |
4844a259 | 8289 | |
baa3015d | 8290 | -- First create the Heap_Allocator |
4844a259 | 8291 | |
ea588d41 | 8292 | Heap_Allocator := Make_Allocator_For_Return (Expr_Q); |
4844a259 EB |
8293 | |
8294 | -- The Pool_Allocator is just like the Heap_Allocator, | |
8295 | -- except we set Storage_Pool and Procedure_To_Call so | |
8296 | -- it will use the user-defined storage pool. | |
8297 | ||
ea588d41 | 8298 | Pool_Allocator := Make_Allocator_For_Return (Expr_Q); |
4844a259 EB |
8299 | |
8300 | -- Do not generate the renaming of the build-in-place | |
8301 | -- pool parameter on ZFP because the parameter is not | |
8302 | -- created in the first place. | |
8303 | ||
8304 | if RTE_Available (RE_Root_Storage_Pool_Ptr) then | |
8305 | Pool_Decl := | |
8306 | Make_Object_Renaming_Declaration (Loc, | |
8307 | Defining_Identifier => Pool_Id, | |
8308 | Subtype_Mark => | |
8309 | New_Occurrence_Of | |
8310 | (RTE (RE_Root_Storage_Pool), Loc), | |
8311 | Name => | |
8312 | Make_Explicit_Dereference (Loc, | |
8313 | New_Occurrence_Of | |
8314 | (Build_In_Place_Formal | |
8315 | (Func_Id, BIP_Storage_Pool), Loc))); | |
8316 | Set_Storage_Pool (Pool_Allocator, Pool_Id); | |
8317 | Set_Procedure_To_Call | |
8318 | (Pool_Allocator, RTE (RE_Allocate_Any)); | |
8319 | else | |
8320 | Pool_Decl := Make_Null_Statement (Loc); | |
8321 | end if; | |
8322 | ||
8323 | -- If the No_Allocators restriction is active, then only | |
8324 | -- an allocator for secondary stack allocation is needed. | |
8325 | -- It's OK for such allocators to have Comes_From_Source | |
8326 | -- set to False, because gigi knows not to flag them as | |
8327 | -- being a violation of No_Implicit_Heap_Allocations. | |
8328 | ||
8329 | if Restriction_Active (No_Allocators) then | |
8330 | SS_Allocator := Heap_Allocator; | |
8331 | Heap_Allocator := Make_Null (Loc); | |
8332 | Pool_Allocator := Make_Null (Loc); | |
8333 | ||
8334 | -- Otherwise the heap and pool allocators may be needed, | |
8335 | -- so we make another allocator for secondary stack | |
8336 | -- allocation. | |
8337 | ||
8338 | else | |
ea588d41 | 8339 | SS_Allocator := Make_Allocator_For_Return (Expr_Q); |
4844a259 EB |
8340 | |
8341 | -- The heap and pool allocators are marked as | |
8342 | -- Comes_From_Source since they correspond to an | |
8343 | -- explicit user-written allocator (that is, it will | |
8344 | -- only be executed on behalf of callers that call the | |
8345 | -- function as initialization for such an allocator). | |
8346 | -- Prevents errors when No_Implicit_Heap_Allocations | |
8347 | -- is in force. | |
8348 | ||
8349 | Set_Comes_From_Source (Heap_Allocator, True); | |
8350 | Set_Comes_From_Source (Pool_Allocator, True); | |
8351 | end if; | |
8352 | ||
8353 | -- The allocator is returned on the secondary stack | |
8354 | ||
8355 | Check_Restriction (No_Secondary_Stack, N); | |
8356 | Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); | |
8357 | Set_Procedure_To_Call | |
8358 | (SS_Allocator, RTE (RE_SS_Allocate)); | |
8359 | ||
8360 | -- The allocator is returned on the secondary stack, | |
8361 | -- so indicate that the function return, as well as | |
8362 | -- all blocks that encloses the allocator, must not | |
8363 | -- release it. The flags must be set now because | |
8364 | -- the decision to use the secondary stack is done | |
8365 | -- very late in the course of expanding the return | |
8366 | -- statement, past the point where these flags are | |
8367 | -- normally set. | |
8368 | ||
8369 | Set_Uses_Sec_Stack (Func_Id); | |
8370 | Set_Uses_Sec_Stack (Scope (Def_Id)); | |
8371 | Set_Sec_Stack_Needed_For_Return (Scope (Def_Id)); | |
8372 | ||
8373 | -- Guard against poor expansion on the caller side by | |
8374 | -- using a raise statement to catch out-of-range values | |
8375 | -- of formal parameter BIP_Alloc_Form. | |
8376 | ||
8377 | if Exceptions_OK then | |
8378 | Guard_Except := | |
8379 | Make_Raise_Program_Error (Loc, | |
8380 | Reason => PE_Build_In_Place_Mismatch); | |
8381 | else | |
8382 | Guard_Except := Make_Null_Statement (Loc); | |
8383 | end if; | |
8384 | ||
8385 | -- Create an if statement to test the BIP_Alloc_Form | |
8386 | -- formal and initialize the access object to either the | |
8387 | -- BIP_Object_Access formal (BIP_Alloc_Form = | |
8388 | -- Caller_Allocation), the result of allocating the | |
8389 | -- object in the secondary stack (BIP_Alloc_Form = | |
8390 | -- Secondary_Stack), or else an allocator to create the | |
8391 | -- return object in the heap or user-defined pool | |
8392 | -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool). | |
8393 | ||
8394 | -- ??? An unchecked type conversion must be made in the | |
8395 | -- case of assigning the access object formal to the | |
8396 | -- local access object, because a normal conversion would | |
8397 | -- be illegal in some cases (such as converting access- | |
8398 | -- to-unconstrained to access-to-constrained), but the | |
8399 | -- the unchecked conversion will presumably fail to work | |
8400 | -- right in just such cases. It's not clear at all how to | |
dee004a9 | 8401 | -- handle this. |
4844a259 EB |
8402 | |
8403 | Alloc_Stmt := | |
8404 | Make_If_Statement (Loc, | |
8405 | Condition => | |
8406 | Make_Op_Eq (Loc, | |
8407 | Left_Opnd => | |
8408 | New_Occurrence_Of (Obj_Alloc_Formal, Loc), | |
8409 | Right_Opnd => | |
8410 | Make_Integer_Literal (Loc, | |
8411 | UI_From_Int (BIP_Allocation_Form'Pos | |
8412 | (Caller_Allocation)))), | |
8413 | ||
8414 | Then_Statements => New_List ( | |
8415 | Make_Assignment_Statement (Loc, | |
8416 | Name => | |
8417 | New_Occurrence_Of (Alloc_Obj_Id, Loc), | |
8418 | Expression => | |
8419 | Unchecked_Convert_To | |
dee004a9 | 8420 | (Acc_Typ, |
4844a259 EB |
8421 | New_Occurrence_Of (Obj_Acc_Formal, Loc)))), |
8422 | ||
8423 | Elsif_Parts => New_List ( | |
8424 | Make_Elsif_Part (Loc, | |
8425 | Condition => | |
8426 | Make_Op_Eq (Loc, | |
8427 | Left_Opnd => | |
8428 | New_Occurrence_Of (Obj_Alloc_Formal, Loc), | |
8429 | Right_Opnd => | |
8430 | Make_Integer_Literal (Loc, | |
8431 | UI_From_Int (BIP_Allocation_Form'Pos | |
8432 | (Secondary_Stack)))), | |
8433 | ||
8434 | Then_Statements => New_List ( | |
8435 | Make_Assignment_Statement (Loc, | |
8436 | Name => | |
8437 | New_Occurrence_Of (Alloc_Obj_Id, Loc), | |
8438 | Expression => SS_Allocator))), | |
8439 | ||
8440 | Make_Elsif_Part (Loc, | |
8441 | Condition => | |
8442 | Make_Op_Eq (Loc, | |
8443 | Left_Opnd => | |
8444 | New_Occurrence_Of (Obj_Alloc_Formal, Loc), | |
8445 | Right_Opnd => | |
8446 | Make_Integer_Literal (Loc, | |
8447 | UI_From_Int (BIP_Allocation_Form'Pos | |
8448 | (Global_Heap)))), | |
8449 | ||
8450 | Then_Statements => New_List ( | |
8451 | Build_Heap_Or_Pool_Allocator | |
8452 | (Temp_Id => Alloc_Obj_Id, | |
dee004a9 | 8453 | Temp_Typ => Acc_Typ, |
4844a259 EB |
8454 | Ret_Typ => Desig_Typ, |
8455 | Alloc_Expr => Heap_Allocator))), | |
8456 | ||
dee004a9 | 8457 | -- ??? If all is well, we can put the following |
4844a259 EB |
8458 | -- 'elsif' in the 'else', but this is a useful |
8459 | -- self-check in case caller and callee don't agree | |
8460 | -- on whether BIPAlloc and so on should be passed. | |
8461 | ||
8462 | Make_Elsif_Part (Loc, | |
8463 | Condition => | |
8464 | Make_Op_Eq (Loc, | |
8465 | Left_Opnd => | |
8466 | New_Occurrence_Of (Obj_Alloc_Formal, Loc), | |
8467 | Right_Opnd => | |
8468 | Make_Integer_Literal (Loc, | |
8469 | UI_From_Int (BIP_Allocation_Form'Pos | |
8470 | (User_Storage_Pool)))), | |
8471 | ||
8472 | Then_Statements => New_List ( | |
8473 | Pool_Decl, | |
8474 | Build_Heap_Or_Pool_Allocator | |
8475 | (Temp_Id => Alloc_Obj_Id, | |
dee004a9 | 8476 | Temp_Typ => Acc_Typ, |
4844a259 EB |
8477 | Ret_Typ => Desig_Typ, |
8478 | Alloc_Expr => Pool_Allocator)))), | |
8479 | ||
8480 | -- Raise Program_Error if it's none of the above; | |
8481 | -- this is a compiler bug. | |
8482 | ||
8483 | Else_Statements => New_List (Guard_Except)); | |
8484 | ||
8485 | -- If a separate initialization assignment was created | |
8486 | -- earlier, append that following the assignment of the | |
8487 | -- implicit access formal to the access object, to ensure | |
8488 | -- that the return object is initialized in that case. In | |
8489 | -- this situation, the target of the assignment must be | |
8490 | -- rewritten to denote a dereference of the access to the | |
8491 | -- return object passed in by the caller. | |
8492 | ||
8493 | if Present (Init_Stmt) then | |
8494 | Set_Name (Init_Stmt, | |
8495 | Make_Explicit_Dereference (Loc, | |
8496 | Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc))); | |
8497 | Set_Assignment_OK (Name (Init_Stmt)); | |
8498 | ||
8499 | Append_To (Then_Statements (Alloc_Stmt), Init_Stmt); | |
8500 | Init_Stmt := Empty; | |
8501 | end if; | |
8502 | ||
8503 | Insert_Action (N, Alloc_Stmt, Suppress => All_Checks); | |
8504 | ||
8505 | -- From now on, the type of the return object is the | |
8506 | -- designated type. | |
8507 | ||
ea588d41 EB |
8508 | if Desig_Typ /= Typ then |
8509 | Set_Etype (Def_Id, Desig_Typ); | |
8510 | Set_Actual_Subtype (Def_Id, Typ); | |
8511 | end if; | |
4844a259 EB |
8512 | |
8513 | -- Remember the local access object for use in the | |
8514 | -- dereference of the renaming created below. | |
8515 | ||
8516 | Obj_Acc_Formal := Alloc_Obj_Id; | |
8517 | end; | |
8518 | ||
dee004a9 EB |
8519 | -- When the function's type is unconstrained and a run-time test |
8520 | -- is not needed, we nevertheless need to build the return using | |
8521 | -- the return object's type. | |
4844a259 EB |
8522 | |
8523 | elsif not Is_Constrained (Underlying_Type (Etype (Func_Id))) then | |
8524 | declare | |
dee004a9 | 8525 | Acc_Typ : Entity_Id; |
4844a259 | 8526 | Alloc_Obj_Decl : Node_Id; |
dee004a9 EB |
8527 | Alloc_Obj_Id : Entity_Id; |
8528 | Ptr_Typ_Decl : Node_Id; | |
4844a259 EB |
8529 | |
8530 | begin | |
8531 | -- Create an access type designating the function's | |
8532 | -- result subtype. | |
8533 | ||
dee004a9 | 8534 | Acc_Typ := Make_Temporary (Loc, 'A'); |
4844a259 | 8535 | |
dee004a9 | 8536 | Ptr_Typ_Decl := |
4844a259 | 8537 | Make_Full_Type_Declaration (Loc, |
dee004a9 | 8538 | Defining_Identifier => Acc_Typ, |
4844a259 EB |
8539 | Type_Definition => |
8540 | Make_Access_To_Object_Definition (Loc, | |
8541 | All_Present => True, | |
8542 | Subtype_Indication => | |
dee004a9 | 8543 | New_Occurrence_Of (Typ, Loc))); |
4844a259 | 8544 | |
dee004a9 | 8545 | Insert_Action (N, Ptr_Typ_Decl, Suppress => All_Checks); |
4844a259 EB |
8546 | |
8547 | -- Create an access object initialized to the conversion | |
8548 | -- of the implicit access value passed in by the caller. | |
8549 | ||
8550 | Alloc_Obj_Id := Make_Temporary (Loc, 'R'); | |
8551 | ||
8552 | -- See the ??? comment a few lines above about the use of | |
8553 | -- an unchecked conversion here. | |
8554 | ||
8555 | Alloc_Obj_Decl := | |
8556 | Make_Object_Declaration (Loc, | |
8557 | Defining_Identifier => Alloc_Obj_Id, | |
ea588d41 | 8558 | Constant_Present => True, |
4844a259 | 8559 | Object_Definition => |
dee004a9 | 8560 | New_Occurrence_Of (Acc_Typ, Loc), |
4844a259 EB |
8561 | Expression => |
8562 | Unchecked_Convert_To | |
dee004a9 | 8563 | (Acc_Typ, New_Occurrence_Of (Obj_Acc_Formal, Loc))); |
4844a259 EB |
8564 | |
8565 | Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks); | |
8566 | ||
8567 | -- Remember the local access object for use in the | |
8568 | -- dereference of the renaming created below. | |
8569 | ||
8570 | Obj_Acc_Formal := Alloc_Obj_Id; | |
8571 | end; | |
8572 | end if; | |
8573 | ||
8574 | -- Initialize the object now that it has got its final subtype, | |
8575 | -- but before rewriting it as a renaming. | |
8576 | ||
ea588d41 EB |
8577 | Initialize_Return_Object |
8578 | (Tag_Assign, Adj_Call, Expr_Q, Init_Stmt, Init_After); | |
4844a259 | 8579 | |
ea588d41 EB |
8580 | -- Replace the return object declaration with a renaming of a |
8581 | -- dereference of the access value designating the return object. | |
4844a259 | 8582 | |
ea588d41 EB |
8583 | Expr_Q := |
8584 | Make_Explicit_Dereference (Loc, | |
8585 | Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc)); | |
8586 | Set_Etype (Expr_Q, Etype (Def_Id)); | |
8587 | ||
8588 | Rewrite_As_Renaming := True; | |
8589 | end; | |
8590 | ||
8591 | -- If we can rename the initialization expression, we need to make sure | |
8592 | -- that we use the proper type in the case of a return object that lives | |
d990f34e EB |
8593 | -- on the secondary stack (see other cases below for a similar handling) |
8594 | -- and that the tag is assigned in the case of any return object. | |
ea588d41 EB |
8595 | |
8596 | elsif Rewrite_As_Renaming then | |
133a8e63 | 8597 | if Special_Ret_Obj then |
ea588d41 | 8598 | declare |
ea588d41 EB |
8599 | Desig_Typ : constant Entity_Id := |
8600 | (if Ekind (Typ) = E_Array_Subtype | |
8601 | then Etype (Func_Id) else Typ); | |
8602 | ||
8603 | begin | |
8604 | -- From now on, the type of the return object is the | |
8605 | -- designated type. | |
8606 | ||
8607 | if Desig_Typ /= Typ then | |
8608 | Set_Etype (Def_Id, Desig_Typ); | |
8609 | Set_Actual_Subtype (Def_Id, Typ); | |
8610 | end if; | |
ea588d41 | 8611 | |
133a8e63 EB |
8612 | if Present (Tag_Assign) then |
8613 | Insert_Action_After (Init_After, Tag_Assign); | |
8614 | end if; | |
8615 | ||
8616 | -- Ada 2005 (AI95-344): If the result type is class-wide, | |
8617 | -- insert a check that the level of the return expression's | |
8618 | -- underlying type is not deeper than the level of the master | |
8619 | -- enclosing the function. | |
8620 | ||
8621 | -- AI12-043: The check is made immediately after the return | |
8622 | -- object is created. | |
8623 | ||
8624 | if Is_Class_Wide_Type (Etype (Func_Id)) then | |
8625 | Apply_CW_Accessibility_Check (Expr_Q, Func_Id); | |
8626 | end if; | |
8627 | end; | |
d990f34e EB |
8628 | end if; |
8629 | ||
ea588d41 EB |
8630 | -- If this is the return object of a function returning on the secondary |
8631 | -- stack, convert the declaration to a renaming of the dereference of ah | |
8632 | -- allocator for the secondary stack. | |
8633 | ||
8634 | -- Result : T [:= <expression>]; | |
8635 | ||
8636 | -- is converted to | |
8637 | ||
8638 | -- type Txx is access all ...; | |
8639 | -- Rxx : constant Txx := | |
8640 | -- new <expression-type>['(<expression>)][storage_pool = | |
8641 | -- system__secondary_stack__ss_pool][procedure_to_call = | |
8642 | -- system__secondary_stack__ss_allocate]; | |
8643 | ||
8644 | -- Result : T renames Rxx.all; | |
8645 | ||
8646 | elsif Is_Secondary_Stack_Return_Object (Def_Id) then | |
8647 | declare | |
ea588d41 EB |
8648 | Desig_Typ : constant Entity_Id := |
8649 | (if Ekind (Typ) = E_Array_Subtype | |
8650 | then Etype (Func_Id) else Typ); | |
8651 | -- Ensure that the we use a fat pointer when allocating | |
8652 | -- an unconstrained array on the heap. In this case the | |
8653 | -- result object's type is a constrained array type even | |
8654 | -- though the function's type is unconstrained. | |
8655 | ||
8656 | Acc_Typ : Entity_Id; | |
8657 | Alloc_Obj_Decl : Node_Id; | |
8658 | Alloc_Obj_Id : Entity_Id; | |
8659 | Ptr_Type_Decl : Node_Id; | |
8660 | ||
8661 | begin | |
8662 | -- Create an access type designating the function's | |
8663 | -- result subtype. | |
8664 | ||
8665 | Acc_Typ := Make_Temporary (Loc, 'A'); | |
8666 | ||
8667 | Ptr_Type_Decl := | |
8668 | Make_Full_Type_Declaration (Loc, | |
8669 | Defining_Identifier => Acc_Typ, | |
8670 | Type_Definition => | |
8671 | Make_Access_To_Object_Definition (Loc, | |
8672 | All_Present => True, | |
8673 | Subtype_Indication => | |
8674 | New_Occurrence_Of (Desig_Typ, Loc))); | |
8675 | ||
8676 | Insert_Action (N, Ptr_Type_Decl, Suppress => All_Checks); | |
8677 | ||
8678 | Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); | |
8679 | ||
8680 | Alloc_Obj_Id := Make_Temporary (Loc, 'R'); | |
8681 | ||
8682 | Alloc_Obj_Decl := | |
8683 | Make_Object_Declaration (Loc, | |
8684 | Defining_Identifier => Alloc_Obj_Id, | |
8685 | Constant_Present => True, | |
8686 | Object_Definition => | |
8687 | New_Occurrence_Of (Acc_Typ, Loc), | |
8688 | Expression => Make_Allocator_For_Return (Expr_Q)); | |
8689 | ||
8690 | Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks); | |
8691 | ||
8692 | Set_Uses_Sec_Stack (Func_Id); | |
8693 | Set_Uses_Sec_Stack (Scope (Def_Id)); | |
8694 | Set_Sec_Stack_Needed_For_Return (Scope (Def_Id)); | |
8695 | ||
8696 | -- From now on, the type of the return object is the | |
8697 | -- designated type. | |
8698 | ||
8699 | if Desig_Typ /= Typ then | |
8700 | Set_Etype (Def_Id, Desig_Typ); | |
8701 | Set_Actual_Subtype (Def_Id, Typ); | |
4844a259 EB |
8702 | end if; |
8703 | ||
ea588d41 EB |
8704 | -- Initialize the object now that it has got its final subtype, |
8705 | -- but before rewriting it as a renaming. | |
8706 | ||
8707 | Initialize_Return_Object | |
8708 | (Tag_Assign, Adj_Call, Expr_Q, Empty, Init_After); | |
8709 | ||
4844a259 EB |
8710 | -- Replace the return object declaration with a renaming of a |
8711 | -- dereference of the access value designating the return object. | |
8712 | ||
8713 | Expr_Q := | |
8714 | Make_Explicit_Dereference (Loc, | |
ea588d41 EB |
8715 | Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)); |
8716 | Set_Etype (Expr_Q, Etype (Def_Id)); | |
8717 | ||
8718 | Rewrite_As_Renaming := True; | |
8719 | end; | |
8720 | ||
8721 | -- If this is the return object of a function returning a by-reference | |
8722 | -- type, convert the declaration to a renaming of the dereference of ah | |
8723 | -- allocator for the return stack. | |
8724 | ||
8725 | -- Result : T [:= <expression>]; | |
8726 | ||
8727 | -- is converted to | |
8728 | ||
8729 | -- type Txx is access all ...; | |
8730 | -- Rxx : constant Txx := | |
8731 | -- new <expression-type>['(<expression>)][storage_pool = | |
229f5150 EB |
8732 | -- system__return_stack__rs_pool][procedure_to_call = |
8733 | -- system__return_stack__rs_allocate]; | |
ea588d41 EB |
8734 | |
8735 | -- Result : T renames Rxx.all; | |
8736 | ||
8737 | elsif Back_End_Return_Slot | |
8738 | and then Is_By_Reference_Return_Object (Def_Id) | |
8739 | then | |
8740 | declare | |
8741 | Acc_Typ : Entity_Id; | |
8742 | Alloc_Obj_Decl : Node_Id; | |
8743 | Alloc_Obj_Id : Entity_Id; | |
8744 | Ptr_Type_Decl : Node_Id; | |
8745 | ||
8746 | begin | |
8747 | -- Create an access type designating the function's | |
8748 | -- result subtype. | |
8749 | ||
8750 | Acc_Typ := Make_Temporary (Loc, 'A'); | |
8751 | ||
8752 | Ptr_Type_Decl := | |
8753 | Make_Full_Type_Declaration (Loc, | |
8754 | Defining_Identifier => Acc_Typ, | |
8755 | Type_Definition => | |
8756 | Make_Access_To_Object_Definition (Loc, | |
8757 | All_Present => True, | |
8758 | Subtype_Indication => | |
8759 | New_Occurrence_Of (Typ, Loc))); | |
8760 | ||
8761 | Insert_Action (N, Ptr_Type_Decl, Suppress => All_Checks); | |
8762 | ||
8763 | Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_RS_Pool)); | |
8764 | ||
8765 | Alloc_Obj_Id := Make_Temporary (Loc, 'R'); | |
8766 | ||
8767 | Alloc_Obj_Decl := | |
8768 | Make_Object_Declaration (Loc, | |
8769 | Defining_Identifier => Alloc_Obj_Id, | |
8770 | Constant_Present => True, | |
8771 | Object_Definition => | |
8772 | New_Occurrence_Of (Acc_Typ, Loc), | |
8773 | Expression => Make_Allocator_For_Return (Expr_Q)); | |
8774 | ||
8775 | Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks); | |
8776 | ||
8777 | -- Initialize the object now that it has got its final subtype, | |
8778 | -- but before rewriting it as a renaming. | |
8779 | ||
8780 | Initialize_Return_Object | |
8781 | (Tag_Assign, Adj_Call, Expr_Q, Empty, Init_After); | |
8782 | ||
8783 | -- Replace the return object declaration with a renaming of a | |
8784 | -- dereference of the access value designating the return object. | |
8785 | ||
8786 | Expr_Q := | |
8787 | Make_Explicit_Dereference (Loc, | |
8788 | Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)); | |
4844a259 EB |
8789 | Set_Etype (Expr_Q, Etype (Def_Id)); |
8790 | ||
8791 | Rewrite_As_Renaming := True; | |
8792 | end; | |
8793 | end if; | |
8794 | ||
c7518e6f AC |
8795 | -- Final transformation - turn the object declaration into a renaming |
8796 | -- if appropriate. If this is the completion of a deferred constant | |
8797 | -- declaration, then this transformation generates what would be | |
8798 | -- illegal code if written by hand, but that's OK. | |
24d2fbbe | 8799 | |
aa683f5c EB |
8800 | if Rewrite_As_Renaming then |
8801 | Rewrite (N, | |
8802 | Make_Object_Renaming_Declaration (Loc, | |
4844a259 EB |
8803 | Defining_Identifier => Def_Id, |
8804 | Subtype_Mark => New_Occurrence_Of (Etype (Def_Id), Loc), | |
aa683f5c | 8805 | Name => Expr_Q)); |
24d2fbbe | 8806 | |
aa683f5c EB |
8807 | -- We do not analyze this renaming declaration, because all its |
8808 | -- components have already been analyzed, and if we were to go | |
8809 | -- ahead and analyze it, we would in effect be trying to generate | |
8810 | -- another declaration of X, which won't do. | |
24d2fbbe | 8811 | |
4844a259 | 8812 | Set_Renamed_Object (Def_Id, Expr_Q); |
aa683f5c | 8813 | Set_Analyzed (N); |
24d2fbbe | 8814 | |
aa683f5c | 8815 | -- We do need to deal with debug issues for this renaming |
24d2fbbe | 8816 | |
aa683f5c EB |
8817 | -- First, if entity comes from source, then mark it as needing |
8818 | -- debug information, even though it is defined by a generated | |
8819 | -- renaming that does not come from source. | |
24d2fbbe | 8820 | |
aa683f5c | 8821 | Set_Debug_Info_Defining_Id (N); |
24d2fbbe | 8822 | |
aa683f5c | 8823 | -- Now call the routine to generate debug info for the renaming |
24d2fbbe | 8824 | |
aa683f5c | 8825 | Insert_Action (N, Debug_Renaming_Declaration (N)); |
24d2fbbe BD |
8826 | end if; |
8827 | ||
95fef24f | 8828 | -- Exception on library entity not available |
70482933 | 8829 | |
95fef24f AC |
8830 | exception |
8831 | when RE_Not_Available => | |
8832 | return; | |
8833 | end Expand_N_Object_Declaration; | |
70482933 | 8834 | |
95fef24f AC |
8835 | --------------------------------- |
8836 | -- Expand_N_Subtype_Indication -- | |
8837 | --------------------------------- | |
70482933 | 8838 | |
32115be8 | 8839 | -- Add a check on the range of the subtype and deal with validity checking |
70482933 | 8840 | |
95fef24f AC |
8841 | procedure Expand_N_Subtype_Indication (N : Node_Id) is |
8842 | Ran : constant Node_Id := Range_Expression (Constraint (N)); | |
8843 | Typ : constant Entity_Id := Entity (Subtype_Mark (N)); | |
70482933 | 8844 | |
95fef24f AC |
8845 | begin |
8846 | if Nkind (Constraint (N)) = N_Range_Constraint then | |
8847 | Validity_Check_Range (Range_Expression (Constraint (N))); | |
70482933 RK |
8848 | end if; |
8849 | ||
32115be8 EB |
8850 | -- Do not duplicate the work of Process_Range_Expr_In_Decl in Sem_Ch3 |
8851 | ||
4a08c95c AC |
8852 | if Nkind (Parent (N)) in N_Constrained_Array_Definition | N_Slice |
8853 | and then Nkind (Parent (Parent (N))) not in | |
8854 | N_Full_Type_Declaration | N_Object_Declaration | |
32115be8 | 8855 | then |
95fef24f AC |
8856 | Apply_Range_Check (Ran, Typ); |
8857 | end if; | |
8858 | end Expand_N_Subtype_Indication; | |
47cc8d6b | 8859 | |
95fef24f AC |
8860 | --------------------------- |
8861 | -- Expand_N_Variant_Part -- | |
8862 | --------------------------- | |
47cc8d6b | 8863 | |
95fef24f AC |
8864 | -- Note: this procedure no longer has any effect. It used to be that we |
8865 | -- would replace the choices in the last variant by a when others, and | |
8866 | -- also expanded static predicates in variant choices here, but both of | |
8867 | -- those activities were being done too early, since we can't check the | |
8868 | -- choices until the statically predicated subtypes are frozen, which can | |
8869 | -- happen as late as the free point of the record, and we can't change the | |
8870 | -- last choice to an others before checking the choices, which is now done | |
8871 | -- at the freeze point of the record. | |
47cc8d6b | 8872 | |
95fef24f AC |
8873 | procedure Expand_N_Variant_Part (N : Node_Id) is |
8874 | begin | |
8875 | null; | |
8876 | end Expand_N_Variant_Part; | |
70482933 | 8877 | |
95fef24f AC |
8878 | --------------------------------- |
8879 | -- Expand_Previous_Access_Type -- | |
8880 | --------------------------------- | |
70482933 | 8881 | |
95fef24f AC |
8882 | procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is |
8883 | Ptr_Typ : Entity_Id; | |
69fff50e | 8884 | |
95fef24f AC |
8885 | begin |
8886 | -- Find all access types in the current scope whose designated type is | |
8887 | -- Def_Id and build master renamings for them. | |
f2cbd970 | 8888 | |
95fef24f AC |
8889 | Ptr_Typ := First_Entity (Current_Scope); |
8890 | while Present (Ptr_Typ) loop | |
8891 | if Is_Access_Type (Ptr_Typ) | |
8892 | and then Designated_Type (Ptr_Typ) = Def_Id | |
8893 | and then No (Master_Id (Ptr_Typ)) | |
f2cbd970 | 8894 | then |
95fef24f | 8895 | -- Ensure that the designated type has a master |
ea1941af | 8896 | |
95fef24f AC |
8897 | Build_Master_Entity (Def_Id); |
8898 | ||
8899 | -- Private and incomplete types complicate the insertion of master | |
8900 | -- renamings because the access type may precede the full view of | |
8901 | -- the designated type. For this reason, the master renamings are | |
8902 | -- inserted relative to the designated type. | |
8903 | ||
8904 | Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id)); | |
8905 | end if; | |
ea1941af | 8906 | |
95fef24f AC |
8907 | Next_Entity (Ptr_Typ); |
8908 | end loop; | |
8909 | end Expand_Previous_Access_Type; | |
df3e68b1 | 8910 | |
95fef24f AC |
8911 | ----------------------------- |
8912 | -- Expand_Record_Extension -- | |
8913 | ----------------------------- | |
d3f70b35 | 8914 | |
95fef24f AC |
8915 | -- Add a field _parent at the beginning of the record extension. This is |
8916 | -- used to implement inheritance. Here are some examples of expansion: | |
70482933 | 8917 | |
95fef24f AC |
8918 | -- 1. no discriminants |
8919 | -- type T2 is new T1 with null record; | |
8920 | -- gives | |
8921 | -- type T2 is new T1 with record | |
8922 | -- _Parent : T1; | |
8923 | -- end record; | |
a05e99a2 | 8924 | |
95fef24f AC |
8925 | -- 2. renamed discriminants |
8926 | -- type T2 (B, C : Int) is new T1 (A => B) with record | |
8927 | -- _Parent : T1 (A => B); | |
8928 | -- D : Int; | |
8929 | -- end; | |
54ecb428 | 8930 | |
95fef24f AC |
8931 | -- 3. inherited discriminants |
8932 | -- type T2 is new T1 with record -- discriminant A inherited | |
8933 | -- _Parent : T1 (A); | |
8934 | -- D : Int; | |
8935 | -- end; | |
54ecb428 | 8936 | |
95fef24f AC |
8937 | procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is |
8938 | Indic : constant Node_Id := Subtype_Indication (Def); | |
8939 | Loc : constant Source_Ptr := Sloc (Def); | |
8940 | Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); | |
8941 | Par_Subtype : Entity_Id; | |
8942 | Comp_List : Node_Id; | |
8943 | Comp_Decl : Node_Id; | |
8944 | Parent_N : Node_Id; | |
8945 | D : Entity_Id; | |
8946 | List_Constr : constant List_Id := New_List; | |
54ecb428 | 8947 | |
95fef24f AC |
8948 | begin |
8949 | -- Expand_Record_Extension is called directly from the semantics, so | |
8950 | -- we must check to see whether expansion is active before proceeding, | |
8951 | -- because this affects the visibility of selected components in bodies | |
bb60efc5 ES |
8952 | -- of instances. Within a generic we still need to set Parent_Subtype |
8953 | -- link because the visibility of inherited components will have to be | |
8954 | -- verified in subsequent instances. | |
54ecb428 | 8955 | |
95fef24f | 8956 | if not Expander_Active then |
bb60efc5 ES |
8957 | if Inside_A_Generic and then Ekind (T) = E_Record_Type then |
8958 | Set_Parent_Subtype (T, Etype (T)); | |
8959 | end if; | |
95fef24f | 8960 | return; |
10b93b2e | 8961 | end if; |
df3e68b1 | 8962 | |
95fef24f AC |
8963 | -- This may be a derivation of an untagged private type whose full |
8964 | -- view is tagged, in which case the Derived_Type_Definition has no | |
8965 | -- extension part. Build an empty one now. | |
3647ca26 | 8966 | |
95fef24f AC |
8967 | if No (Rec_Ext_Part) then |
8968 | Rec_Ext_Part := | |
8969 | Make_Record_Definition (Loc, | |
8970 | End_Label => Empty, | |
8971 | Component_List => Empty, | |
8972 | Null_Present => True); | |
3647ca26 | 8973 | |
95fef24f AC |
8974 | Set_Record_Extension_Part (Def, Rec_Ext_Part); |
8975 | Mark_Rewrite_Insertion (Rec_Ext_Part); | |
8976 | end if; | |
df3e68b1 | 8977 | |
95fef24f | 8978 | Comp_List := Component_List (Rec_Ext_Part); |
df3e68b1 | 8979 | |
95fef24f | 8980 | Parent_N := Make_Defining_Identifier (Loc, Name_uParent); |
df3e68b1 | 8981 | |
95fef24f AC |
8982 | -- If the derived type inherits its discriminants the type of the |
8983 | -- _parent field must be constrained by the inherited discriminants | |
3647ca26 | 8984 | |
95fef24f AC |
8985 | if Has_Discriminants (T) |
8986 | and then Nkind (Indic) /= N_Subtype_Indication | |
8987 | and then not Is_Constrained (Entity (Indic)) | |
8988 | then | |
8989 | D := First_Discriminant (T); | |
8990 | while Present (D) loop | |
8991 | Append_To (List_Constr, New_Occurrence_Of (D, Loc)); | |
8992 | Next_Discriminant (D); | |
8993 | end loop; | |
3647ca26 | 8994 | |
95fef24f AC |
8995 | Par_Subtype := |
8996 | Process_Subtype ( | |
8997 | Make_Subtype_Indication (Loc, | |
8998 | Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc), | |
8999 | Constraint => | |
9000 | Make_Index_Or_Discriminant_Constraint (Loc, | |
9001 | Constraints => List_Constr)), | |
9002 | Def); | |
3647ca26 | 9003 | |
95fef24f | 9004 | -- Otherwise the original subtype_indication is just what is needed |
3647ca26 | 9005 | |
95fef24f AC |
9006 | else |
9007 | Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); | |
9008 | end if; | |
3647ca26 | 9009 | |
95fef24f | 9010 | Set_Parent_Subtype (T, Par_Subtype); |
3647ca26 | 9011 | |
95fef24f AC |
9012 | Comp_Decl := |
9013 | Make_Component_Declaration (Loc, | |
9014 | Defining_Identifier => Parent_N, | |
9015 | Component_Definition => | |
9016 | Make_Component_Definition (Loc, | |
9017 | Aliased_Present => False, | |
9018 | Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc))); | |
3647ca26 | 9019 | |
95fef24f AC |
9020 | if Null_Present (Rec_Ext_Part) then |
9021 | Set_Component_List (Rec_Ext_Part, | |
9022 | Make_Component_List (Loc, | |
9023 | Component_Items => New_List (Comp_Decl), | |
9024 | Variant_Part => Empty, | |
9025 | Null_Present => False)); | |
9026 | Set_Null_Present (Rec_Ext_Part, False); | |
3647ca26 | 9027 | |
95fef24f AC |
9028 | elsif Null_Present (Comp_List) |
9029 | or else Is_Empty_List (Component_Items (Comp_List)) | |
9030 | then | |
9031 | Set_Component_Items (Comp_List, New_List (Comp_Decl)); | |
9032 | Set_Null_Present (Comp_List, False); | |
3647ca26 | 9033 | |
95fef24f AC |
9034 | else |
9035 | Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); | |
9036 | end if; | |
3647ca26 | 9037 | |
95fef24f AC |
9038 | Analyze (Comp_Decl); |
9039 | end Expand_Record_Extension; | |
3647ca26 | 9040 | |
95fef24f AC |
9041 | ------------------------ |
9042 | -- Expand_Tagged_Root -- | |
9043 | ------------------------ | |
3647ca26 | 9044 | |
95fef24f AC |
9045 | procedure Expand_Tagged_Root (T : Entity_Id) is |
9046 | Def : constant Node_Id := Type_Definition (Parent (T)); | |
9047 | Comp_List : Node_Id; | |
9048 | Comp_Decl : Node_Id; | |
9049 | Sloc_N : Source_Ptr; | |
3647ca26 | 9050 | |
95fef24f AC |
9051 | begin |
9052 | if Null_Present (Def) then | |
9053 | Set_Component_List (Def, | |
9054 | Make_Component_List (Sloc (Def), | |
9055 | Component_Items => Empty_List, | |
9056 | Variant_Part => Empty, | |
9057 | Null_Present => True)); | |
3647ca26 | 9058 | end if; |
9e1902a9 | 9059 | |
95fef24f | 9060 | Comp_List := Component_List (Def); |
d85be3ba | 9061 | |
95fef24f AC |
9062 | if Null_Present (Comp_List) |
9063 | or else Is_Empty_List (Component_Items (Comp_List)) | |
9064 | then | |
9065 | Sloc_N := Sloc (Comp_List); | |
9066 | else | |
9067 | Sloc_N := Sloc (First (Component_Items (Comp_List))); | |
9068 | end if; | |
7c0c194b | 9069 | |
95fef24f AC |
9070 | Comp_Decl := |
9071 | Make_Component_Declaration (Sloc_N, | |
9072 | Defining_Identifier => First_Tag_Component (T), | |
9073 | Component_Definition => | |
9074 | Make_Component_Definition (Sloc_N, | |
9075 | Aliased_Present => False, | |
9076 | Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N))); | |
7c0c194b | 9077 | |
95fef24f AC |
9078 | if Null_Present (Comp_List) |
9079 | or else Is_Empty_List (Component_Items (Comp_List)) | |
9080 | then | |
9081 | Set_Component_Items (Comp_List, New_List (Comp_Decl)); | |
9082 | Set_Null_Present (Comp_List, False); | |
9083 | ||
9084 | else | |
9085 | Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); | |
7c0c194b | 9086 | end if; |
95fef24f AC |
9087 | |
9088 | -- We don't Analyze the whole expansion because the tag component has | |
9089 | -- already been analyzed previously. Here we just insure that the tree | |
9090 | -- is coherent with the semantic decoration | |
9091 | ||
9092 | Find_Type (Subtype_Indication (Component_Definition (Comp_Decl))); | |
9093 | ||
9094 | exception | |
9095 | when RE_Not_Available => | |
9096 | return; | |
9097 | end Expand_Tagged_Root; | |
70482933 | 9098 | |
07fc65c4 GB |
9099 | ------------------------------ |
9100 | -- Freeze_Stream_Operations -- | |
9101 | ------------------------------ | |
9102 | ||
9103 | procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is | |
fbf5a39b AC |
9104 | Names : constant array (1 .. 4) of TSS_Name_Type := |
9105 | (TSS_Stream_Input, | |
9106 | TSS_Stream_Output, | |
9107 | TSS_Stream_Read, | |
9108 | TSS_Stream_Write); | |
07fc65c4 GB |
9109 | Stream_Op : Entity_Id; |
9110 | ||
9111 | begin | |
9112 | -- Primitive operations of tagged types are frozen when the dispatch | |
9113 | -- table is constructed. | |
9114 | ||
24d4b3d5 | 9115 | if not Comes_From_Source (Typ) or else Is_Tagged_Type (Typ) then |
07fc65c4 GB |
9116 | return; |
9117 | end if; | |
9118 | ||
9119 | for J in Names'Range loop | |
9120 | Stream_Op := TSS (Typ, Names (J)); | |
9121 | ||
9122 | if Present (Stream_Op) | |
9123 | and then Is_Subprogram (Stream_Op) | |
9124 | and then Nkind (Unit_Declaration_Node (Stream_Op)) = | |
24d4b3d5 | 9125 | N_Subprogram_Declaration |
07fc65c4 GB |
9126 | and then not Is_Frozen (Stream_Op) |
9127 | then | |
c159409f | 9128 | Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N)); |
07fc65c4 GB |
9129 | end if; |
9130 | end loop; | |
9131 | end Freeze_Stream_Operations; | |
9132 | ||
70482933 RK |
9133 | ----------------- |
9134 | -- Freeze_Type -- | |
9135 | ----------------- | |
9136 | ||
a9d8907c JM |
9137 | -- Full type declarations are expanded at the point at which the type is |
9138 | -- frozen. The formal N is the Freeze_Node for the type. Any statements or | |
9139 | -- declarations generated by the freezing (e.g. the procedure generated | |
758c442c | 9140 | -- for initialization) are chained in the Actions field list of the freeze |
70482933 RK |
9141 | -- node using Append_Freeze_Actions. |
9142 | ||
b0bf18ad AC |
9143 | -- WARNING: This routine manages Ghost regions. Return statements must be |
9144 | -- replaced by gotos which jump to the end of the routine and restore the | |
9145 | -- Ghost mode. | |
9146 | ||
a9d8907c | 9147 | function Freeze_Type (N : Node_Id) return Boolean is |
760804f3 AC |
9148 | procedure Process_RACW_Types (Typ : Entity_Id); |
9149 | -- Validate and generate stubs for all RACW types associated with type | |
9150 | -- Typ. | |
9151 | ||
9152 | procedure Process_Pending_Access_Types (Typ : Entity_Id); | |
9153 | -- Associate type Typ's Finalize_Address primitive with the finalization | |
9154 | -- masters of pending access-to-Typ types. | |
9155 | ||
760804f3 AC |
9156 | ------------------------ |
9157 | -- Process_RACW_Types -- | |
9158 | ------------------------ | |
9159 | ||
9160 | procedure Process_RACW_Types (Typ : Entity_Id) is | |
9161 | List : constant Elist_Id := Access_Types_To_Process (N); | |
9162 | E : Elmt_Id; | |
9163 | Seen : Boolean := False; | |
9164 | ||
9165 | begin | |
9166 | if Present (List) then | |
9167 | E := First_Elmt (List); | |
9168 | while Present (E) loop | |
9169 | if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then | |
9170 | Validate_RACW_Primitives (Node (E)); | |
9171 | Seen := True; | |
9172 | end if; | |
9173 | ||
9174 | Next_Elmt (E); | |
9175 | end loop; | |
9176 | end if; | |
9177 | ||
9178 | -- If there are RACWs designating this type, make stubs now | |
9179 | ||
9180 | if Seen then | |
9181 | Remote_Types_Tagged_Full_View_Encountered (Typ); | |
9182 | end if; | |
9183 | end Process_RACW_Types; | |
9184 | ||
9185 | ---------------------------------- | |
9186 | -- Process_Pending_Access_Types -- | |
9187 | ---------------------------------- | |
9188 | ||
9189 | procedure Process_Pending_Access_Types (Typ : Entity_Id) is | |
9190 | E : Elmt_Id; | |
9191 | ||
9192 | begin | |
9193 | -- Finalize_Address is not generated in CodePeer mode because the | |
9194 | -- body contains address arithmetic. This processing is disabled. | |
9195 | ||
9196 | if CodePeer_Mode then | |
9197 | null; | |
9198 | ||
9199 | -- Certain itypes are generated for contexts that cannot allocate | |
9200 | -- objects and should not set primitive Finalize_Address. | |
9201 | ||
9202 | elsif Is_Itype (Typ) | |
9203 | and then Nkind (Associated_Node_For_Itype (Typ)) = | |
9204 | N_Explicit_Dereference | |
9205 | then | |
9206 | null; | |
9207 | ||
9208 | -- When an access type is declared after the incomplete view of a | |
9209 | -- Taft-amendment type, the access type is considered pending in | |
9210 | -- case the full view of the Taft-amendment type is controlled. If | |
9211 | -- this is indeed the case, associate the Finalize_Address routine | |
9212 | -- of the full view with the finalization masters of all pending | |
9213 | -- access types. This scenario applies to anonymous access types as | |
f23d4b88 EB |
9214 | -- well. But the Finalize_Address routine is missing if the type is |
9215 | -- class-wide and we are under restriction No_Dispatching_Calls, see | |
9216 | -- Expand_Freeze_Class_Wide_Type above for the rationale. | |
760804f3 AC |
9217 | |
9218 | elsif Needs_Finalization (Typ) | |
f23d4b88 EB |
9219 | and then (not Is_Class_Wide_Type (Typ) |
9220 | or else not Restriction_Active (No_Dispatching_Calls)) | |
760804f3 AC |
9221 | and then Present (Pending_Access_Types (Typ)) |
9222 | then | |
9223 | E := First_Elmt (Pending_Access_Types (Typ)); | |
9224 | while Present (E) loop | |
9225 | ||
9226 | -- Generate: | |
9227 | -- Set_Finalize_Address | |
9228 | -- (Ptr_Typ, <Typ>FD'Unrestricted_Access); | |
9229 | ||
9230 | Append_Freeze_Action (Typ, | |
9231 | Make_Set_Finalize_Address_Call | |
9232 | (Loc => Sloc (N), | |
9233 | Ptr_Typ => Node (E))); | |
9234 | ||
9235 | Next_Elmt (E); | |
9236 | end loop; | |
9237 | end if; | |
9238 | end Process_Pending_Access_Types; | |
9239 | ||
8636f52f HK |
9240 | -- Local variables |
9241 | ||
760804f3 | 9242 | Def_Id : constant Entity_Id := Entity (N); |
b2c1aa8f | 9243 | |
9057bd6a HK |
9244 | Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; |
9245 | Saved_IGR : constant Node_Id := Ignored_Ghost_Region; | |
9246 | -- Save the Ghost-related attributes to restore on exit | |
f9a8f910 HK |
9247 | |
9248 | Result : Boolean := False; | |
70482933 | 9249 | |
8636f52f HK |
9250 | -- Start of processing for Freeze_Type |
9251 | ||
70482933 | 9252 | begin |
1af4455a HK |
9253 | -- The type being frozen may be subject to pragma Ghost. Set the mode |
9254 | -- now to ensure that any nodes generated during freezing are properly | |
9255 | -- marked as Ghost. | |
8636f52f | 9256 | |
f9a8f910 | 9257 | Set_Ghost_Mode (Def_Id); |
8636f52f | 9258 | |
760804f3 AC |
9259 | -- Process any remote access-to-class-wide types designating the type |
9260 | -- being frozen. | |
fbf5a39b | 9261 | |
760804f3 | 9262 | Process_RACW_Types (Def_Id); |
70482933 RK |
9263 | |
9264 | -- Freeze processing for record types | |
9265 | ||
9266 | if Is_Record_Type (Def_Id) then | |
9267 | if Ekind (Def_Id) = E_Record_Type then | |
e80d72ea | 9268 | Expand_Freeze_Record_Type (N); |
df3e68b1 HK |
9269 | elsif Is_Class_Wide_Type (Def_Id) then |
9270 | Expand_Freeze_Class_Wide_Type (N); | |
70482933 RK |
9271 | end if; |
9272 | ||
9273 | -- Freeze processing for array types | |
9274 | ||
9275 | elsif Is_Array_Type (Def_Id) then | |
e80d72ea | 9276 | Expand_Freeze_Array_Type (N); |
70482933 RK |
9277 | |
9278 | -- Freeze processing for access types | |
9279 | ||
9280 | -- For pool-specific access types, find out the pool object used for | |
9281 | -- this type, needs actual expansion of it in some cases. Here are the | |
9282 | -- different cases : | |
9283 | ||
9284 | -- 1. Rep Clause "for Def_Id'Storage_Size use 0;" | |
9285 | -- ---> don't use any storage pool | |
9286 | ||
9287 | -- 2. Rep Clause : for Def_Id'Storage_Size use Expr. | |
9288 | -- Expand: | |
9289 | -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment); | |
9290 | ||
9291 | -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" | |
9292 | -- ---> Storage Pool is the specified one | |
9293 | ||
9294 | -- See GNAT Pool packages in the Run-Time for more details | |
9295 | ||
4a08c95c | 9296 | elsif Ekind (Def_Id) in E_Access_Type | E_General_Access_Type then |
70482933 | 9297 | declare |
3ddfabe3 AC |
9298 | Loc : constant Source_Ptr := Sloc (N); |
9299 | Desig_Type : constant Entity_Id := Designated_Type (Def_Id); | |
70482933 RK |
9300 | |
9301 | Freeze_Action_Typ : Entity_Id; | |
3ddfabe3 | 9302 | Pool_Object : Entity_Id; |
70482933 RK |
9303 | |
9304 | begin | |
70482933 RK |
9305 | -- Case 1 |
9306 | ||
9307 | -- Rep Clause "for Def_Id'Storage_Size use 0;" | |
9308 | -- ---> don't use any storage pool | |
9309 | ||
f2cbd970 | 9310 | if No_Pool_Assigned (Def_Id) then |
70482933 RK |
9311 | null; |
9312 | ||
9313 | -- Case 2 | |
9314 | ||
9315 | -- Rep Clause : for Def_Id'Storage_Size use Expr. | |
9316 | -- ---> Expand: | |
9317 | -- Def_Id__Pool : Stack_Bounded_Pool | |
9318 | -- (Expr, DT'Size, DT'Alignment); | |
9319 | ||
9320 | elsif Has_Storage_Size_Clause (Def_Id) then | |
9321 | declare | |
70482933 | 9322 | DT_Align : Node_Id; |
3ddfabe3 | 9323 | DT_Size : Node_Id; |
70482933 RK |
9324 | |
9325 | begin | |
a9d8907c JM |
9326 | -- For unconstrained composite types we give a size of zero |
9327 | -- so that the pool knows that it needs a special algorithm | |
9328 | -- for variable size object allocation. | |
70482933 RK |
9329 | |
9330 | if Is_Composite_Type (Desig_Type) | |
9331 | and then not Is_Constrained (Desig_Type) | |
9332 | then | |
24d4b3d5 AC |
9333 | DT_Size := Make_Integer_Literal (Loc, 0); |
9334 | DT_Align := Make_Integer_Literal (Loc, Maximum_Alignment); | |
70482933 RK |
9335 | |
9336 | else | |
9337 | DT_Size := | |
9338 | Make_Attribute_Reference (Loc, | |
24d4b3d5 | 9339 | Prefix => New_Occurrence_Of (Desig_Type, Loc), |
70482933 RK |
9340 | Attribute_Name => Name_Max_Size_In_Storage_Elements); |
9341 | ||
9342 | DT_Align := | |
9343 | Make_Attribute_Reference (Loc, | |
24d4b3d5 | 9344 | Prefix => New_Occurrence_Of (Desig_Type, Loc), |
70482933 RK |
9345 | Attribute_Name => Name_Alignment); |
9346 | end if; | |
9347 | ||
9348 | Pool_Object := | |
9349 | Make_Defining_Identifier (Loc, | |
9350 | Chars => New_External_Name (Chars (Def_Id), 'P')); | |
9351 | ||
a9d8907c | 9352 | -- We put the code associated with the pools in the entity |
47cc8d6b | 9353 | -- that has the later freeze node, usually the access type |
a9d8907c JM |
9354 | -- but it can also be the designated_type; because the pool |
9355 | -- code requires both those types to be frozen | |
70482933 RK |
9356 | |
9357 | if Is_Frozen (Desig_Type) | |
a05e99a2 | 9358 | and then (No (Freeze_Node (Desig_Type)) |
70482933 RK |
9359 | or else Analyzed (Freeze_Node (Desig_Type))) |
9360 | then | |
9361 | Freeze_Action_Typ := Def_Id; | |
9362 | ||
9363 | -- A Taft amendment type cannot get the freeze actions | |
9364 | -- since the full view is not there. | |
9365 | ||
9366 | elsif Is_Incomplete_Or_Private_Type (Desig_Type) | |
9367 | and then No (Full_View (Desig_Type)) | |
9368 | then | |
9369 | Freeze_Action_Typ := Def_Id; | |
9370 | ||
9371 | else | |
9372 | Freeze_Action_Typ := Desig_Type; | |
9373 | end if; | |
9374 | ||
9375 | Append_Freeze_Action (Freeze_Action_Typ, | |
9376 | Make_Object_Declaration (Loc, | |
9377 | Defining_Identifier => Pool_Object, | |
24d4b3d5 | 9378 | Object_Definition => |
70482933 RK |
9379 | Make_Subtype_Indication (Loc, |
9380 | Subtype_Mark => | |
e4494292 | 9381 | New_Occurrence_Of |
70482933 RK |
9382 | (RTE (RE_Stack_Bounded_Pool), Loc), |
9383 | ||
24d4b3d5 | 9384 | Constraint => |
70482933 RK |
9385 | Make_Index_Or_Discriminant_Constraint (Loc, |
9386 | Constraints => New_List ( | |
9387 | ||
24d4b3d5 | 9388 | -- First discriminant is the Pool Size |
70482933 | 9389 | |
e4494292 | 9390 | New_Occurrence_Of ( |
70482933 RK |
9391 | Storage_Size_Variable (Def_Id), Loc), |
9392 | ||
24d4b3d5 | 9393 | -- Second discriminant is the element size |
70482933 RK |
9394 | |
9395 | DT_Size, | |
9396 | ||
24d4b3d5 | 9397 | -- Third discriminant is the alignment |
70482933 RK |
9398 | |
9399 | DT_Align))))); | |
70482933 RK |
9400 | end; |
9401 | ||
9402 | Set_Associated_Storage_Pool (Def_Id, Pool_Object); | |
9403 | ||
9404 | -- Case 3 | |
9405 | ||
9406 | -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" | |
9407 | -- ---> Storage Pool is the specified one | |
9408 | ||
dfbcb149 HK |
9409 | -- When compiling in Ada 2012 mode, ensure that the accessibility |
9410 | -- level of the subpool access type is not deeper than that of the | |
8d80ff64 | 9411 | -- pool_with_subpools. |
70482933 | 9412 | |
dfbcb149 HK |
9413 | elsif Ada_Version >= Ada_2012 |
9414 | and then Present (Associated_Storage_Pool (Def_Id)) | |
d0f6dd47 | 9415 | and then RTU_Loaded (System_Storage_Pools_Subpools) |
dfbcb149 HK |
9416 | then |
9417 | declare | |
9418 | Loc : constant Source_Ptr := Sloc (Def_Id); | |
9419 | Pool : constant Entity_Id := | |
9420 | Associated_Storage_Pool (Def_Id); | |
70482933 | 9421 | |
dfbcb149 HK |
9422 | begin |
9423 | -- It is known that the accessibility level of the access | |
9424 | -- type is deeper than that of the pool. | |
9425 | ||
d7e20130 | 9426 | if Type_Access_Level (Def_Id) |
66e97274 | 9427 | > Static_Accessibility_Level (Pool, Object_Decl_Level) |
d0f6dd47 | 9428 | and then Is_Class_Wide_Type (Etype (Pool)) |
dfbcb149 HK |
9429 | and then not Accessibility_Checks_Suppressed (Def_Id) |
9430 | and then not Accessibility_Checks_Suppressed (Pool) | |
9431 | then | |
d0f6dd47 AC |
9432 | -- When the pool is of a class-wide type, it may or may |
9433 | -- not support subpools depending on the path of | |
9434 | -- derivation. Generate: | |
226a7fa4 | 9435 | |
dfbcb149 HK |
9436 | -- if Def_Id in RSPWS'Class then |
9437 | -- raise Program_Error; | |
9438 | -- end if; | |
9439 | ||
d0f6dd47 AC |
9440 | Append_Freeze_Action (Def_Id, |
9441 | Make_If_Statement (Loc, | |
9442 | Condition => | |
9443 | Make_In (Loc, | |
9444 | Left_Opnd => New_Occurrence_Of (Pool, Loc), | |
9445 | Right_Opnd => | |
9446 | New_Occurrence_Of | |
9447 | (Class_Wide_Type | |
9448 | (RTE | |
9449 | (RE_Root_Storage_Pool_With_Subpools)), | |
9450 | Loc)), | |
9451 | Then_Statements => New_List ( | |
9452 | Make_Raise_Program_Error (Loc, | |
9453 | Reason => PE_Accessibility_Check_Failed)))); | |
dfbcb149 HK |
9454 | end if; |
9455 | end; | |
70482933 RK |
9456 | end if; |
9457 | ||
a9d8907c | 9458 | -- For access-to-controlled types (including class-wide types and |
996c8821 | 9459 | -- Taft-amendment types, which potentially have controlled |
a9d8907c | 9460 | -- components), expand the list controller object that will store |
996c8821 | 9461 | -- the dynamically allocated objects. Don't do this transformation |
4c5e9870 SB |
9462 | -- for expander-generated access types, except do it for types |
9463 | -- that are the full view of types derived from other private | |
9464 | -- types and for access types used to implement indirect temps. | |
996c8821 RD |
9465 | -- Also suppress the list controller in the case of a designated |
9466 | -- type with convention Java, since this is used when binding to | |
9467 | -- Java API specs, where there's no equivalent of a finalization | |
9468 | -- list and we don't want to pull in the finalization support if | |
9469 | -- not needed. | |
70482933 RK |
9470 | |
9471 | if not Comes_From_Source (Def_Id) | |
ca5af305 | 9472 | and then not Has_Private_Declaration (Def_Id) |
4c5e9870 SB |
9473 | and then not Old_Attr_Util.Indirect_Temps |
9474 | .Is_Access_Type_For_Indirect_Temp (Def_Id) | |
70482933 RK |
9475 | then |
9476 | null; | |
9477 | ||
ca5af305 AC |
9478 | -- An exception is made for types defined in the run-time because |
9479 | -- Ada.Tags.Tag itself is such a type and cannot afford this | |
9480 | -- unnecessary overhead that would generates a loop in the | |
9481 | -- expansion scheme. Another exception is if Restrictions | |
9482 | -- (No_Finalization) is active, since then we know nothing is | |
9483 | -- controlled. | |
fbf5a39b | 9484 | |
ca5af305 AC |
9485 | elsif Restriction_Active (No_Finalization) |
9486 | or else In_Runtime (Def_Id) | |
9487 | then | |
9488 | null; | |
70482933 | 9489 | |
760804f3 AC |
9490 | -- Create a finalization master for an access-to-controlled type |
9491 | -- or an access-to-incomplete type. It is assumed that the full | |
9492 | -- view will be controlled. | |
70482933 | 9493 | |
ca5af305 | 9494 | elsif Needs_Finalization (Desig_Type) |
760804f3 | 9495 | or else (Is_Incomplete_Type (Desig_Type) |
46413d9e | 9496 | and then No (Full_View (Desig_Type))) |
70482933 | 9497 | then |
d3f70b35 | 9498 | Build_Finalization_Master (Def_Id); |
760804f3 AC |
9499 | |
9500 | -- Create a finalization master when the designated type contains | |
9501 | -- a private component. It is assumed that the full view will be | |
9502 | -- controlled. | |
9503 | ||
9504 | elsif Has_Private_Component (Desig_Type) then | |
9505 | Build_Finalization_Master | |
9506 | (Typ => Def_Id, | |
9507 | For_Private => True, | |
9508 | Context_Scope => Scope (Def_Id), | |
9509 | Insertion_Node => Declaration_Node (Desig_Type)); | |
70482933 RK |
9510 | end if; |
9511 | end; | |
9512 | ||
9513 | -- Freeze processing for enumeration types | |
9514 | ||
9515 | elsif Ekind (Def_Id) = E_Enumeration_Type then | |
9516 | ||
9517 | -- We only have something to do if we have a non-standard | |
9518 | -- representation (i.e. at least one literal whose pos value | |
9519 | -- is not the same as its representation) | |
9520 | ||
9521 | if Has_Non_Standard_Rep (Def_Id) then | |
e80d72ea | 9522 | Expand_Freeze_Enumeration_Type (N); |
70482933 RK |
9523 | end if; |
9524 | ||
fbf5a39b | 9525 | -- Private types that are completed by a derivation from a private |
70482933 RK |
9526 | -- type have an internally generated full view, that needs to be |
9527 | -- frozen. This must be done explicitly because the two views share | |
9528 | -- the freeze node, and the underlying full view is not visible when | |
9529 | -- the freeze node is analyzed. | |
9530 | ||
9531 | elsif Is_Private_Type (Def_Id) | |
9532 | and then Is_Derived_Type (Def_Id) | |
9533 | and then Present (Full_View (Def_Id)) | |
9534 | and then Is_Itype (Full_View (Def_Id)) | |
9535 | and then Has_Private_Declaration (Full_View (Def_Id)) | |
9536 | and then Freeze_Node (Full_View (Def_Id)) = N | |
9537 | then | |
9538 | Set_Entity (N, Full_View (Def_Id)); | |
a9d8907c | 9539 | Result := Freeze_Type (N); |
70482933 RK |
9540 | Set_Entity (N, Def_Id); |
9541 | ||
a9d8907c JM |
9542 | -- All other types require no expander action. There are such cases |
9543 | -- (e.g. task types and protected types). In such cases, the freeze | |
9544 | -- nodes are there for use by Gigi. | |
70482933 RK |
9545 | |
9546 | end if; | |
07fc65c4 | 9547 | |
760804f3 AC |
9548 | -- Complete the initialization of all pending access types' finalization |
9549 | -- masters now that the designated type has been is frozen and primitive | |
9550 | -- Finalize_Address generated. | |
9551 | ||
9552 | Process_Pending_Access_Types (Def_Id); | |
07fc65c4 | 9553 | Freeze_Stream_Operations (N, Def_Id); |
8636f52f | 9554 | |
3ddfabe3 AC |
9555 | -- Generate the [spec and] body of the invariant procedure tasked with |
9556 | -- the runtime verification of all invariants that pertain to the type. | |
9557 | -- This includes invariants on the partial and full view, inherited | |
9558 | -- class-wide invariants from parent types or interfaces, and invariants | |
ae035e34 | 9559 | -- on array elements or record components. But skip internal types. |
3ddfabe3 | 9560 | |
ae035e34 EB |
9561 | if Is_Itype (Def_Id) then |
9562 | null; | |
9563 | ||
9564 | elsif Is_Interface (Def_Id) then | |
b554177a AC |
9565 | |
9566 | -- Interfaces are treated as the partial view of a private type in | |
9567 | -- order to achieve uniformity with the general case. As a result, an | |
9568 | -- interface receives only a "partial" invariant procedure which is | |
9569 | -- never called. | |
9570 | ||
9571 | if Has_Own_Invariants (Def_Id) then | |
9572 | Build_Invariant_Procedure_Body | |
9573 | (Typ => Def_Id, | |
9574 | Partial_Invariant => Is_Interface (Def_Id)); | |
9575 | end if; | |
9576 | ||
9577 | -- Non-interface types | |
9578 | ||
d6fd1f07 AC |
9579 | -- Do not generate invariant procedure within other assertion |
9580 | -- subprograms, which may involve local declarations of local | |
3e720c96 | 9581 | -- subtypes to which these checks do not apply. |
d6fd1f07 | 9582 | |
f7937111 GD |
9583 | else |
9584 | if Has_Invariants (Def_Id) then | |
9585 | if not Predicate_Check_In_Scope (Def_Id) | |
9586 | or else (Ekind (Current_Scope) = E_Function | |
9587 | and then Is_Predicate_Function (Current_Scope)) | |
9588 | then | |
9589 | null; | |
9590 | else | |
9591 | Build_Invariant_Procedure_Body (Def_Id); | |
9592 | end if; | |
9593 | end if; | |
9594 | ||
9595 | -- Generate the [spec and] body of the procedure tasked with the | |
9596 | -- run-time verification of pragma Default_Initial_Condition's | |
9597 | -- expression. | |
9598 | ||
9599 | if Has_DIC (Def_Id) then | |
9600 | Build_DIC_Procedure_Body (Def_Id); | |
d6fd1f07 | 9601 | end if; |
3ddfabe3 AC |
9602 | end if; |
9603 | ||
9057bd6a | 9604 | Restore_Ghost_Region (Saved_GM, Saved_IGR); |
b2c1aa8f | 9605 | |
a9d8907c | 9606 | return Result; |
fbf5a39b AC |
9607 | |
9608 | exception | |
9609 | when RE_Not_Available => | |
9057bd6a | 9610 | Restore_Ghost_Region (Saved_GM, Saved_IGR); |
b2c1aa8f | 9611 | |
a9d8907c | 9612 | return False; |
70482933 RK |
9613 | end Freeze_Type; |
9614 | ||
9615 | ------------------------- | |
9616 | -- Get_Simple_Init_Val -- | |
9617 | ------------------------- | |
9618 | ||
9619 | function Get_Simple_Init_Val | |
3b26fe82 | 9620 | (Typ : Entity_Id; |
f2cbd970 | 9621 | N : Node_Id; |
82c80734 | 9622 | Size : Uint := No_Uint) return Node_Id |
70482933 | 9623 | is |
f2cbd970 JM |
9624 | IV_Attribute : constant Boolean := |
9625 | Nkind (N) = N_Attribute_Reference | |
9626 | and then Attribute_Name (N) = Name_Invalid_Value; | |
9627 | ||
3b26fe82 HK |
9628 | Loc : constant Source_Ptr := Sloc (N); |
9629 | ||
9630 | procedure Extract_Subtype_Bounds | |
9631 | (Lo_Bound : out Uint; | |
9632 | Hi_Bound : out Uint); | |
9633 | -- Inspect subtype Typ as well its ancestor subtypes and derived types | |
9634 | -- to determine the best known information about the bounds of the type. | |
9635 | -- The output parameters are set as follows: | |
9636 | -- | |
9637 | -- * Lo_Bound - Set to No_Unit when there is no information available, | |
9638 | -- or to the known low bound. | |
9639 | -- | |
9640 | -- * Hi_Bound - Set to No_Unit when there is no information available, | |
9641 | -- or to the known high bound. | |
9642 | ||
529749b9 HK |
9643 | function Simple_Init_Array_Type return Node_Id; |
9644 | -- Build an expression to initialize array type Typ | |
9645 | ||
3b26fe82 HK |
9646 | function Simple_Init_Defaulted_Type return Node_Id; |
9647 | -- Build an expression to initialize type Typ which is subject to | |
9648 | -- aspect Default_Value. | |
82c80734 | 9649 | |
3b26fe82 HK |
9650 | function Simple_Init_Initialize_Scalars_Type |
9651 | (Size_To_Use : Uint) return Node_Id; | |
9652 | -- Build an expression to initialize scalar type Typ which is subject to | |
9653 | -- pragma Initialize_Scalars. Size_To_Use is the size of the object. | |
82c80734 | 9654 | |
3b26fe82 HK |
9655 | function Simple_Init_Normalize_Scalars_Type |
9656 | (Size_To_Use : Uint) return Node_Id; | |
9657 | -- Build an expression to initialize scalar type Typ which is subject to | |
9658 | -- pragma Normalize_Scalars. Size_To_Use is the size of the object. | |
82c80734 | 9659 | |
3b26fe82 HK |
9660 | function Simple_Init_Private_Type return Node_Id; |
9661 | -- Build an expression to initialize private type Typ | |
9662 | ||
9663 | function Simple_Init_Scalar_Type return Node_Id; | |
9664 | -- Build an expression to initialize scalar type Typ | |
9665 | ||
3b26fe82 HK |
9666 | ---------------------------- |
9667 | -- Extract_Subtype_Bounds -- | |
9668 | ---------------------------- | |
9669 | ||
9670 | procedure Extract_Subtype_Bounds | |
9671 | (Lo_Bound : out Uint; | |
9672 | Hi_Bound : out Uint) | |
9673 | is | |
9674 | ST1 : Entity_Id; | |
9675 | ST2 : Entity_Id; | |
9676 | Lo : Node_Id; | |
9677 | Hi : Node_Id; | |
9678 | Lo_Val : Uint; | |
9679 | Hi_Val : Uint; | |
82c80734 RD |
9680 | |
9681 | begin | |
9682 | Lo_Bound := No_Uint; | |
9683 | Hi_Bound := No_Uint; | |
9684 | ||
9685 | -- Loop to climb ancestor subtypes and derived types | |
9686 | ||
3b26fe82 | 9687 | ST1 := Typ; |
82c80734 RD |
9688 | loop |
9689 | if not Is_Discrete_Type (ST1) then | |
9690 | return; | |
9691 | end if; | |
9692 | ||
9693 | Lo := Type_Low_Bound (ST1); | |
9694 | Hi := Type_High_Bound (ST1); | |
9695 | ||
9696 | if Compile_Time_Known_Value (Lo) then | |
3b26fe82 | 9697 | Lo_Val := Expr_Value (Lo); |
82c80734 | 9698 | |
2175b50b | 9699 | if No (Lo_Bound) or else Lo_Bound < Lo_Val then |
3b26fe82 | 9700 | Lo_Bound := Lo_Val; |
82c80734 RD |
9701 | end if; |
9702 | end if; | |
9703 | ||
9704 | if Compile_Time_Known_Value (Hi) then | |
3b26fe82 | 9705 | Hi_Val := Expr_Value (Hi); |
82c80734 | 9706 | |
2175b50b | 9707 | if No (Hi_Bound) or else Hi_Bound > Hi_Val then |
3b26fe82 | 9708 | Hi_Bound := Hi_Val; |
82c80734 RD |
9709 | end if; |
9710 | end if; | |
9711 | ||
9712 | ST2 := Ancestor_Subtype (ST1); | |
9713 | ||
9714 | if No (ST2) then | |
9715 | ST2 := Etype (ST1); | |
9716 | end if; | |
9717 | ||
9718 | exit when ST1 = ST2; | |
9719 | ST1 := ST2; | |
9720 | end loop; | |
3b26fe82 | 9721 | end Extract_Subtype_Bounds; |
82c80734 | 9722 | |
529749b9 HK |
9723 | ---------------------------- |
9724 | -- Simple_Init_Array_Type -- | |
9725 | ---------------------------- | |
9726 | ||
9727 | function Simple_Init_Array_Type return Node_Id is | |
9728 | Comp_Typ : constant Entity_Id := Component_Type (Typ); | |
9729 | ||
9730 | function Simple_Init_Dimension (Index : Node_Id) return Node_Id; | |
9731 | -- Initialize a single array dimension with index constraint Index | |
9732 | ||
9733 | -------------------- | |
9734 | -- Simple_Init_Dimension -- | |
9735 | -------------------- | |
9736 | ||
9737 | function Simple_Init_Dimension (Index : Node_Id) return Node_Id is | |
9738 | begin | |
9739 | -- Process the current dimension | |
9740 | ||
9741 | if Present (Index) then | |
9742 | ||
9743 | -- Build a suitable "others" aggregate for the next dimension, | |
9744 | -- or initialize the component itself. Generate: | |
9745 | -- | |
9746 | -- (others => ...) | |
9747 | ||
9748 | return | |
9749 | Make_Aggregate (Loc, | |
9750 | Component_Associations => New_List ( | |
9751 | Make_Component_Association (Loc, | |
9752 | Choices => New_List (Make_Others_Choice (Loc)), | |
9753 | Expression => | |
9754 | Simple_Init_Dimension (Next_Index (Index))))); | |
9755 | ||
9756 | -- Otherwise all dimensions have been processed. Initialize the | |
9757 | -- component itself. | |
9758 | ||
9759 | else | |
9760 | return | |
9761 | Get_Simple_Init_Val | |
9762 | (Typ => Comp_Typ, | |
9763 | N => N, | |
9764 | Size => Esize (Comp_Typ)); | |
9765 | end if; | |
9766 | end Simple_Init_Dimension; | |
9767 | ||
9768 | -- Start of processing for Simple_Init_Array_Type | |
9769 | ||
9770 | begin | |
9771 | return Simple_Init_Dimension (First_Index (Typ)); | |
9772 | end Simple_Init_Array_Type; | |
9773 | ||
3b26fe82 HK |
9774 | -------------------------------- |
9775 | -- Simple_Init_Defaulted_Type -- | |
9776 | -------------------------------- | |
82c80734 | 9777 | |
3b26fe82 | 9778 | function Simple_Init_Defaulted_Type return Node_Id is |
cbd743fe | 9779 | Subtyp : Entity_Id := First_Subtype (Typ); |
07fc65c4 | 9780 | |
3b26fe82 | 9781 | begin |
3b26fe82 HK |
9782 | -- When the first subtype is private, retrieve the expression of the |
9783 | -- Default_Value from the underlying type. | |
07fc65c4 | 9784 | |
3b26fe82 | 9785 | if Is_Private_Type (Subtyp) then |
cbd743fe | 9786 | Subtyp := Full_View (Subtyp); |
07fc65c4 | 9787 | end if; |
cbd743fe BD |
9788 | |
9789 | -- Use the Sloc of the context node when constructing the initial | |
9790 | -- value because the expression of Default_Value may come from a | |
9791 | -- different unit. Updating the Sloc will result in accurate error | |
9792 | -- diagnostics. | |
9793 | ||
9794 | return | |
9795 | OK_Convert_To | |
9796 | (Typ => Typ, | |
9797 | Expr => | |
9798 | New_Copy_Tree | |
9799 | (Source => Default_Aspect_Value (Subtyp), | |
9800 | New_Sloc => Loc)); | |
3b26fe82 | 9801 | end Simple_Init_Defaulted_Type; |
07fc65c4 | 9802 | |
3b26fe82 HK |
9803 | ----------------------------------------- |
9804 | -- Simple_Init_Initialize_Scalars_Type -- | |
9805 | ----------------------------------------- | |
fbf5a39b | 9806 | |
3b26fe82 HK |
9807 | function Simple_Init_Initialize_Scalars_Type |
9808 | (Size_To_Use : Uint) return Node_Id | |
9809 | is | |
9810 | Float_Typ : Entity_Id; | |
9811 | Hi_Bound : Uint; | |
9812 | Lo_Bound : Uint; | |
529749b9 | 9813 | Scal_Typ : Scalar_Id; |
fbf5a39b | 9814 | |
3b26fe82 HK |
9815 | begin |
9816 | Extract_Subtype_Bounds (Lo_Bound, Hi_Bound); | |
fbf5a39b | 9817 | |
529749b9 | 9818 | -- Float types |
07fc65c4 | 9819 | |
3b26fe82 HK |
9820 | if Is_Floating_Point_Type (Typ) then |
9821 | Float_Typ := Root_Type (Typ); | |
a01b9df6 | 9822 | |
3b26fe82 | 9823 | if Float_Typ = Standard_Short_Float then |
529749b9 | 9824 | Scal_Typ := Name_Short_Float; |
3b26fe82 | 9825 | elsif Float_Typ = Standard_Float then |
529749b9 | 9826 | Scal_Typ := Name_Float; |
3b26fe82 | 9827 | elsif Float_Typ = Standard_Long_Float then |
529749b9 | 9828 | Scal_Typ := Name_Long_Float; |
3b26fe82 | 9829 | else pragma Assert (Float_Typ = Standard_Long_Long_Float); |
529749b9 | 9830 | Scal_Typ := Name_Long_Long_Float; |
3b26fe82 | 9831 | end if; |
a01b9df6 | 9832 | |
529749b9 HK |
9833 | -- If zero is invalid, it is a convenient value to use that is for |
9834 | -- sure an appropriate invalid value in all situations. | |
70482933 | 9835 | |
2175b50b | 9836 | elsif Present (Lo_Bound) and then Lo_Bound > Uint_0 then |
529749b9 | 9837 | return Make_Integer_Literal (Loc, 0); |
70482933 | 9838 | |
529749b9 | 9839 | -- Unsigned types |
3b26fe82 HK |
9840 | |
9841 | elsif Is_Unsigned_Type (Typ) then | |
9842 | if Size_To_Use <= 8 then | |
529749b9 | 9843 | Scal_Typ := Name_Unsigned_8; |
3b26fe82 | 9844 | elsif Size_To_Use <= 16 then |
529749b9 | 9845 | Scal_Typ := Name_Unsigned_16; |
3b26fe82 | 9846 | elsif Size_To_Use <= 32 then |
529749b9 | 9847 | Scal_Typ := Name_Unsigned_32; |
a5476382 | 9848 | elsif Size_To_Use <= 64 then |
529749b9 | 9849 | Scal_Typ := Name_Unsigned_64; |
a5476382 EB |
9850 | else |
9851 | Scal_Typ := Name_Unsigned_128; | |
3b26fe82 HK |
9852 | end if; |
9853 | ||
529749b9 | 9854 | -- Signed types |
82c80734 | 9855 | |
82c80734 | 9856 | else |
3b26fe82 | 9857 | if Size_To_Use <= 8 then |
529749b9 | 9858 | Scal_Typ := Name_Signed_8; |
3b26fe82 | 9859 | elsif Size_To_Use <= 16 then |
529749b9 | 9860 | Scal_Typ := Name_Signed_16; |
3b26fe82 | 9861 | elsif Size_To_Use <= 32 then |
529749b9 | 9862 | Scal_Typ := Name_Signed_32; |
a5476382 | 9863 | elsif Size_To_Use <= 64 then |
529749b9 | 9864 | Scal_Typ := Name_Signed_64; |
a5476382 EB |
9865 | else |
9866 | Scal_Typ := Name_Signed_128; | |
3b26fe82 | 9867 | end if; |
82c80734 RD |
9868 | end if; |
9869 | ||
529749b9 HK |
9870 | -- Use the values specified by pragma Initialize_Scalars or the ones |
9871 | -- provided by the binder. Higher precedence is given to the pragma. | |
9872 | ||
9873 | return Invalid_Scalar_Value (Loc, Scal_Typ); | |
3b26fe82 | 9874 | end Simple_Init_Initialize_Scalars_Type; |
82c80734 | 9875 | |
3b26fe82 HK |
9876 | ---------------------------------------- |
9877 | -- Simple_Init_Normalize_Scalars_Type -- | |
9878 | ---------------------------------------- | |
82c80734 | 9879 | |
3b26fe82 HK |
9880 | function Simple_Init_Normalize_Scalars_Type |
9881 | (Size_To_Use : Uint) return Node_Id | |
9882 | is | |
9883 | Signed_Size : constant Uint := UI_Min (Uint_63, Size_To_Use - 1); | |
82c80734 | 9884 | |
3b26fe82 HK |
9885 | Expr : Node_Id; |
9886 | Hi_Bound : Uint; | |
9887 | Lo_Bound : Uint; | |
82c80734 | 9888 | |
3b26fe82 HK |
9889 | begin |
9890 | Extract_Subtype_Bounds (Lo_Bound, Hi_Bound); | |
70482933 | 9891 | |
3b26fe82 HK |
9892 | -- If zero is invalid, it is a convenient value to use that is for |
9893 | -- sure an appropriate invalid value in all situations. | |
70482933 | 9894 | |
2175b50b | 9895 | if Present (Lo_Bound) and then Lo_Bound > Uint_0 then |
3b26fe82 | 9896 | Expr := Make_Integer_Literal (Loc, 0); |
82c80734 | 9897 | |
3b26fe82 | 9898 | -- Cases where all one bits is the appropriate invalid value |
82c80734 | 9899 | |
3b26fe82 HK |
9900 | -- For modular types, all 1 bits is either invalid or valid. If it |
9901 | -- is valid, then there is nothing that can be done since there are | |
9902 | -- no invalid values (we ruled out zero already). | |
82c80734 | 9903 | |
3b26fe82 HK |
9904 | -- For signed integer types that have no negative values, either |
9905 | -- there is room for negative values, or there is not. If there | |
9906 | -- is, then all 1-bits may be interpreted as minus one, which is | |
9907 | -- certainly invalid. Alternatively it is treated as the largest | |
9908 | -- positive value, in which case the observation for modular types | |
9909 | -- still applies. | |
82c80734 | 9910 | |
3b26fe82 HK |
9911 | -- For float types, all 1-bits is a NaN (not a number), which is |
9912 | -- certainly an appropriately invalid value. | |
82c80734 | 9913 | |
3b26fe82 HK |
9914 | elsif Is_Enumeration_Type (Typ) |
9915 | or else Is_Floating_Point_Type (Typ) | |
9916 | or else Is_Unsigned_Type (Typ) | |
9917 | then | |
9918 | Expr := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1); | |
70482933 | 9919 | |
a5476382 | 9920 | -- Resolve as Long_Long_Long_Unsigned, because the largest number |
c7c7dd3a | 9921 | -- we can generate is out of range of universal integer. |
82c80734 | 9922 | |
a5476382 | 9923 | Analyze_And_Resolve (Expr, Standard_Long_Long_Long_Unsigned); |
82c80734 | 9924 | |
3b26fe82 HK |
9925 | -- Case of signed types |
9926 | ||
9927 | else | |
9928 | -- Normally we like to use the most negative number. The one | |
9929 | -- exception is when this number is in the known subtype range and | |
9930 | -- the largest positive number is not in the known subtype range. | |
9931 | ||
9932 | -- For this exceptional case, use largest positive value | |
9933 | ||
2175b50b | 9934 | if Present (Lo_Bound) and then Present (Hi_Bound) |
3b26fe82 HK |
9935 | and then Lo_Bound <= (-(2 ** Signed_Size)) |
9936 | and then Hi_Bound < 2 ** Signed_Size | |
9937 | then | |
9938 | Expr := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1); | |
70482933 | 9939 | |
3b26fe82 | 9940 | -- Normal case of largest negative value |
70482933 RK |
9941 | |
9942 | else | |
3b26fe82 HK |
9943 | Expr := Make_Integer_Literal (Loc, -(2 ** Signed_Size)); |
9944 | end if; | |
9945 | end if; | |
82c80734 | 9946 | |
3b26fe82 HK |
9947 | return Expr; |
9948 | end Simple_Init_Normalize_Scalars_Type; | |
82c80734 | 9949 | |
3b26fe82 HK |
9950 | ------------------------------ |
9951 | -- Simple_Init_Private_Type -- | |
9952 | ------------------------------ | |
70482933 | 9953 | |
3b26fe82 HK |
9954 | function Simple_Init_Private_Type return Node_Id is |
9955 | Under_Typ : constant Entity_Id := Underlying_Type (Typ); | |
9956 | Expr : Node_Id; | |
82c80734 | 9957 | |
3b26fe82 HK |
9958 | begin |
9959 | -- The availability of the underlying view must be checked by routine | |
9960 | -- Needs_Simple_Initialization. | |
82c80734 | 9961 | |
3b26fe82 | 9962 | pragma Assert (Present (Under_Typ)); |
70482933 | 9963 | |
3b26fe82 | 9964 | Expr := Get_Simple_Init_Val (Under_Typ, N, Size); |
70482933 | 9965 | |
3b26fe82 HK |
9966 | -- If the initial value is null or an aggregate, qualify it with the |
9967 | -- underlying type in order to provide a proper context. | |
9968 | ||
4a08c95c | 9969 | if Nkind (Expr) in N_Aggregate | N_Null then |
3b26fe82 HK |
9970 | Expr := |
9971 | Make_Qualified_Expression (Loc, | |
9972 | Subtype_Mark => New_Occurrence_Of (Under_Typ, Loc), | |
9973 | Expression => Expr); | |
9974 | end if; | |
70482933 | 9975 | |
3b26fe82 | 9976 | Expr := Unchecked_Convert_To (Typ, Expr); |
82c80734 | 9977 | |
3b26fe82 HK |
9978 | -- Do not truncate the result when scalar types are involved and |
9979 | -- Initialize/Normalize_Scalars is in effect. | |
82c80734 | 9980 | |
3b26fe82 HK |
9981 | if Nkind (Expr) = N_Unchecked_Type_Conversion |
9982 | and then Is_Scalar_Type (Under_Typ) | |
9983 | then | |
9984 | Set_No_Truncation (Expr); | |
9985 | end if; | |
82c80734 | 9986 | |
3b26fe82 HK |
9987 | return Expr; |
9988 | end Simple_Init_Private_Type; | |
70482933 | 9989 | |
3b26fe82 HK |
9990 | ----------------------------- |
9991 | -- Simple_Init_Scalar_Type -- | |
9992 | ----------------------------- | |
82c80734 | 9993 | |
3b26fe82 HK |
9994 | function Simple_Init_Scalar_Type return Node_Id is |
9995 | Expr : Node_Id; | |
9996 | Size_To_Use : Uint; | |
9997 | ||
9998 | begin | |
9999 | pragma Assert (Init_Or_Norm_Scalars or IV_Attribute); | |
70482933 | 10000 | |
3b26fe82 HK |
10001 | -- Determine the size of the object. This is either the size provided |
10002 | -- by the caller, or the Esize of the scalar type. | |
10003 | ||
2175b50b | 10004 | if No (Size) or else Size <= Uint_0 then |
3b26fe82 HK |
10005 | Size_To_Use := UI_Max (Uint_1, Esize (Typ)); |
10006 | else | |
10007 | Size_To_Use := Size; | |
10008 | end if; | |
10009 | ||
c7c7dd3a | 10010 | -- The maximum size to use is System_Max_Integer_Size bits. This |
a5476382 | 10011 | -- will create values of type Long_Long_Long_Unsigned and the range |
c7c7dd3a | 10012 | -- must fit this type. |
3b26fe82 | 10013 | |
2175b50b | 10014 | if Present (Size_To_Use) |
c7c7dd3a EB |
10015 | and then Size_To_Use > System_Max_Integer_Size |
10016 | then | |
10017 | Size_To_Use := UI_From_Int (System_Max_Integer_Size); | |
3b26fe82 HK |
10018 | end if; |
10019 | ||
10020 | if Normalize_Scalars and then not IV_Attribute then | |
10021 | Expr := Simple_Init_Normalize_Scalars_Type (Size_To_Use); | |
10022 | else | |
10023 | Expr := Simple_Init_Initialize_Scalars_Type (Size_To_Use); | |
70482933 RK |
10024 | end if; |
10025 | ||
82c80734 | 10026 | -- The final expression is obtained by doing an unchecked conversion |
69fff50e AC |
10027 | -- of this result to the base type of the required subtype. Use the |
10028 | -- base type to prevent the unchecked conversion from chopping bits, | |
10029 | -- and then we set Kill_Range_Check to preserve the "bad" value. | |
70482933 | 10030 | |
3b26fe82 | 10031 | Expr := Unchecked_Convert_To (Base_Type (Typ), Expr); |
70482933 | 10032 | |
3b26fe82 HK |
10033 | -- Ensure that the expression is not truncated since the "bad" bits |
10034 | -- are desired, and also kill the range checks. | |
fbf5a39b | 10035 | |
3b26fe82 HK |
10036 | if Nkind (Expr) = N_Unchecked_Type_Conversion then |
10037 | Set_Kill_Range_Check (Expr); | |
10038 | Set_No_Truncation (Expr); | |
70482933 RK |
10039 | end if; |
10040 | ||
3b26fe82 HK |
10041 | return Expr; |
10042 | end Simple_Init_Scalar_Type; | |
70482933 | 10043 | |
3b26fe82 HK |
10044 | -- Start of processing for Get_Simple_Init_Val |
10045 | ||
10046 | begin | |
10047 | if Is_Private_Type (Typ) then | |
10048 | return Simple_Init_Private_Type; | |
10049 | ||
10050 | elsif Is_Scalar_Type (Typ) then | |
10051 | if Has_Default_Aspect (Typ) then | |
10052 | return Simple_Init_Defaulted_Type; | |
10053 | else | |
10054 | return Simple_Init_Scalar_Type; | |
10055 | end if; | |
10056 | ||
529749b9 | 10057 | -- Array type with Initialize or Normalize_Scalars |
3b26fe82 | 10058 | |
529749b9 | 10059 | elsif Is_Array_Type (Typ) then |
3b26fe82 | 10060 | pragma Assert (Init_Or_Norm_Scalars); |
529749b9 | 10061 | return Simple_Init_Array_Type; |
70482933 RK |
10062 | |
10063 | -- Access type is initialized to null | |
10064 | ||
3b26fe82 | 10065 | elsif Is_Access_Type (Typ) then |
df170605 | 10066 | return Make_Null (Loc); |
70482933 | 10067 | |
df170605 AC |
10068 | -- No other possibilities should arise, since we should only be calling |
10069 | -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True, | |
10070 | -- indicating one of the above cases held. | |
70482933 RK |
10071 | |
10072 | else | |
07fc65c4 | 10073 | raise Program_Error; |
70482933 | 10074 | end if; |
fbf5a39b AC |
10075 | |
10076 | exception | |
10077 | when RE_Not_Available => | |
10078 | return Empty; | |
70482933 RK |
10079 | end Get_Simple_Init_Val; |
10080 | ||
10081 | ------------------------------ | |
10082 | -- Has_New_Non_Standard_Rep -- | |
10083 | ------------------------------ | |
10084 | ||
10085 | function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is | |
10086 | begin | |
10087 | if not Is_Derived_Type (T) then | |
10088 | return Has_Non_Standard_Rep (T) | |
10089 | or else Has_Non_Standard_Rep (Root_Type (T)); | |
10090 | ||
10091 | -- If Has_Non_Standard_Rep is not set on the derived type, the | |
10092 | -- representation is fully inherited. | |
10093 | ||
10094 | elsif not Has_Non_Standard_Rep (T) then | |
10095 | return False; | |
10096 | ||
10097 | else | |
10098 | return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T)); | |
10099 | ||
ee4eee0a AC |
10100 | -- May need a more precise check here: the First_Rep_Item may be a |
10101 | -- stream attribute, which does not affect the representation of the | |
10102 | -- type ??? | |
10103 | ||
70482933 RK |
10104 | end if; |
10105 | end Has_New_Non_Standard_Rep; | |
10106 | ||
0d66b596 AC |
10107 | ---------------------- |
10108 | -- Inline_Init_Proc -- | |
10109 | ---------------------- | |
10110 | ||
10111 | function Inline_Init_Proc (Typ : Entity_Id) return Boolean is | |
10112 | begin | |
10113 | -- The initialization proc of protected records is not worth inlining. | |
10114 | -- In addition, when compiled for another unit for inlining purposes, | |
10115 | -- it may make reference to entities that have not been elaborated yet. | |
10116 | -- The initialization proc of records that need finalization contains | |
10117 | -- a nested clean-up procedure that makes it impractical to inline as | |
10118 | -- well, except for simple controlled types themselves. And similar | |
10119 | -- considerations apply to task types. | |
10120 | ||
10121 | if Is_Concurrent_Type (Typ) then | |
10122 | return False; | |
10123 | ||
10124 | elsif Needs_Finalization (Typ) and then not Is_Controlled (Typ) then | |
10125 | return False; | |
10126 | ||
10127 | elsif Has_Task (Typ) then | |
10128 | return False; | |
10129 | ||
10130 | else | |
10131 | return True; | |
10132 | end if; | |
10133 | end Inline_Init_Proc; | |
10134 | ||
70482933 RK |
10135 | ---------------- |
10136 | -- In_Runtime -- | |
10137 | ---------------- | |
10138 | ||
10139 | function In_Runtime (E : Entity_Id) return Boolean is | |
47cc8d6b | 10140 | S1 : Entity_Id; |
70482933 RK |
10141 | |
10142 | begin | |
47cc8d6b | 10143 | S1 := Scope (E); |
70482933 RK |
10144 | while Scope (S1) /= Standard_Standard loop |
10145 | S1 := Scope (S1); | |
10146 | end loop; | |
10147 | ||
c5ecd6b7 | 10148 | return Is_RTU (S1, System) or else Is_RTU (S1, Ada); |
70482933 RK |
10149 | end In_Runtime; |
10150 | ||
b77029ff SB |
10151 | package body Initialization_Control is |
10152 | ||
10153 | ------------------------ | |
10154 | -- Requires_Late_Init -- | |
10155 | ------------------------ | |
10156 | ||
10157 | function Requires_Late_Init | |
10158 | (Decl : Node_Id; | |
10159 | Rec_Type : Entity_Id) return Boolean | |
10160 | is | |
10161 | References_Current_Instance : Boolean := False; | |
10162 | Has_Access_Discriminant : Boolean := False; | |
10163 | Has_Internal_Call : Boolean := False; | |
10164 | ||
10165 | function Find_Access_Discriminant | |
10166 | (N : Node_Id) return Traverse_Result; | |
10167 | -- Look for a name denoting an access discriminant | |
10168 | ||
10169 | function Find_Current_Instance | |
10170 | (N : Node_Id) return Traverse_Result; | |
10171 | -- Look for a reference to the current instance of the type | |
10172 | ||
10173 | function Find_Internal_Call | |
10174 | (N : Node_Id) return Traverse_Result; | |
10175 | -- Look for an internal protected function call | |
10176 | ||
10177 | ------------------------------ | |
10178 | -- Find_Access_Discriminant -- | |
10179 | ------------------------------ | |
10180 | ||
10181 | function Find_Access_Discriminant | |
10182 | (N : Node_Id) return Traverse_Result is | |
10183 | begin | |
10184 | if Is_Entity_Name (N) | |
10185 | and then Denotes_Discriminant (N) | |
10186 | and then Is_Access_Type (Etype (N)) | |
10187 | then | |
10188 | Has_Access_Discriminant := True; | |
10189 | return Abandon; | |
10190 | else | |
10191 | return OK; | |
10192 | end if; | |
10193 | end Find_Access_Discriminant; | |
10194 | ||
10195 | --------------------------- | |
10196 | -- Find_Current_Instance -- | |
10197 | --------------------------- | |
10198 | ||
10199 | function Find_Current_Instance | |
10200 | (N : Node_Id) return Traverse_Result is | |
10201 | begin | |
10202 | if Is_Entity_Name (N) | |
10203 | and then Present (Entity (N)) | |
10204 | and then Is_Current_Instance (N) | |
10205 | then | |
10206 | References_Current_Instance := True; | |
10207 | return Abandon; | |
10208 | else | |
10209 | return OK; | |
10210 | end if; | |
10211 | end Find_Current_Instance; | |
10212 | ||
10213 | ------------------------ | |
10214 | -- Find_Internal_Call -- | |
10215 | ------------------------ | |
10216 | ||
10217 | function Find_Internal_Call (N : Node_Id) return Traverse_Result is | |
10218 | ||
10219 | function Call_Scope (N : Node_Id) return Entity_Id; | |
10220 | -- Return the scope enclosing a given call node N | |
10221 | ||
10222 | ---------------- | |
10223 | -- Call_Scope -- | |
10224 | ---------------- | |
10225 | ||
10226 | function Call_Scope (N : Node_Id) return Entity_Id is | |
10227 | Nam : constant Node_Id := Name (N); | |
10228 | begin | |
10229 | if Nkind (Nam) = N_Selected_Component then | |
10230 | return Scope (Entity (Prefix (Nam))); | |
10231 | else | |
10232 | return Scope (Entity (Nam)); | |
10233 | end if; | |
10234 | end Call_Scope; | |
10235 | ||
10236 | begin | |
10237 | if Nkind (N) = N_Function_Call | |
10238 | and then Call_Scope (N) | |
10239 | = Corresponding_Concurrent_Type (Rec_Type) | |
10240 | then | |
10241 | Has_Internal_Call := True; | |
10242 | return Abandon; | |
10243 | else | |
10244 | return OK; | |
10245 | end if; | |
10246 | end Find_Internal_Call; | |
10247 | ||
10248 | procedure Search_Access_Discriminant is new | |
10249 | Traverse_Proc (Find_Access_Discriminant); | |
10250 | ||
10251 | procedure Search_Current_Instance is new | |
10252 | Traverse_Proc (Find_Current_Instance); | |
10253 | ||
10254 | procedure Search_Internal_Call is new | |
10255 | Traverse_Proc (Find_Internal_Call); | |
10256 | ||
10257 | -- Start of processing for Requires_Late_Init | |
10258 | ||
10259 | begin | |
10260 | -- A component of an object is said to require late initialization | |
10261 | -- if: | |
10262 | ||
10263 | -- it has an access discriminant value constrained by a per-object | |
10264 | -- expression; | |
10265 | ||
10266 | if Has_Access_Constraint (Defining_Identifier (Decl)) | |
10267 | and then No (Expression (Decl)) | |
10268 | then | |
10269 | return True; | |
10270 | ||
10271 | elsif Present (Expression (Decl)) then | |
10272 | ||
10273 | -- it has an initialization expression that includes a name | |
10274 | -- denoting an access discriminant; | |
10275 | ||
10276 | Search_Access_Discriminant (Expression (Decl)); | |
10277 | ||
10278 | if Has_Access_Discriminant then | |
10279 | return True; | |
10280 | end if; | |
10281 | ||
10282 | -- or it has an initialization expression that includes a | |
10283 | -- reference to the current instance of the type either by | |
10284 | -- name... | |
10285 | ||
10286 | Search_Current_Instance (Expression (Decl)); | |
10287 | ||
10288 | if References_Current_Instance then | |
10289 | return True; | |
10290 | end if; | |
10291 | ||
10292 | -- ...or implicitly as the target object of a call. | |
10293 | ||
10294 | if Is_Protected_Record_Type (Rec_Type) then | |
10295 | Search_Internal_Call (Expression (Decl)); | |
10296 | ||
10297 | if Has_Internal_Call then | |
10298 | return True; | |
10299 | end if; | |
10300 | end if; | |
10301 | end if; | |
10302 | ||
10303 | return False; | |
10304 | end Requires_Late_Init; | |
10305 | ||
10306 | ----------------------------- | |
10307 | -- Has_Late_Init_Component -- | |
10308 | ----------------------------- | |
10309 | ||
10310 | function Has_Late_Init_Component | |
10311 | (Tagged_Rec_Type : Entity_Id) return Boolean | |
10312 | is | |
10313 | Comp_Id : Entity_Id := | |
10314 | First_Component (Implementation_Base_Type (Tagged_Rec_Type)); | |
10315 | begin | |
10316 | while Present (Comp_Id) loop | |
10317 | if Requires_Late_Init (Decl => Parent (Comp_Id), | |
10318 | Rec_Type => Tagged_Rec_Type) | |
10319 | then | |
10320 | return True; -- found a component that requires late init | |
10321 | ||
10322 | elsif Chars (Comp_Id) = Name_uParent | |
10323 | and then Has_Late_Init_Component (Etype (Comp_Id)) | |
10324 | then | |
10325 | return True; -- an ancestor type has a late init component | |
10326 | end if; | |
10327 | ||
10328 | Next_Component (Comp_Id); | |
10329 | end loop; | |
10330 | ||
10331 | return False; | |
10332 | end Has_Late_Init_Component; | |
10333 | ||
10334 | ------------------------ | |
10335 | -- Tag_Init_Condition -- | |
10336 | ------------------------ | |
10337 | ||
10338 | function Tag_Init_Condition | |
10339 | (Loc : Source_Ptr; | |
10340 | Init_Control_Formal : Entity_Id) return Node_Id is | |
10341 | begin | |
10342 | return Make_Op_Eq (Loc, | |
10343 | New_Occurrence_Of (Init_Control_Formal, Loc), | |
10344 | Make_Mode_Literal (Loc, Full_Init)); | |
10345 | end Tag_Init_Condition; | |
10346 | ||
10347 | -------------------------- | |
10348 | -- Early_Init_Condition -- | |
10349 | -------------------------- | |
10350 | ||
10351 | function Early_Init_Condition | |
10352 | (Loc : Source_Ptr; | |
10353 | Init_Control_Formal : Entity_Id) return Node_Id is | |
10354 | begin | |
10355 | return Make_Op_Ne (Loc, | |
10356 | New_Occurrence_Of (Init_Control_Formal, Loc), | |
10357 | Make_Mode_Literal (Loc, Late_Init_Only)); | |
10358 | end Early_Init_Condition; | |
10359 | ||
10360 | ------------------------- | |
10361 | -- Late_Init_Condition -- | |
10362 | ------------------------- | |
10363 | ||
10364 | function Late_Init_Condition | |
10365 | (Loc : Source_Ptr; | |
10366 | Init_Control_Formal : Entity_Id) return Node_Id is | |
10367 | begin | |
10368 | return Make_Op_Ne (Loc, | |
10369 | New_Occurrence_Of (Init_Control_Formal, Loc), | |
10370 | Make_Mode_Literal (Loc, Early_Init_Only)); | |
10371 | end Late_Init_Condition; | |
10372 | ||
10373 | end Initialization_Control; | |
10374 | ||
47cc8d6b ES |
10375 | ---------------------------- |
10376 | -- Initialization_Warning -- | |
10377 | ---------------------------- | |
10378 | ||
10379 | procedure Initialization_Warning (E : Entity_Id) is | |
10380 | Warning_Needed : Boolean; | |
10381 | ||
10382 | begin | |
10383 | Warning_Needed := False; | |
10384 | ||
10385 | if Ekind (Current_Scope) = E_Package | |
10386 | and then Static_Elaboration_Desired (Current_Scope) | |
10387 | then | |
10388 | if Is_Type (E) then | |
10389 | if Is_Record_Type (E) then | |
10390 | if Has_Discriminants (E) | |
10391 | or else Is_Limited_Type (E) | |
10392 | or else Has_Non_Standard_Rep (E) | |
10393 | then | |
10394 | Warning_Needed := True; | |
10395 | ||
10396 | else | |
8fc789c8 | 10397 | -- Verify that at least one component has an initialization |
47cc8d6b ES |
10398 | -- expression. No need for a warning on a type if all its |
10399 | -- components have no initialization. | |
10400 | ||
10401 | declare | |
10402 | Comp : Entity_Id; | |
10403 | ||
10404 | begin | |
10405 | Comp := First_Component (E); | |
10406 | while Present (Comp) loop | |
04598eb0 PT |
10407 | pragma Assert |
10408 | (Nkind (Parent (Comp)) = N_Component_Declaration); | |
10409 | ||
10410 | if Present (Expression (Parent (Comp))) then | |
47cc8d6b ES |
10411 | Warning_Needed := True; |
10412 | exit; | |
10413 | end if; | |
10414 | ||
10415 | Next_Component (Comp); | |
10416 | end loop; | |
10417 | end; | |
10418 | end if; | |
10419 | ||
10420 | if Warning_Needed then | |
10421 | Error_Msg_N | |
9ed2b86d | 10422 | ("objects of the type cannot be initialized statically " |
4ac2bbbd | 10423 | & "by default??", Parent (E)); |
47cc8d6b ES |
10424 | end if; |
10425 | end if; | |
10426 | ||
10427 | else | |
9ed2b86d | 10428 | Error_Msg_N ("object cannot be initialized statically??", E); |
47cc8d6b ES |
10429 | end if; |
10430 | end if; | |
10431 | end Initialization_Warning; | |
10432 | ||
70482933 RK |
10433 | ------------------ |
10434 | -- Init_Formals -- | |
10435 | ------------------ | |
10436 | ||
a7837c08 JM |
10437 | function Init_Formals (Typ : Entity_Id; Proc_Id : Entity_Id) return List_Id |
10438 | is | |
c7862167 HK |
10439 | Loc : constant Source_Ptr := Sloc (Typ); |
10440 | Unc_Arr : constant Boolean := | |
10441 | Is_Array_Type (Typ) and then not Is_Constrained (Typ); | |
c743425f | 10442 | With_Prot : constant Boolean := |
c7862167 HK |
10443 | Has_Protected (Typ) |
10444 | or else (Is_Record_Type (Typ) | |
10445 | and then Is_Protected_Record_Type (Typ)); | |
c743425f | 10446 | With_Task : constant Boolean := |
a7837c08 JM |
10447 | not Global_No_Tasking |
10448 | and then | |
10449 | (Has_Task (Typ) | |
10450 | or else (Is_Record_Type (Typ) | |
10451 | and then Is_Task_Record_Type (Typ))); | |
70482933 RK |
10452 | Formals : List_Id; |
10453 | ||
10454 | begin | |
c743425f EB |
10455 | -- The first parameter is always _Init : [in] out Typ. Note that we need |
10456 | -- it to be in/out in the case of an unconstrained array, because of the | |
10457 | -- need to have the bounds, and in the case of protected or task record | |
10458 | -- value, because there are default record fields that may be referenced | |
10459 | -- in the generated initialization routine. | |
70482933 RK |
10460 | |
10461 | Formals := New_List ( | |
10462 | Make_Parameter_Specification (Loc, | |
24d4b3d5 | 10463 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit), |
c743425f | 10464 | In_Present => Unc_Arr or else With_Prot or else With_Task, |
24d4b3d5 AC |
10465 | Out_Present => True, |
10466 | Parameter_Type => New_Occurrence_Of (Typ, Loc))); | |
70482933 RK |
10467 | |
10468 | -- For task record value, or type that contains tasks, add two more | |
10469 | -- formals, _Master : Master_Id and _Chain : in out Activation_Chain | |
10470 | -- We also add these parameters for the task record type case. | |
10471 | ||
c743425f | 10472 | if With_Task then |
70482933 RK |
10473 | Append_To (Formals, |
10474 | Make_Parameter_Specification (Loc, | |
10475 | Defining_Identifier => | |
10476 | Make_Defining_Identifier (Loc, Name_uMaster), | |
c18e9f65 | 10477 | Parameter_Type => |
37cd8d97 | 10478 | New_Occurrence_Of (Standard_Integer, Loc))); |
70482933 | 10479 | |
a7837c08 JM |
10480 | Set_Has_Master_Entity (Proc_Id); |
10481 | ||
6bc057a7 AC |
10482 | -- Add _Chain (not done for sequential elaboration policy, see |
10483 | -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). | |
c18e9f65 | 10484 | |
6bc057a7 | 10485 | if Partition_Elaboration_Policy /= 'S' then |
c18e9f65 TG |
10486 | Append_To (Formals, |
10487 | Make_Parameter_Specification (Loc, | |
10488 | Defining_Identifier => | |
10489 | Make_Defining_Identifier (Loc, Name_uChain), | |
10490 | In_Present => True, | |
10491 | Out_Present => True, | |
10492 | Parameter_Type => | |
e4494292 | 10493 | New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))); |
c18e9f65 | 10494 | end if; |
70482933 RK |
10495 | |
10496 | Append_To (Formals, | |
10497 | Make_Parameter_Specification (Loc, | |
10498 | Defining_Identifier => | |
fbf5a39b | 10499 | Make_Defining_Identifier (Loc, Name_uTask_Name), |
c18e9f65 | 10500 | In_Present => True, |
e4494292 | 10501 | Parameter_Type => New_Occurrence_Of (Standard_String, Loc))); |
70482933 RK |
10502 | end if; |
10503 | ||
6a890c58 | 10504 | -- Due to certain edge cases such as arrays with null-excluding |
341e0bb6 JS |
10505 | -- components being built with the secondary stack it becomes necessary |
10506 | -- to add a formal to the Init_Proc which controls whether we raise | |
6a890c58 | 10507 | -- Constraint_Errors on generated calls for internal object |
341e0bb6 JS |
10508 | -- declarations. |
10509 | ||
10510 | if Needs_Conditional_Null_Excluding_Check (Typ) then | |
10511 | Append_To (Formals, | |
10512 | Make_Parameter_Specification (Loc, | |
10513 | Defining_Identifier => | |
10514 | Make_Defining_Identifier (Loc, | |
10515 | New_External_Name (Chars | |
10516 | (Component_Type (Typ)), "_skip_null_excluding_check")), | |
fa528281 | 10517 | Expression => New_Occurrence_Of (Standard_False, Loc), |
341e0bb6 JS |
10518 | In_Present => True, |
10519 | Parameter_Type => | |
10520 | New_Occurrence_Of (Standard_Boolean, Loc))); | |
10521 | end if; | |
10522 | ||
70482933 | 10523 | return Formals; |
fbf5a39b AC |
10524 | |
10525 | exception | |
10526 | when RE_Not_Available => | |
10527 | return Empty_List; | |
70482933 RK |
10528 | end Init_Formals; |
10529 | ||
3476f949 JM |
10530 | ------------------------- |
10531 | -- Init_Secondary_Tags -- | |
10532 | ------------------------- | |
10533 | ||
10534 | procedure Init_Secondary_Tags | |
04df6250 TQ |
10535 | (Typ : Entity_Id; |
10536 | Target : Node_Id; | |
fe683ef6 | 10537 | Init_Tags_List : List_Id; |
04df6250 TQ |
10538 | Stmts_List : List_Id; |
10539 | Fixed_Comps : Boolean := True; | |
10540 | Variable_Comps : Boolean := True) | |
3476f949 | 10541 | is |
04df6250 | 10542 | Loc : constant Source_Ptr := Sloc (Target); |
ea1941af | 10543 | |
04df6250 TQ |
10544 | -- Inherit the C++ tag of the secondary dispatch table of Typ associated |
10545 | -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. | |
ea1941af ES |
10546 | |
10547 | procedure Initialize_Tag | |
10548 | (Typ : Entity_Id; | |
10549 | Iface : Entity_Id; | |
04df6250 | 10550 | Tag_Comp : Entity_Id; |
ea1941af ES |
10551 | Iface_Tag : Node_Id); |
10552 | -- Initialize the tag of the secondary dispatch table of Typ associated | |
10553 | -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. | |
04df6250 TQ |
10554 | -- Compiling under the CPP full ABI compatibility mode, if the ancestor |
10555 | -- of Typ CPP tagged type we generate code to inherit the contents of | |
10556 | -- the dispatch table directly from the ancestor. | |
3476f949 | 10557 | |
ea1941af ES |
10558 | -------------------- |
10559 | -- Initialize_Tag -- | |
10560 | -------------------- | |
10561 | ||
10562 | procedure Initialize_Tag | |
10563 | (Typ : Entity_Id; | |
10564 | Iface : Entity_Id; | |
04df6250 | 10565 | Tag_Comp : Entity_Id; |
ea1941af ES |
10566 | Iface_Tag : Node_Id) |
10567 | is | |
04df6250 TQ |
10568 | Comp_Typ : Entity_Id; |
10569 | Offset_To_Top_Comp : Entity_Id := Empty; | |
ea1941af ES |
10570 | |
10571 | begin | |
ee4eee0a | 10572 | -- Initialize pointer to secondary DT associated with the interface |
ea1941af | 10573 | |
4ac2477e | 10574 | if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then |
fe683ef6 | 10575 | Append_To (Init_Tags_List, |
04df6250 | 10576 | Make_Assignment_Statement (Loc, |
24d4b3d5 | 10577 | Name => |
ea1941af | 10578 | Make_Selected_Component (Loc, |
24d4b3d5 | 10579 | Prefix => New_Copy_Tree (Target), |
e4494292 | 10580 | Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)), |
04df6250 | 10581 | Expression => |
e4494292 | 10582 | New_Occurrence_Of (Iface_Tag, Loc))); |
ea1941af ES |
10583 | end if; |
10584 | ||
04df6250 | 10585 | Comp_Typ := Scope (Tag_Comp); |
ea1941af | 10586 | |
04df6250 TQ |
10587 | -- Initialize the entries of the table of interfaces. We generate a |
10588 | -- different call when the parent of the type has variable size | |
10589 | -- components. | |
ea1941af | 10590 | |
04df6250 TQ |
10591 | if Comp_Typ /= Etype (Comp_Typ) |
10592 | and then Is_Variable_Size_Record (Etype (Comp_Typ)) | |
10593 | and then Chars (Tag_Comp) /= Name_uTag | |
10594 | then | |
a8f59a33 | 10595 | pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp))); |
ea1941af | 10596 | |
f2cbd970 JM |
10597 | -- Issue error if Set_Dynamic_Offset_To_Top is not available in a |
10598 | -- configurable run-time environment. | |
10599 | ||
10600 | if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then | |
10601 | Error_Msg_CRT | |
10602 | ("variable size record with interface types", Typ); | |
10603 | return; | |
10604 | end if; | |
10605 | ||
04df6250 | 10606 | -- Generate: |
f2cbd970 | 10607 | -- Set_Dynamic_Offset_To_Top |
04df6250 | 10608 | -- (This => Init, |
fe683ef6 | 10609 | -- Prim_T => Typ'Tag, |
04df6250 | 10610 | -- Interface_T => Iface'Tag, |
04df6250 | 10611 | -- Offset_Value => n, |
4c132238 | 10612 | -- Offset_Func => Fn'Unrestricted_Access) |
ea1941af | 10613 | |
04df6250 TQ |
10614 | Append_To (Stmts_List, |
10615 | Make_Procedure_Call_Statement (Loc, | |
24d4b3d5 AC |
10616 | Name => |
10617 | New_Occurrence_Of (RTE (RE_Set_Dynamic_Offset_To_Top), Loc), | |
04df6250 TQ |
10618 | Parameter_Associations => New_List ( |
10619 | Make_Attribute_Reference (Loc, | |
c18e9f65 | 10620 | Prefix => New_Copy_Tree (Target), |
04df6250 | 10621 | Attribute_Name => Name_Address), |
ea1941af | 10622 | |
fe683ef6 AC |
10623 | Unchecked_Convert_To (RTE (RE_Tag), |
10624 | New_Occurrence_Of | |
10625 | (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)), | |
10626 | ||
04df6250 | 10627 | Unchecked_Convert_To (RTE (RE_Tag), |
e4494292 | 10628 | New_Occurrence_Of |
04df6250 TQ |
10629 | (Node (First_Elmt (Access_Disp_Table (Iface))), |
10630 | Loc)), | |
ea1941af | 10631 | |
04df6250 TQ |
10632 | Unchecked_Convert_To |
10633 | (RTE (RE_Storage_Offset), | |
d0567dc0 PMR |
10634 | Make_Op_Minus (Loc, |
10635 | Make_Attribute_Reference (Loc, | |
10636 | Prefix => | |
10637 | Make_Selected_Component (Loc, | |
10638 | Prefix => New_Copy_Tree (Target), | |
10639 | Selector_Name => | |
10640 | New_Occurrence_Of (Tag_Comp, Loc)), | |
10641 | Attribute_Name => Name_Position))), | |
ea1941af | 10642 | |
04df6250 TQ |
10643 | Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr), |
10644 | Make_Attribute_Reference (Loc, | |
e4494292 | 10645 | Prefix => New_Occurrence_Of |
04df6250 | 10646 | (DT_Offset_To_Top_Func (Tag_Comp), Loc), |
4c132238 | 10647 | Attribute_Name => Name_Unrestricted_Access))))); |
3476f949 | 10648 | |
ee4eee0a AC |
10649 | -- In this case the next component stores the value of the offset |
10650 | -- to the top. | |
ea1941af | 10651 | |
04df6250 TQ |
10652 | Offset_To_Top_Comp := Next_Entity (Tag_Comp); |
10653 | pragma Assert (Present (Offset_To_Top_Comp)); | |
ea1941af | 10654 | |
fe683ef6 | 10655 | Append_To (Init_Tags_List, |
04df6250 | 10656 | Make_Assignment_Statement (Loc, |
24d4b3d5 | 10657 | Name => |
04df6250 | 10658 | Make_Selected_Component (Loc, |
24d4b3d5 AC |
10659 | Prefix => New_Copy_Tree (Target), |
10660 | Selector_Name => | |
10661 | New_Occurrence_Of (Offset_To_Top_Comp, Loc)), | |
10662 | ||
04df6250 | 10663 | Expression => |
d0567dc0 PMR |
10664 | Make_Op_Minus (Loc, |
10665 | Make_Attribute_Reference (Loc, | |
10666 | Prefix => | |
10667 | Make_Selected_Component (Loc, | |
10668 | Prefix => New_Copy_Tree (Target), | |
10669 | Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)), | |
10670 | Attribute_Name => Name_Position)))); | |
3476f949 | 10671 | |
04df6250 | 10672 | -- Normal case: No discriminants in the parent type |
3476f949 | 10673 | |
04df6250 | 10674 | else |
15529d0a PMR |
10675 | -- Don't need to set any value if the offset-to-top field is |
10676 | -- statically set or if this interface shares the primary | |
10677 | -- dispatch table. | |
f2cbd970 | 10678 | |
15529d0a PMR |
10679 | if not Building_Static_Secondary_DT (Typ) |
10680 | and then not Is_Ancestor (Iface, Typ, Use_Full_View => True) | |
10681 | then | |
f2cbd970 JM |
10682 | Append_To (Stmts_List, |
10683 | Build_Set_Static_Offset_To_Top (Loc, | |
e4494292 | 10684 | Iface_Tag => New_Occurrence_Of (Iface_Tag, Loc), |
f2cbd970 JM |
10685 | Offset_Value => |
10686 | Unchecked_Convert_To (RTE (RE_Storage_Offset), | |
d0567dc0 PMR |
10687 | Make_Op_Minus (Loc, |
10688 | Make_Attribute_Reference (Loc, | |
10689 | Prefix => | |
10690 | Make_Selected_Component (Loc, | |
10691 | Prefix => New_Copy_Tree (Target), | |
10692 | Selector_Name => | |
10693 | New_Occurrence_Of (Tag_Comp, Loc)), | |
10694 | Attribute_Name => Name_Position))))); | |
f2cbd970 JM |
10695 | end if; |
10696 | ||
3476f949 | 10697 | -- Generate: |
f2cbd970 | 10698 | -- Register_Interface_Offset |
fe683ef6 | 10699 | -- (Prim_T => Typ'Tag, |
3476f949 JM |
10700 | -- Interface_T => Iface'Tag, |
10701 | -- Is_Constant => True, | |
04df6250 TQ |
10702 | -- Offset_Value => n, |
10703 | -- Offset_Func => null); | |
3476f949 | 10704 | |
3ec54569 PMR |
10705 | if not Building_Static_Secondary_DT (Typ) |
10706 | and then RTE_Available (RE_Register_Interface_Offset) | |
10707 | then | |
f2cbd970 JM |
10708 | Append_To (Stmts_List, |
10709 | Make_Procedure_Call_Statement (Loc, | |
24d4b3d5 AC |
10710 | Name => |
10711 | New_Occurrence_Of | |
10712 | (RTE (RE_Register_Interface_Offset), Loc), | |
f2cbd970 | 10713 | Parameter_Associations => New_List ( |
fe683ef6 AC |
10714 | Unchecked_Convert_To (RTE (RE_Tag), |
10715 | New_Occurrence_Of | |
10716 | (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)), | |
04df6250 | 10717 | |
f2cbd970 | 10718 | Unchecked_Convert_To (RTE (RE_Tag), |
e4494292 | 10719 | New_Occurrence_Of |
d70d147e | 10720 | (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)), |
04df6250 | 10721 | |
f2cbd970 | 10722 | New_Occurrence_Of (Standard_True, Loc), |
3476f949 | 10723 | |
24d4b3d5 | 10724 | Unchecked_Convert_To (RTE (RE_Storage_Offset), |
d0567dc0 PMR |
10725 | Make_Op_Minus (Loc, |
10726 | Make_Attribute_Reference (Loc, | |
10727 | Prefix => | |
10728 | Make_Selected_Component (Loc, | |
10729 | Prefix => New_Copy_Tree (Target), | |
10730 | Selector_Name => | |
10731 | New_Occurrence_Of (Tag_Comp, Loc)), | |
10732 | Attribute_Name => Name_Position))), | |
3476f949 | 10733 | |
f2cbd970 JM |
10734 | Make_Null (Loc)))); |
10735 | end if; | |
04df6250 TQ |
10736 | end if; |
10737 | end Initialize_Tag; | |
3476f949 | 10738 | |
04df6250 | 10739 | -- Local variables |
3476f949 | 10740 | |
04df6250 TQ |
10741 | Full_Typ : Entity_Id; |
10742 | Ifaces_List : Elist_Id; | |
10743 | Ifaces_Comp_List : Elist_Id; | |
10744 | Ifaces_Tag_List : Elist_Id; | |
10745 | Iface_Elmt : Elmt_Id; | |
10746 | Iface_Comp_Elmt : Elmt_Id; | |
10747 | Iface_Tag_Elmt : Elmt_Id; | |
10748 | Tag_Comp : Node_Id; | |
10749 | In_Variable_Pos : Boolean; | |
3476f949 JM |
10750 | |
10751 | -- Start of processing for Init_Secondary_Tags | |
10752 | ||
10753 | begin | |
3476f949 JM |
10754 | -- Handle private types |
10755 | ||
10756 | if Present (Full_View (Typ)) then | |
10757 | Full_Typ := Full_View (Typ); | |
10758 | else | |
10759 | Full_Typ := Typ; | |
10760 | end if; | |
10761 | ||
04df6250 TQ |
10762 | Collect_Interfaces_Info |
10763 | (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List); | |
ea1941af | 10764 | |
04df6250 TQ |
10765 | Iface_Elmt := First_Elmt (Ifaces_List); |
10766 | Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); | |
10767 | Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List); | |
10768 | while Present (Iface_Elmt) loop | |
10769 | Tag_Comp := Node (Iface_Comp_Elmt); | |
10770 | ||
cefce34c JM |
10771 | -- Check if parent of record type has variable size components |
10772 | ||
10773 | In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp)) | |
10774 | and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp))); | |
10775 | ||
04df6250 TQ |
10776 | -- If we are compiling under the CPP full ABI compatibility mode and |
10777 | -- the ancestor is a CPP_Pragma tagged type then we generate code to | |
cefce34c JM |
10778 | -- initialize the secondary tag components from tags that reference |
10779 | -- secondary tables filled with copy of parent slots. | |
04df6250 | 10780 | |
cefce34c | 10781 | if Is_CPP_Class (Root_Type (Full_Typ)) then |
04df6250 | 10782 | |
cefce34c JM |
10783 | -- Reject interface components located at variable offset in |
10784 | -- C++ derivations. This is currently unsupported. | |
04df6250 | 10785 | |
cefce34c JM |
10786 | if not Fixed_Comps and then In_Variable_Pos then |
10787 | ||
10788 | -- Locate the first dynamic component of the record. Done to | |
10789 | -- improve the text of the warning. | |
10790 | ||
10791 | declare | |
10792 | Comp : Entity_Id; | |
10793 | Comp_Typ : Entity_Id; | |
10794 | ||
10795 | begin | |
10796 | Comp := First_Entity (Typ); | |
10797 | while Present (Comp) loop | |
10798 | Comp_Typ := Etype (Comp); | |
10799 | ||
10800 | if Ekind (Comp) /= E_Discriminant | |
10801 | and then not Is_Tag (Comp) | |
10802 | then | |
10803 | exit when | |
10804 | (Is_Record_Type (Comp_Typ) | |
24d4b3d5 AC |
10805 | and then |
10806 | Is_Variable_Size_Record (Base_Type (Comp_Typ))) | |
cefce34c JM |
10807 | or else |
10808 | (Is_Array_Type (Comp_Typ) | |
ee4eee0a | 10809 | and then Is_Variable_Size_Array (Comp_Typ)); |
cefce34c JM |
10810 | end if; |
10811 | ||
10812 | Next_Entity (Comp); | |
10813 | end loop; | |
04df6250 | 10814 | |
cefce34c | 10815 | pragma Assert (Present (Comp)); |
2d6f6e08 AC |
10816 | |
10817 | -- Move this check to sem??? | |
cefce34c JM |
10818 | Error_Msg_Node_2 := Comp; |
10819 | Error_Msg_NE | |
10820 | ("parent type & with dynamic component & cannot be parent" | |
24d4b3d5 | 10821 | & " of 'C'P'P derivation if new interfaces are present", |
cefce34c JM |
10822 | Typ, Scope (Original_Record_Component (Comp))); |
10823 | ||
10824 | Error_Msg_Sloc := | |
10825 | Sloc (Scope (Original_Record_Component (Comp))); | |
10826 | Error_Msg_NE | |
10827 | ("type derived from 'C'P'P type & defined #", | |
10828 | Typ, Scope (Original_Record_Component (Comp))); | |
10829 | ||
10830 | -- Avoid duplicated warnings | |
10831 | ||
10832 | exit; | |
10833 | end; | |
10834 | ||
10835 | -- Initialize secondary tags | |
10836 | ||
10837 | else | |
d63199d8 PMR |
10838 | Initialize_Tag |
10839 | (Typ => Full_Typ, | |
10840 | Iface => Node (Iface_Elmt), | |
10841 | Tag_Comp => Tag_Comp, | |
10842 | Iface_Tag => Node (Iface_Tag_Elmt)); | |
cefce34c | 10843 | end if; |
04df6250 | 10844 | |
cefce34c JM |
10845 | -- Otherwise generate code to initialize the tag |
10846 | ||
10847 | else | |
04df6250 TQ |
10848 | if (In_Variable_Pos and then Variable_Comps) |
10849 | or else (not In_Variable_Pos and then Fixed_Comps) | |
10850 | then | |
d63199d8 PMR |
10851 | Initialize_Tag |
10852 | (Typ => Full_Typ, | |
10853 | Iface => Node (Iface_Elmt), | |
10854 | Tag_Comp => Tag_Comp, | |
10855 | Iface_Tag => Node (Iface_Tag_Elmt)); | |
04df6250 TQ |
10856 | end if; |
10857 | end if; | |
10858 | ||
10859 | Next_Elmt (Iface_Elmt); | |
10860 | Next_Elmt (Iface_Comp_Elmt); | |
10861 | Next_Elmt (Iface_Tag_Elmt); | |
10862 | end loop; | |
3476f949 JM |
10863 | end Init_Secondary_Tags; |
10864 | ||
c743425f EB |
10865 | ---------------------------- |
10866 | -- Is_Null_Statement_List -- | |
10867 | ---------------------------- | |
10868 | ||
10869 | function Is_Null_Statement_List (Stmts : List_Id) return Boolean is | |
10870 | Stmt : Node_Id; | |
10871 | ||
10872 | begin | |
c7862167 HK |
10873 | -- We must skip SCIL nodes because they may have been added to the list |
10874 | -- by Insert_Actions. | |
c743425f EB |
10875 | |
10876 | Stmt := First_Non_SCIL_Node (Stmts); | |
10877 | while Present (Stmt) loop | |
10878 | if Nkind (Stmt) = N_Case_Statement then | |
10879 | declare | |
10880 | Alt : Node_Id; | |
10881 | begin | |
10882 | Alt := First (Alternatives (Stmt)); | |
10883 | while Present (Alt) loop | |
10884 | if not Is_Null_Statement_List (Statements (Alt)) then | |
10885 | return False; | |
10886 | end if; | |
10887 | ||
10888 | Next (Alt); | |
10889 | end loop; | |
10890 | end; | |
10891 | ||
10892 | elsif Nkind (Stmt) /= N_Null_Statement then | |
10893 | return False; | |
10894 | end if; | |
10895 | ||
10896 | Stmt := Next_Non_SCIL_Node (Stmt); | |
10897 | end loop; | |
10898 | ||
10899 | return True; | |
10900 | end Is_Null_Statement_List; | |
10901 | ||
3476f949 JM |
10902 | ---------------------------------------- |
10903 | -- Make_Controlling_Function_Wrappers -- | |
10904 | ---------------------------------------- | |
a05e99a2 JM |
10905 | |
10906 | procedure Make_Controlling_Function_Wrappers | |
10907 | (Tag_Typ : Entity_Id; | |
10908 | Decl_List : out List_Id; | |
10909 | Body_List : out List_Id) | |
10910 | is | |
a714d2b0 PT |
10911 | Loc : constant Source_Ptr := Sloc (Tag_Typ); |
10912 | ||
10913 | function Make_Wrapper_Specification (Subp : Entity_Id) return Node_Id; | |
10914 | -- Returns a function specification with the same profile as Subp | |
10915 | ||
10916 | -------------------------------- | |
10917 | -- Make_Wrapper_Specification -- | |
10918 | -------------------------------- | |
10919 | ||
10920 | function Make_Wrapper_Specification (Subp : Entity_Id) return Node_Id is | |
10921 | begin | |
10922 | return | |
10923 | Make_Function_Specification (Loc, | |
10924 | Defining_Unit_Name => | |
10925 | Make_Defining_Identifier (Loc, | |
10926 | Chars => Chars (Subp)), | |
10927 | Parameter_Specifications => | |
10928 | Copy_Parameter_List (Subp), | |
10929 | Result_Definition => | |
10930 | New_Occurrence_Of (Etype (Subp), Loc)); | |
10931 | end Make_Wrapper_Specification; | |
10932 | ||
a05e99a2 JM |
10933 | Prim_Elmt : Elmt_Id; |
10934 | Subp : Entity_Id; | |
10935 | Actual_List : List_Id; | |
a05e99a2 JM |
10936 | Formal : Entity_Id; |
10937 | Par_Formal : Entity_Id; | |
2af751b3 | 10938 | Ext_Aggr : Node_Id; |
a05e99a2 | 10939 | Formal_Node : Node_Id; |
a05e99a2 | 10940 | Func_Body : Node_Id; |
55d4e6c0 | 10941 | Func_Decl : Node_Id; |
a714d2b0 | 10942 | Func_Id : Entity_Id; |
a05e99a2 | 10943 | |
a714d2b0 PT |
10944 | -- Start of processing for Make_Controlling_Function_Wrappers |
10945 | ||
a05e99a2 JM |
10946 | begin |
10947 | Decl_List := New_List; | |
10948 | Body_List := New_List; | |
10949 | ||
10950 | Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); | |
a05e99a2 JM |
10951 | while Present (Prim_Elmt) loop |
10952 | Subp := Node (Prim_Elmt); | |
10953 | ||
10954 | -- If a primitive function with a controlling result of the type has | |
10955 | -- not been overridden by the user, then we must create a wrapper | |
10956 | -- function here that effectively overrides it and invokes the | |
3476f949 JM |
10957 | -- (non-abstract) parent function. This can only occur for a null |
10958 | -- extension. Note that functions with anonymous controlling access | |
10959 | -- results don't qualify and must be overridden. We also exclude | |
10960 | -- Input attributes, since each type will have its own version of | |
10961 | -- Input constructed by the expander. The test for Comes_From_Source | |
10962 | -- is needed to distinguish inherited operations from renamings | |
8398e82e AC |
10963 | -- (which also have Alias set). We exclude internal entities with |
10964 | -- Interface_Alias to avoid generating duplicated wrappers since | |
10965 | -- the primitive which covers the interface is also available in | |
10966 | -- the list of primitive operations. | |
04df6250 | 10967 | |
47cc8d6b ES |
10968 | -- The function may be abstract, or require_Overriding may be set |
10969 | -- for it, because tests for null extensions may already have reset | |
04df6250 TQ |
10970 | -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not |
10971 | -- set, functions that need wrappers are recognized by having an | |
10972 | -- alias that returns the parent type. | |
10973 | ||
10974 | if Comes_From_Source (Subp) | |
10975 | or else No (Alias (Subp)) | |
8398e82e | 10976 | or else Present (Interface_Alias (Subp)) |
04df6250 TQ |
10977 | or else Ekind (Subp) /= E_Function |
10978 | or else not Has_Controlling_Result (Subp) | |
10979 | or else Is_Access_Type (Etype (Subp)) | |
10980 | or else Is_Abstract_Subprogram (Alias (Subp)) | |
10981 | or else Is_TSS (Subp, TSS_Stream_Input) | |
10982 | then | |
10983 | goto Next_Prim; | |
10984 | ||
10985 | elsif Is_Abstract_Subprogram (Subp) | |
10986 | or else Requires_Overriding (Subp) | |
10987 | or else | |
10988 | (Is_Null_Extension (Etype (Subp)) | |
10989 | and then Etype (Alias (Subp)) /= Etype (Subp)) | |
a05e99a2 | 10990 | then |
3bb4836f ES |
10991 | -- If there is a non-overloadable homonym in the current |
10992 | -- scope, the implicit declaration remains invisible. | |
10993 | -- We check the current entity with the same name, or its | |
10994 | -- homonym in case the derivation takes place after the | |
10995 | -- hiding object declaration. | |
10996 | ||
10997 | if Present (Current_Entity (Subp)) then | |
10998 | declare | |
10999 | Curr : constant Entity_Id := Current_Entity (Subp); | |
11000 | Prev : constant Entity_Id := Homonym (Curr); | |
11001 | begin | |
11002 | if (Comes_From_Source (Curr) | |
11003 | and then Scope (Curr) = Current_Scope | |
11004 | and then not Is_Overloadable (Curr)) | |
11005 | or else | |
11006 | (Present (Prev) | |
11007 | and then Comes_From_Source (Prev) | |
11008 | and then Scope (Prev) = Current_Scope | |
11009 | and then not Is_Overloadable (Prev)) | |
11010 | then | |
11011 | goto Next_Prim; | |
11012 | end if; | |
11013 | end; | |
11014 | end if; | |
11015 | ||
a714d2b0 PT |
11016 | Func_Decl := |
11017 | Make_Subprogram_Declaration (Loc, | |
11018 | Specification => Make_Wrapper_Specification (Subp)); | |
a05e99a2 | 11019 | |
a05e99a2 JM |
11020 | Append_To (Decl_List, Func_Decl); |
11021 | ||
11022 | -- Build a wrapper body that calls the parent function. The body | |
11023 | -- contains a single return statement that returns an extension | |
11024 | -- aggregate whose ancestor part is a call to the parent function, | |
11025 | -- passing the formals as actuals (with any controlling arguments | |
11026 | -- converted to the types of the corresponding formals of the | |
11027 | -- parent function, which might be anonymous access types), and | |
11028 | -- having a null extension. | |
11029 | ||
11030 | Formal := First_Formal (Subp); | |
11031 | Par_Formal := First_Formal (Alias (Subp)); | |
a714d2b0 PT |
11032 | Formal_Node := |
11033 | First (Parameter_Specifications (Specification (Func_Decl))); | |
a05e99a2 JM |
11034 | |
11035 | if Present (Formal) then | |
11036 | Actual_List := New_List; | |
a05e99a2 | 11037 | |
a714d2b0 PT |
11038 | while Present (Formal) loop |
11039 | if Is_Controlling_Formal (Formal) then | |
11040 | Append_To (Actual_List, | |
11041 | Make_Type_Conversion (Loc, | |
11042 | Subtype_Mark => | |
11043 | New_Occurrence_Of (Etype (Par_Formal), Loc), | |
11044 | Expression => | |
11045 | New_Occurrence_Of | |
11046 | (Defining_Identifier (Formal_Node), Loc))); | |
11047 | else | |
11048 | Append_To | |
11049 | (Actual_List, | |
e4494292 | 11050 | New_Occurrence_Of |
a714d2b0 PT |
11051 | (Defining_Identifier (Formal_Node), Loc)); |
11052 | end if; | |
a05e99a2 | 11053 | |
a714d2b0 PT |
11054 | Next_Formal (Formal); |
11055 | Next_Formal (Par_Formal); | |
11056 | Next (Formal_Node); | |
11057 | end loop; | |
11058 | else | |
11059 | Actual_List := No_List; | |
11060 | end if; | |
a05e99a2 | 11061 | |
2af751b3 PT |
11062 | Ext_Aggr := |
11063 | Make_Extension_Aggregate (Loc, | |
11064 | Ancestor_Part => | |
11065 | Make_Function_Call (Loc, | |
11066 | Name => | |
11067 | New_Occurrence_Of (Alias (Subp), Loc), | |
11068 | Parameter_Associations => Actual_List), | |
11069 | Null_Record_Present => True); | |
11070 | ||
11071 | -- GNATprove will use expression of an expression function as an | |
ea97b4db EB |
11072 | -- implicit postcondition. GNAT will also benefit from expression |
11073 | -- function to avoid premature freezing, but would struggle if we | |
11074 | -- added an expression function to freezing actions, so we create | |
11075 | -- the expanded form directly. | |
2af751b3 PT |
11076 | |
11077 | if GNATprove_Mode then | |
11078 | Func_Body := | |
11079 | Make_Expression_Function (Loc, | |
11080 | Specification => | |
11081 | Make_Wrapper_Specification (Subp), | |
11082 | Expression => Ext_Aggr); | |
11083 | else | |
11084 | Func_Body := | |
11085 | Make_Subprogram_Body (Loc, | |
11086 | Specification => | |
11087 | Make_Wrapper_Specification (Subp), | |
11088 | Declarations => Empty_List, | |
11089 | Handled_Statement_Sequence => | |
11090 | Make_Handled_Sequence_Of_Statements (Loc, | |
11091 | Statements => New_List ( | |
11092 | Make_Simple_Return_Statement (Loc, | |
11093 | Expression => Ext_Aggr)))); | |
ea97b4db | 11094 | Set_Was_Expression_Function (Func_Body); |
2af751b3 | 11095 | end if; |
a05e99a2 | 11096 | |
a05e99a2 JM |
11097 | Append_To (Body_List, Func_Body); |
11098 | ||
8398e82e AC |
11099 | -- Replace the inherited function with the wrapper function in the |
11100 | -- primitive operations list. We add the minimum decoration needed | |
11101 | -- to override interface primitives. | |
11102 | ||
a714d2b0 | 11103 | Func_Id := Defining_Unit_Name (Specification (Func_Decl)); |
a05e99a2 | 11104 | |
a714d2b0 PT |
11105 | Mutate_Ekind (Func_Id, E_Function); |
11106 | Set_Is_Wrapper (Func_Id); | |
11107 | ||
b1743c7d SB |
11108 | -- Corresponding_Spec will be set again to the same value during |
11109 | -- analysis, but we need this information earlier. | |
11110 | -- Expand_N_Freeze_Entity needs to know whether a subprogram body | |
11111 | -- is a wrapper's body in order to get check suppression right. | |
11112 | ||
11113 | Set_Corresponding_Spec (Func_Body, Func_Id); | |
a05e99a2 JM |
11114 | end if; |
11115 | ||
04df6250 | 11116 | <<Next_Prim>> |
a05e99a2 JM |
11117 | Next_Elmt (Prim_Elmt); |
11118 | end loop; | |
11119 | end Make_Controlling_Function_Wrappers; | |
11120 | ||
3e6845df AC |
11121 | ------------------ |
11122 | -- Make_Eq_Body -- | |
11123 | ------------------ | |
d151d6a3 AC |
11124 | |
11125 | function Make_Eq_Body | |
11126 | (Typ : Entity_Id; | |
11127 | Eq_Name : Name_Id) return Node_Id | |
11128 | is | |
11129 | Loc : constant Source_Ptr := Sloc (Parent (Typ)); | |
11130 | Decl : Node_Id; | |
11131 | Def : constant Node_Id := Parent (Typ); | |
11132 | Stmts : constant List_Id := New_List; | |
11133 | Variant_Case : Boolean := Has_Discriminants (Typ); | |
11134 | Comps : Node_Id := Empty; | |
11135 | Typ_Def : Node_Id := Type_Definition (Def); | |
11136 | ||
11137 | begin | |
11138 | Decl := | |
11139 | Predef_Spec_Or_Body (Loc, | |
82faa04d PT |
11140 | Tag_Typ => Typ, |
11141 | Name => Eq_Name, | |
11142 | Profile => New_List ( | |
d151d6a3 AC |
11143 | Make_Parameter_Specification (Loc, |
11144 | Defining_Identifier => | |
11145 | Make_Defining_Identifier (Loc, Name_X), | |
e4494292 | 11146 | Parameter_Type => New_Occurrence_Of (Typ, Loc)), |
d151d6a3 AC |
11147 | |
11148 | Make_Parameter_Specification (Loc, | |
11149 | Defining_Identifier => | |
11150 | Make_Defining_Identifier (Loc, Name_Y), | |
e4494292 | 11151 | Parameter_Type => New_Occurrence_Of (Typ, Loc))), |
d151d6a3 AC |
11152 | |
11153 | Ret_Type => Standard_Boolean, | |
11154 | For_Body => True); | |
11155 | ||
11156 | if Variant_Case then | |
11157 | if Nkind (Typ_Def) = N_Derived_Type_Definition then | |
11158 | Typ_Def := Record_Extension_Part (Typ_Def); | |
11159 | end if; | |
11160 | ||
11161 | if Present (Typ_Def) then | |
11162 | Comps := Component_List (Typ_Def); | |
11163 | end if; | |
11164 | ||
7a963087 RD |
11165 | Variant_Case := |
11166 | Present (Comps) and then Present (Variant_Part (Comps)); | |
d151d6a3 AC |
11167 | end if; |
11168 | ||
11169 | if Variant_Case then | |
11170 | Append_To (Stmts, | |
11171 | Make_Eq_If (Typ, Discriminant_Specifications (Def))); | |
11172 | Append_List_To (Stmts, Make_Eq_Case (Typ, Comps)); | |
11173 | Append_To (Stmts, | |
11174 | Make_Simple_Return_Statement (Loc, | |
e4494292 | 11175 | Expression => New_Occurrence_Of (Standard_True, Loc))); |
d151d6a3 AC |
11176 | |
11177 | else | |
11178 | Append_To (Stmts, | |
11179 | Make_Simple_Return_Statement (Loc, | |
11180 | Expression => | |
11181 | Expand_Record_Equality | |
11182 | (Typ, | |
99f8a653 PT |
11183 | Typ => Typ, |
11184 | Lhs => Make_Identifier (Loc, Name_X), | |
11185 | Rhs => Make_Identifier (Loc, Name_Y)))); | |
d151d6a3 AC |
11186 | end if; |
11187 | ||
11188 | Set_Handled_Statement_Sequence | |
11189 | (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts)); | |
11190 | return Decl; | |
11191 | end Make_Eq_Body; | |
11192 | ||
70482933 RK |
11193 | ------------------ |
11194 | -- Make_Eq_Case -- | |
11195 | ------------------ | |
11196 | ||
d70d147e | 11197 | -- <Make_Eq_If shared components> |
45ec05e1 | 11198 | |
70482933 RK |
11199 | -- case X.D1 is |
11200 | -- when V1 => <Make_Eq_Case> on subcomponents | |
11201 | -- ... | |
11202 | -- when Vn => <Make_Eq_Case> on subcomponents | |
11203 | -- end case; | |
11204 | ||
5d09245e | 11205 | function Make_Eq_Case |
2cbac6c6 AC |
11206 | (E : Entity_Id; |
11207 | CL : Node_Id; | |
fa1608c2 | 11208 | Discrs : Elist_Id := New_Elmt_List) return List_Id |
5d09245e AC |
11209 | is |
11210 | Loc : constant Source_Ptr := Sloc (E); | |
fbf5a39b | 11211 | Result : constant List_Id := New_List; |
70482933 RK |
11212 | Variant : Node_Id; |
11213 | Alt_List : List_Id; | |
70482933 | 11214 | |
fa1608c2 ES |
11215 | function Corresponding_Formal (C : Node_Id) return Entity_Id; |
11216 | -- Given the discriminant that controls a given variant of an unchecked | |
11217 | -- union, find the formal of the equality function that carries the | |
11218 | -- inferred value of the discriminant. | |
11219 | ||
11220 | function External_Name (E : Entity_Id) return Name_Id; | |
11221 | -- The value of a given discriminant is conveyed in the corresponding | |
11222 | -- formal parameter of the equality routine. The name of this formal | |
11223 | -- parameter carries a one-character suffix which is removed here. | |
11224 | ||
11225 | -------------------------- | |
11226 | -- Corresponding_Formal -- | |
11227 | -------------------------- | |
11228 | ||
11229 | function Corresponding_Formal (C : Node_Id) return Entity_Id is | |
11230 | Discr : constant Entity_Id := Entity (Name (Variant_Part (C))); | |
11231 | Elm : Elmt_Id; | |
11232 | ||
11233 | begin | |
11234 | Elm := First_Elmt (Discrs); | |
11235 | while Present (Elm) loop | |
11236 | if Chars (Discr) = External_Name (Node (Elm)) then | |
11237 | return Node (Elm); | |
11238 | end if; | |
dda38714 | 11239 | |
fa1608c2 ES |
11240 | Next_Elmt (Elm); |
11241 | end loop; | |
11242 | ||
11243 | -- A formal of the proper name must be found | |
11244 | ||
11245 | raise Program_Error; | |
11246 | end Corresponding_Formal; | |
11247 | ||
11248 | ------------------- | |
11249 | -- External_Name -- | |
11250 | ------------------- | |
11251 | ||
11252 | function External_Name (E : Entity_Id) return Name_Id is | |
11253 | begin | |
11254 | Get_Name_String (Chars (E)); | |
11255 | Name_Len := Name_Len - 1; | |
11256 | return Name_Find; | |
11257 | end External_Name; | |
11258 | ||
2cbac6c6 AC |
11259 | -- Start of processing for Make_Eq_Case |
11260 | ||
70482933 | 11261 | begin |
5d09245e | 11262 | Append_To (Result, Make_Eq_If (E, Component_Items (CL))); |
70482933 RK |
11263 | |
11264 | if No (Variant_Part (CL)) then | |
11265 | return Result; | |
11266 | end if; | |
11267 | ||
11268 | Variant := First_Non_Pragma (Variants (Variant_Part (CL))); | |
11269 | ||
11270 | if No (Variant) then | |
11271 | return Result; | |
11272 | end if; | |
11273 | ||
11274 | Alt_List := New_List; | |
70482933 RK |
11275 | while Present (Variant) loop |
11276 | Append_To (Alt_List, | |
11277 | Make_Case_Statement_Alternative (Loc, | |
11278 | Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)), | |
fa1608c2 ES |
11279 | Statements => |
11280 | Make_Eq_Case (E, Component_List (Variant), Discrs))); | |
70482933 RK |
11281 | Next_Non_Pragma (Variant); |
11282 | end loop; | |
11283 | ||
fa1608c2 ES |
11284 | -- If we have an Unchecked_Union, use one of the parameters of the |
11285 | -- enclosing equality routine that captures the discriminant, to use | |
11286 | -- as the expression in the generated case statement. | |
5d09245e AC |
11287 | |
11288 | if Is_Unchecked_Union (E) then | |
11289 | Append_To (Result, | |
11290 | Make_Case_Statement (Loc, | |
fa1608c2 | 11291 | Expression => |
e4494292 | 11292 | New_Occurrence_Of (Corresponding_Formal (CL), Loc), |
5d09245e AC |
11293 | Alternatives => Alt_List)); |
11294 | ||
11295 | else | |
11296 | Append_To (Result, | |
11297 | Make_Case_Statement (Loc, | |
11298 | Expression => | |
11299 | Make_Selected_Component (Loc, | |
7675ad4f | 11300 | Prefix => Make_Identifier (Loc, Name_X), |
5d09245e AC |
11301 | Selector_Name => New_Copy (Name (Variant_Part (CL)))), |
11302 | Alternatives => Alt_List)); | |
11303 | end if; | |
70482933 RK |
11304 | |
11305 | return Result; | |
11306 | end Make_Eq_Case; | |
11307 | ||
11308 | ---------------- | |
11309 | -- Make_Eq_If -- | |
11310 | ---------------- | |
11311 | ||
11312 | -- Generates: | |
11313 | ||
11314 | -- if | |
11315 | -- X.C1 /= Y.C1 | |
11316 | -- or else | |
11317 | -- X.C2 /= Y.C2 | |
11318 | -- ... | |
11319 | -- then | |
11320 | -- return False; | |
11321 | -- end if; | |
11322 | ||
5a30024a | 11323 | -- or a null statement if the list L is empty |
70482933 | 11324 | |
bdbb2a40 ES |
11325 | -- Equality may be user-defined for a given component type, in which case |
11326 | -- a function call is constructed instead of an operator node. This is an | |
11327 | -- Ada 2012 change in the composability of equality for untagged composite | |
11328 | -- types. | |
11329 | ||
5d09245e AC |
11330 | function Make_Eq_If |
11331 | (E : Entity_Id; | |
11332 | L : List_Id) return Node_Id | |
11333 | is | |
eedc5882 HK |
11334 | Loc : constant Source_Ptr := Sloc (E); |
11335 | ||
70482933 | 11336 | C : Node_Id; |
70482933 | 11337 | Cond : Node_Id; |
eedc5882 | 11338 | Field_Name : Name_Id; |
bdbb2a40 ES |
11339 | Next_Test : Node_Id; |
11340 | Typ : Entity_Id; | |
70482933 RK |
11341 | |
11342 | begin | |
11343 | if No (L) then | |
11344 | return Make_Null_Statement (Loc); | |
11345 | ||
11346 | else | |
11347 | Cond := Empty; | |
11348 | ||
11349 | C := First_Non_Pragma (L); | |
11350 | while Present (C) loop | |
bdbb2a40 | 11351 | Typ := Etype (Defining_Identifier (C)); |
70482933 RK |
11352 | Field_Name := Chars (Defining_Identifier (C)); |
11353 | ||
47cc8d6b | 11354 | -- The tags must not be compared: they are not part of the value. |
6d4e4fbc JM |
11355 | -- Ditto for parent interfaces because their equality operator is |
11356 | -- abstract. | |
47cc8d6b | 11357 | |
70482933 | 11358 | -- Note also that in the following, we use Make_Identifier for |
e4494292 | 11359 | -- the component names. Use of New_Occurrence_Of to identify the |
70482933 RK |
11360 | -- components would be incorrect because the wrong entities for |
11361 | -- discriminants could be picked up in the private type case. | |
11362 | ||
6d4e4fbc | 11363 | if Field_Name = Name_uParent |
bdbb2a40 | 11364 | and then Is_Interface (Typ) |
6d4e4fbc JM |
11365 | then |
11366 | null; | |
11367 | ||
11368 | elsif Field_Name /= Name_uTag then | |
bdbb2a40 ES |
11369 | declare |
11370 | Lhs : constant Node_Id := | |
11371 | Make_Selected_Component (Loc, | |
11372 | Prefix => Make_Identifier (Loc, Name_X), | |
11373 | Selector_Name => Make_Identifier (Loc, Field_Name)); | |
70482933 | 11374 | |
bdbb2a40 ES |
11375 | Rhs : constant Node_Id := |
11376 | Make_Selected_Component (Loc, | |
11377 | Prefix => Make_Identifier (Loc, Name_Y), | |
11378 | Selector_Name => Make_Identifier (Loc, Field_Name)); | |
11379 | Eq_Call : Node_Id; | |
11380 | ||
11381 | begin | |
11382 | -- Build equality code with a user-defined operator, if | |
eedc5882 | 11383 | -- available, and with the predefined "=" otherwise. For |
65f1ca2e AC |
11384 | -- compatibility with older Ada versions, we also use the |
11385 | -- predefined operation if the component-type equality is | |
11386 | -- abstract, rather than raising Program_Error. | |
bdbb2a40 ES |
11387 | |
11388 | if Ada_Version < Ada_2012 then | |
11389 | Next_Test := Make_Op_Ne (Loc, Lhs, Rhs); | |
11390 | ||
11391 | else | |
11392 | Eq_Call := Build_Eq_Call (Typ, Loc, Lhs, Rhs); | |
11393 | ||
11394 | if No (Eq_Call) then | |
11395 | Next_Test := Make_Op_Ne (Loc, Lhs, Rhs); | |
11396 | ||
6d0289b1 HK |
11397 | -- If a component has a defined abstract equality, its |
11398 | -- application raises Program_Error on that component | |
11399 | -- and therefore on the current variant. | |
bdbb2a40 ES |
11400 | |
11401 | elsif Nkind (Eq_Call) = N_Raise_Program_Error then | |
11402 | Set_Etype (Eq_Call, Standard_Boolean); | |
11403 | Next_Test := Make_Op_Not (Loc, Eq_Call); | |
11404 | ||
11405 | else | |
11406 | Next_Test := Make_Op_Not (Loc, Eq_Call); | |
11407 | end if; | |
11408 | end if; | |
11409 | end; | |
11410 | ||
11411 | Evolve_Or_Else (Cond, Next_Test); | |
70482933 RK |
11412 | end if; |
11413 | ||
11414 | Next_Non_Pragma (C); | |
11415 | end loop; | |
11416 | ||
11417 | if No (Cond) then | |
11418 | return Make_Null_Statement (Loc); | |
11419 | ||
11420 | else | |
11421 | return | |
5d09245e | 11422 | Make_Implicit_If_Statement (E, |
dda38714 | 11423 | Condition => Cond, |
70482933 | 11424 | Then_Statements => New_List ( |
04df6250 | 11425 | Make_Simple_Return_Statement (Loc, |
70482933 RK |
11426 | Expression => New_Occurrence_Of (Standard_False, Loc)))); |
11427 | end if; | |
11428 | end if; | |
11429 | end Make_Eq_If; | |
11430 | ||
dda38714 AC |
11431 | ------------------- |
11432 | -- Make_Neq_Body -- | |
11433 | ------------------- | |
cd20e505 AC |
11434 | |
11435 | function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is | |
11436 | ||
11437 | function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean; | |
11438 | -- Returns true if Prim is a renaming of an unresolved predefined | |
11439 | -- inequality operation. | |
11440 | ||
11441 | -------------------------------- | |
11442 | -- Is_Predefined_Neq_Renaming -- | |
11443 | -------------------------------- | |
11444 | ||
11445 | function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is | |
11446 | begin | |
11447 | return Chars (Prim) /= Name_Op_Ne | |
11448 | and then Present (Alias (Prim)) | |
11449 | and then Comes_From_Source (Prim) | |
11450 | and then Is_Intrinsic_Subprogram (Alias (Prim)) | |
11451 | and then Chars (Alias (Prim)) = Name_Op_Ne; | |
11452 | end Is_Predefined_Neq_Renaming; | |
11453 | ||
11454 | -- Local variables | |
11455 | ||
11456 | Loc : constant Source_Ptr := Sloc (Parent (Tag_Typ)); | |
cd20e505 AC |
11457 | Decl : Node_Id; |
11458 | Eq_Prim : Entity_Id; | |
11459 | Left_Op : Entity_Id; | |
11460 | Renaming_Prim : Entity_Id; | |
11461 | Right_Op : Entity_Id; | |
11462 | Target : Entity_Id; | |
11463 | ||
11464 | -- Start of processing for Make_Neq_Body | |
11465 | ||
11466 | begin | |
11467 | -- For a call on a renaming of a dispatching subprogram that is | |
11468 | -- overridden, if the overriding occurred before the renaming, then | |
11469 | -- the body executed is that of the overriding declaration, even if the | |
11470 | -- overriding declaration is not visible at the place of the renaming; | |
11471 | -- otherwise, the inherited or predefined subprogram is called, see | |
659e775a | 11472 | -- (RM 8.5.4(8)). |
cd20e505 | 11473 | |
2ed5b748 | 11474 | -- Stage 1: Search for a renaming of the inequality primitive and also |
cd20e505 AC |
11475 | -- search for an overriding of the equality primitive located before the |
11476 | -- renaming declaration. | |
11477 | ||
11478 | declare | |
11479 | Elmt : Elmt_Id; | |
11480 | Prim : Node_Id; | |
11481 | ||
11482 | begin | |
11483 | Eq_Prim := Empty; | |
11484 | Renaming_Prim := Empty; | |
11485 | ||
11486 | Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); | |
11487 | while Present (Elmt) loop | |
11488 | Prim := Node (Elmt); | |
11489 | ||
ee4eee0a | 11490 | if Is_User_Defined_Equality (Prim) and then No (Alias (Prim)) then |
cd20e505 AC |
11491 | if No (Renaming_Prim) then |
11492 | pragma Assert (No (Eq_Prim)); | |
11493 | Eq_Prim := Prim; | |
11494 | end if; | |
11495 | ||
11496 | elsif Is_Predefined_Neq_Renaming (Prim) then | |
11497 | Renaming_Prim := Prim; | |
11498 | end if; | |
11499 | ||
11500 | Next_Elmt (Elmt); | |
11501 | end loop; | |
11502 | end; | |
11503 | ||
11504 | -- No further action needed if no renaming was found | |
11505 | ||
11506 | if No (Renaming_Prim) then | |
11507 | return Empty; | |
11508 | end if; | |
11509 | ||
11510 | -- Stage 2: Replace the renaming declaration by a subprogram declaration | |
11511 | -- (required to add its body) | |
11512 | ||
11513 | Decl := Parent (Parent (Renaming_Prim)); | |
11514 | Rewrite (Decl, | |
11515 | Make_Subprogram_Declaration (Loc, | |
11516 | Specification => Specification (Decl))); | |
11517 | Set_Analyzed (Decl); | |
11518 | ||
11519 | -- Remove the decoration of intrinsic renaming subprogram | |
11520 | ||
11521 | Set_Is_Intrinsic_Subprogram (Renaming_Prim, False); | |
11522 | Set_Convention (Renaming_Prim, Convention_Ada); | |
11523 | Set_Alias (Renaming_Prim, Empty); | |
11524 | Set_Has_Completion (Renaming_Prim, False); | |
11525 | ||
11526 | -- Stage 3: Build the corresponding body | |
11527 | ||
11528 | Left_Op := First_Formal (Renaming_Prim); | |
11529 | Right_Op := Next_Formal (Left_Op); | |
11530 | ||
11531 | Decl := | |
11532 | Predef_Spec_Or_Body (Loc, | |
82faa04d PT |
11533 | Tag_Typ => Tag_Typ, |
11534 | Name => Chars (Renaming_Prim), | |
11535 | Profile => New_List ( | |
cd20e505 AC |
11536 | Make_Parameter_Specification (Loc, |
11537 | Defining_Identifier => | |
11538 | Make_Defining_Identifier (Loc, Chars (Left_Op)), | |
e4494292 | 11539 | Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)), |
cd20e505 AC |
11540 | |
11541 | Make_Parameter_Specification (Loc, | |
11542 | Defining_Identifier => | |
11543 | Make_Defining_Identifier (Loc, Chars (Right_Op)), | |
e4494292 | 11544 | Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), |
cd20e505 AC |
11545 | |
11546 | Ret_Type => Standard_Boolean, | |
11547 | For_Body => True); | |
11548 | ||
11549 | -- If the overriding of the equality primitive occurred before the | |
11550 | -- renaming, then generate: | |
11551 | ||
11552 | -- function <Neq_Name> (X : Y : Typ) return Boolean is | |
11553 | -- begin | |
11554 | -- return not Oeq (X, Y); | |
11555 | -- end; | |
11556 | ||
11557 | if Present (Eq_Prim) then | |
11558 | Target := Eq_Prim; | |
11559 | ||
11560 | -- Otherwise build a nested subprogram which performs the predefined | |
11561 | -- evaluation of the equality operator. That is, generate: | |
11562 | ||
11563 | -- function <Neq_Name> (X : Y : Typ) return Boolean is | |
11564 | -- function Oeq (X : Y) return Boolean is | |
11565 | -- begin | |
11566 | -- <<body of default implementation>> | |
11567 | -- end; | |
11568 | -- begin | |
11569 | -- return not Oeq (X, Y); | |
11570 | -- end; | |
11571 | ||
11572 | else | |
11573 | declare | |
11574 | Local_Subp : Node_Id; | |
11575 | begin | |
11576 | Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq); | |
11577 | Set_Declarations (Decl, New_List (Local_Subp)); | |
11578 | Target := Defining_Entity (Local_Subp); | |
11579 | end; | |
11580 | end if; | |
11581 | ||
cd20e505 | 11582 | Set_Handled_Statement_Sequence |
659e775a PT |
11583 | (Decl, |
11584 | Make_Handled_Sequence_Of_Statements (Loc, New_List ( | |
11585 | Make_Simple_Return_Statement (Loc, | |
11586 | Expression => | |
11587 | Make_Op_Not (Loc, | |
11588 | Make_Function_Call (Loc, | |
11589 | Name => New_Occurrence_Of (Target, Loc), | |
11590 | Parameter_Associations => New_List ( | |
11591 | Make_Identifier (Loc, Chars (Left_Op)), | |
11592 | Make_Identifier (Loc, Chars (Right_Op))))))))); | |
11593 | ||
cd20e505 AC |
11594 | return Decl; |
11595 | end Make_Neq_Body; | |
11596 | ||
e5a58fac AC |
11597 | ------------------------------- |
11598 | -- Make_Null_Procedure_Specs -- | |
11599 | ------------------------------- | |
11600 | ||
11601 | function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is | |
11602 | Decl_List : constant List_Id := New_List; | |
11603 | Loc : constant Source_Ptr := Sloc (Tag_Typ); | |
11604 | Formal : Entity_Id; | |
e5a58fac | 11605 | New_Param_Spec : Node_Id; |
54403a81 | 11606 | New_Spec : Node_Id; |
e5a58fac AC |
11607 | Parent_Subp : Entity_Id; |
11608 | Prim_Elmt : Elmt_Id; | |
11609 | Subp : Entity_Id; | |
11610 | ||
11611 | begin | |
11612 | Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); | |
11613 | while Present (Prim_Elmt) loop | |
11614 | Subp := Node (Prim_Elmt); | |
11615 | ||
11616 | -- If a null procedure inherited from an interface has not been | |
11617 | -- overridden, then we build a null procedure declaration to | |
11618 | -- override the inherited procedure. | |
11619 | ||
11620 | Parent_Subp := Alias (Subp); | |
11621 | ||
11622 | if Present (Parent_Subp) | |
11623 | and then Is_Null_Interface_Primitive (Parent_Subp) | |
11624 | then | |
54403a81 PT |
11625 | -- The null procedure spec is copied from the inherited procedure, |
11626 | -- except for the IS NULL (which must be added) and the overriding | |
11627 | -- indicators (which must be removed, if present). | |
e5a58fac | 11628 | |
54403a81 PT |
11629 | New_Spec := |
11630 | Copy_Subprogram_Spec (Subprogram_Specification (Subp), Loc); | |
e5a58fac | 11631 | |
54403a81 PT |
11632 | Set_Null_Present (New_Spec, True); |
11633 | Set_Must_Override (New_Spec, False); | |
11634 | Set_Must_Not_Override (New_Spec, False); | |
e5a58fac | 11635 | |
54403a81 PT |
11636 | Formal := First_Formal (Subp); |
11637 | New_Param_Spec := First (Parameter_Specifications (New_Spec)); | |
e5a58fac | 11638 | |
54403a81 | 11639 | while Present (Formal) loop |
e5a58fac | 11640 | |
54403a81 PT |
11641 | -- For controlling arguments we must change their parameter |
11642 | -- type to reference the tagged type (instead of the interface | |
11643 | -- type). | |
e5a58fac | 11644 | |
54403a81 PT |
11645 | if Is_Controlling_Formal (Formal) then |
11646 | if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier | |
11647 | then | |
11648 | Set_Parameter_Type (New_Param_Spec, | |
11649 | New_Occurrence_Of (Tag_Typ, Loc)); | |
11650 | ||
11651 | else pragma Assert | |
11652 | (Nkind (Parameter_Type (Parent (Formal))) = | |
11653 | N_Access_Definition); | |
11654 | Set_Subtype_Mark (Parameter_Type (New_Param_Spec), | |
11655 | New_Occurrence_Of (Tag_Typ, Loc)); | |
e5a58fac | 11656 | end if; |
54403a81 | 11657 | end if; |
e5a58fac | 11658 | |
54403a81 PT |
11659 | Next_Formal (Formal); |
11660 | Next (New_Param_Spec); | |
11661 | end loop; | |
e5a58fac AC |
11662 | |
11663 | Append_To (Decl_List, | |
11664 | Make_Subprogram_Declaration (Loc, | |
54403a81 | 11665 | Specification => New_Spec)); |
e5a58fac AC |
11666 | end if; |
11667 | ||
11668 | Next_Elmt (Prim_Elmt); | |
11669 | end loop; | |
11670 | ||
11671 | return Decl_List; | |
11672 | end Make_Null_Procedure_Specs; | |
11673 | ||
5ae5ba7a PT |
11674 | --------------------------------------- |
11675 | -- Make_Predefined_Primitive_Eq_Spec -- | |
11676 | --------------------------------------- | |
70482933 | 11677 | |
5ae5ba7a | 11678 | procedure Make_Predefined_Primitive_Eq_Spec |
70482933 | 11679 | (Tag_Typ : Entity_Id; |
5ae5ba7a | 11680 | Predef_List : List_Id; |
4ce9a2d8 | 11681 | Renamed_Eq : out Entity_Id) |
70482933 | 11682 | is |
70482933 RK |
11683 | function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean; |
11684 | -- Returns true if Prim is a renaming of an unresolved predefined | |
11685 | -- equality operation. | |
11686 | ||
fbf5a39b AC |
11687 | ------------------------------- |
11688 | -- Is_Predefined_Eq_Renaming -- | |
11689 | ------------------------------- | |
11690 | ||
70482933 RK |
11691 | function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is |
11692 | begin | |
11693 | return Chars (Prim) /= Name_Op_Eq | |
11694 | and then Present (Alias (Prim)) | |
11695 | and then Comes_From_Source (Prim) | |
11696 | and then Is_Intrinsic_Subprogram (Alias (Prim)) | |
11697 | and then Chars (Alias (Prim)) = Name_Op_Eq; | |
11698 | end Is_Predefined_Eq_Renaming; | |
11699 | ||
cd20e505 AC |
11700 | -- Local variables |
11701 | ||
5ae5ba7a PT |
11702 | Loc : constant Source_Ptr := Sloc (Tag_Typ); |
11703 | ||
11704 | Eq_Name : Name_Id := Name_Op_Eq; | |
11705 | Eq_Needed : Boolean := True; | |
cd20e505 AC |
11706 | Eq_Spec : Node_Id; |
11707 | Prim : Elmt_Id; | |
11708 | ||
11709 | Has_Predef_Eq_Renaming : Boolean := False; | |
11710 | -- Set to True if Tag_Typ has a primitive that renames the predefined | |
11711 | -- equality operator. Used to implement (RM 8-5-4(8)). | |
11712 | ||
70482933 RK |
11713 | -- Start of processing for Make_Predefined_Primitive_Specs |
11714 | ||
5ae5ba7a PT |
11715 | begin |
11716 | Renamed_Eq := Empty; | |
11717 | ||
11718 | Prim := First_Elmt (Primitive_Operations (Tag_Typ)); | |
11719 | while Present (Prim) loop | |
11720 | ||
11721 | -- If a primitive is encountered that renames the predefined equality | |
11722 | -- operator before reaching any explicit equality primitive, then we | |
11723 | -- still need to create a predefined equality function, because calls | |
11724 | -- to it can occur via the renaming. A new name is created for the | |
11725 | -- equality to avoid conflicting with any user-defined equality. | |
11726 | -- (Note that this doesn't account for renamings of equality nested | |
11727 | -- within subpackages???) | |
11728 | ||
11729 | if Is_Predefined_Eq_Renaming (Node (Prim)) then | |
11730 | Has_Predef_Eq_Renaming := True; | |
11731 | Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); | |
11732 | ||
11733 | -- User-defined equality | |
11734 | ||
11735 | elsif Is_User_Defined_Equality (Node (Prim)) then | |
11736 | if No (Alias (Node (Prim))) | |
11737 | or else Nkind (Unit_Declaration_Node (Node (Prim))) = | |
11738 | N_Subprogram_Renaming_Declaration | |
11739 | then | |
11740 | Eq_Needed := False; | |
11741 | exit; | |
11742 | ||
11743 | -- If the parent is not an interface type and has an abstract | |
11744 | -- equality function explicitly defined in the sources, then the | |
11745 | -- inherited equality is abstract as well, and no body can be | |
11746 | -- created for it. | |
11747 | ||
11748 | elsif not Is_Interface (Etype (Tag_Typ)) | |
11749 | and then Present (Alias (Node (Prim))) | |
11750 | and then Comes_From_Source (Alias (Node (Prim))) | |
11751 | and then Is_Abstract_Subprogram (Alias (Node (Prim))) | |
11752 | then | |
11753 | Eq_Needed := False; | |
11754 | exit; | |
11755 | ||
11756 | -- If the type has an equality function corresponding with a | |
11757 | -- primitive defined in an interface type, the inherited equality | |
11758 | -- is abstract as well, and no body can be created for it. | |
11759 | ||
11760 | elsif Present (Alias (Node (Prim))) | |
11761 | and then Comes_From_Source (Ultimate_Alias (Node (Prim))) | |
11762 | and then | |
11763 | Is_Interface | |
11764 | (Find_Dispatching_Type (Ultimate_Alias (Node (Prim)))) | |
11765 | then | |
11766 | Eq_Needed := False; | |
11767 | exit; | |
11768 | end if; | |
11769 | end if; | |
11770 | ||
11771 | Next_Elmt (Prim); | |
11772 | end loop; | |
11773 | ||
11774 | -- If a renaming of predefined equality was found but there was no | |
11775 | -- user-defined equality (so Eq_Needed is still true), then set the name | |
11776 | -- back to Name_Op_Eq. But in the case where a user-defined equality was | |
11777 | -- located after such a renaming, then the predefined equality function | |
11778 | -- is still needed, so Eq_Needed must be set back to True. | |
11779 | ||
11780 | if Eq_Name /= Name_Op_Eq then | |
11781 | if Eq_Needed then | |
11782 | Eq_Name := Name_Op_Eq; | |
11783 | else | |
11784 | Eq_Needed := True; | |
11785 | end if; | |
11786 | end if; | |
11787 | ||
11788 | if Eq_Needed then | |
11789 | Eq_Spec := Predef_Spec_Or_Body (Loc, | |
82faa04d PT |
11790 | Tag_Typ => Tag_Typ, |
11791 | Name => Eq_Name, | |
11792 | Profile => New_List ( | |
5ae5ba7a PT |
11793 | Make_Parameter_Specification (Loc, |
11794 | Defining_Identifier => | |
11795 | Make_Defining_Identifier (Loc, Name_X), | |
11796 | Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)), | |
11797 | ||
11798 | Make_Parameter_Specification (Loc, | |
11799 | Defining_Identifier => | |
11800 | Make_Defining_Identifier (Loc, Name_Y), | |
11801 | Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), | |
82faa04d | 11802 | Ret_Type => Standard_Boolean); |
5ae5ba7a PT |
11803 | Append_To (Predef_List, Eq_Spec); |
11804 | ||
11805 | if Has_Predef_Eq_Renaming then | |
11806 | Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec)); | |
11807 | ||
11808 | Prim := First_Elmt (Primitive_Operations (Tag_Typ)); | |
11809 | while Present (Prim) loop | |
11810 | ||
11811 | -- Any renamings of equality that appeared before an overriding | |
11812 | -- equality must be updated to refer to the entity for the | |
11813 | -- predefined equality, otherwise calls via the renaming would | |
11814 | -- get incorrectly resolved to call the user-defined equality | |
11815 | -- function. | |
11816 | ||
11817 | if Is_Predefined_Eq_Renaming (Node (Prim)) then | |
11818 | Set_Alias (Node (Prim), Renamed_Eq); | |
11819 | ||
11820 | -- Exit upon encountering a user-defined equality | |
11821 | ||
11822 | elsif Chars (Node (Prim)) = Name_Op_Eq | |
11823 | and then No (Alias (Node (Prim))) | |
11824 | then | |
11825 | exit; | |
11826 | end if; | |
11827 | ||
11828 | Next_Elmt (Prim); | |
11829 | end loop; | |
11830 | end if; | |
11831 | end if; | |
11832 | end Make_Predefined_Primitive_Eq_Spec; | |
11833 | ||
11834 | ------------------------------------- | |
11835 | -- Make_Predefined_Primitive_Specs -- | |
11836 | ------------------------------------- | |
11837 | ||
11838 | procedure Make_Predefined_Primitive_Specs | |
11839 | (Tag_Typ : Entity_Id; | |
11840 | Predef_List : out List_Id; | |
11841 | Renamed_Eq : out Entity_Id) | |
11842 | is | |
11843 | Loc : constant Source_Ptr := Sloc (Tag_Typ); | |
11844 | Res : constant List_Id := New_List; | |
11845 | ||
11846 | use Exp_Put_Image; | |
11847 | ||
70482933 RK |
11848 | begin |
11849 | Renamed_Eq := Empty; | |
11850 | ||
a9d8907c | 11851 | -- Spec of _Size |
fbf5a39b AC |
11852 | |
11853 | Append_To (Res, Predef_Spec_Or_Body (Loc, | |
82faa04d PT |
11854 | Tag_Typ => Tag_Typ, |
11855 | Name => Name_uSize, | |
11856 | Profile => New_List ( | |
fbf5a39b AC |
11857 | Make_Parameter_Specification (Loc, |
11858 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
e4494292 | 11859 | Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), |
fbf5a39b | 11860 | |
a9d8907c | 11861 | Ret_Type => Standard_Long_Long_Integer)); |
fbf5a39b | 11862 | |
110d0820 BD |
11863 | -- Spec of Put_Image |
11864 | ||
8f563162 AC |
11865 | if not No_Run_Time_Mode |
11866 | and then RTE_Available (RE_Root_Buffer_Type) | |
09768159 SB |
11867 | then |
11868 | -- No_Run_Time_Mode implies that the declaration of Tag_Typ | |
11869 | -- (like any tagged type) will be rejected. Given this, avoid | |
11870 | -- cascading errors associated with the Tag_Typ's TSS_Put_Image | |
11871 | -- procedure. | |
11872 | ||
110d0820 BD |
11873 | Append_To (Res, Predef_Spec_Or_Body (Loc, |
11874 | Tag_Typ => Tag_Typ, | |
11875 | Name => Make_TSS_Name (Tag_Typ, TSS_Put_Image), | |
11876 | Profile => Build_Put_Image_Profile (Loc, Tag_Typ))); | |
11877 | end if; | |
11878 | ||
3ca505dc | 11879 | -- Specs for dispatching stream attributes |
d2d3604c TQ |
11880 | |
11881 | declare | |
11882 | Stream_Op_TSS_Names : | |
3b387bff | 11883 | constant array (Positive range <>) of TSS_Name_Type := |
d2d3604c TQ |
11884 | (TSS_Stream_Read, |
11885 | TSS_Stream_Write, | |
11886 | TSS_Stream_Input, | |
11887 | TSS_Stream_Output); | |
ae7adb1b | 11888 | |
d2d3604c TQ |
11889 | begin |
11890 | for Op in Stream_Op_TSS_Names'Range loop | |
11891 | if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then | |
11892 | Append_To (Res, | |
ae7adb1b ES |
11893 | Predef_Stream_Attr_Spec (Loc, Tag_Typ, |
11894 | Stream_Op_TSS_Names (Op))); | |
d2d3604c TQ |
11895 | end if; |
11896 | end loop; | |
11897 | end; | |
70482933 | 11898 | |
cd20e505 AC |
11899 | -- Spec of "=" is expanded if the type is not limited and if a user |
11900 | -- defined "=" was not already declared for the non-full view of a | |
5ae5ba7a | 11901 | -- private extension. |
70482933 | 11902 | |
fbf5a39b | 11903 | if not Is_Limited_Type (Tag_Typ) then |
5ae5ba7a | 11904 | Make_Predefined_Primitive_Eq_Spec (Tag_Typ, Res, Renamed_Eq); |
70482933 RK |
11905 | |
11906 | -- Spec for dispatching assignment | |
11907 | ||
11908 | Append_To (Res, Predef_Spec_Or_Body (Loc, | |
11909 | Tag_Typ => Tag_Typ, | |
11910 | Name => Name_uAssign, | |
11911 | Profile => New_List ( | |
11912 | Make_Parameter_Specification (Loc, | |
11913 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
11914 | Out_Present => True, | |
e4494292 | 11915 | Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)), |
70482933 RK |
11916 | |
11917 | Make_Parameter_Specification (Loc, | |
11918 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), | |
e4494292 | 11919 | Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))))); |
70482933 RK |
11920 | end if; |
11921 | ||
47cc8d6b ES |
11922 | -- Ada 2005: Generate declarations for the following primitive |
11923 | -- operations for limited interfaces and synchronized types that | |
11924 | -- implement a limited interface. | |
4d744221 | 11925 | |
4ce9a2d8 HK |
11926 | -- Disp_Asynchronous_Select |
11927 | -- Disp_Conditional_Select | |
11928 | -- Disp_Get_Prim_Op_Kind | |
11929 | -- Disp_Get_Task_Id | |
11930 | -- Disp_Requeue | |
11931 | -- Disp_Timed_Select | |
4d744221 | 11932 | |
a59626c8 | 11933 | -- Disable the generation of these bodies if Ravenscar or ZFP is active |
10b93b2e | 11934 | |
0791fbe9 | 11935 | if Ada_Version >= Ada_2005 |
c09a557e | 11936 | and then not Restriction_Active (No_Select_Statements) |
3edf2f76 | 11937 | and then RTE_Available (RE_Select_Specific_Data) |
10b93b2e | 11938 | then |
4ce9a2d8 | 11939 | -- These primitives are defined abstract in interface types |
10b93b2e | 11940 | |
4ce9a2d8 HK |
11941 | if Is_Interface (Tag_Typ) |
11942 | and then Is_Limited_Record (Tag_Typ) | |
11943 | then | |
11944 | Append_To (Res, | |
11945 | Make_Abstract_Subprogram_Declaration (Loc, | |
11946 | Specification => | |
11947 | Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); | |
10b93b2e | 11948 | |
4ce9a2d8 HK |
11949 | Append_To (Res, |
11950 | Make_Abstract_Subprogram_Declaration (Loc, | |
11951 | Specification => | |
11952 | Make_Disp_Conditional_Select_Spec (Tag_Typ))); | |
10b93b2e | 11953 | |
4ce9a2d8 HK |
11954 | Append_To (Res, |
11955 | Make_Abstract_Subprogram_Declaration (Loc, | |
11956 | Specification => | |
11957 | Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); | |
10b93b2e | 11958 | |
4ce9a2d8 HK |
11959 | Append_To (Res, |
11960 | Make_Abstract_Subprogram_Declaration (Loc, | |
11961 | Specification => | |
11962 | Make_Disp_Get_Task_Id_Spec (Tag_Typ))); | |
11963 | ||
11964 | Append_To (Res, | |
11965 | Make_Abstract_Subprogram_Declaration (Loc, | |
11966 | Specification => | |
11967 | Make_Disp_Requeue_Spec (Tag_Typ))); | |
11968 | ||
11969 | Append_To (Res, | |
11970 | Make_Abstract_Subprogram_Declaration (Loc, | |
11971 | Specification => | |
11972 | Make_Disp_Timed_Select_Spec (Tag_Typ))); | |
11973 | ||
24d4b3d5 AC |
11974 | -- If ancestor is an interface type, declare non-abstract primitives |
11975 | -- to override the abstract primitives of the interface type. | |
4ce9a2d8 | 11976 | |
4fbad0ba AC |
11977 | -- In VM targets we define these primitives in all root tagged types |
11978 | -- that are not interface types. Done because in VM targets we don't | |
11979 | -- have secondary dispatch tables and any derivation of Tag_Typ may | |
11980 | -- cover limited interfaces (which always have these primitives since | |
11981 | -- they may be ancestors of synchronized interface types). | |
11982 | ||
4ce9a2d8 | 11983 | elsif (not Is_Interface (Tag_Typ) |
052e0603 AC |
11984 | and then Is_Interface (Etype (Tag_Typ)) |
11985 | and then Is_Limited_Record (Etype (Tag_Typ))) | |
4ce9a2d8 HK |
11986 | or else |
11987 | (Is_Concurrent_Record_Type (Tag_Typ) | |
052e0603 | 11988 | and then Has_Interfaces (Tag_Typ)) |
4fbad0ba AC |
11989 | or else |
11990 | (not Tagged_Type_Expansion | |
052e0603 AC |
11991 | and then not Is_Interface (Tag_Typ) |
11992 | and then Tag_Typ = Root_Type (Tag_Typ)) | |
4ce9a2d8 HK |
11993 | then |
11994 | Append_To (Res, | |
11995 | Make_Subprogram_Declaration (Loc, | |
11996 | Specification => | |
11997 | Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); | |
11998 | ||
11999 | Append_To (Res, | |
12000 | Make_Subprogram_Declaration (Loc, | |
12001 | Specification => | |
12002 | Make_Disp_Conditional_Select_Spec (Tag_Typ))); | |
12003 | ||
12004 | Append_To (Res, | |
12005 | Make_Subprogram_Declaration (Loc, | |
12006 | Specification => | |
12007 | Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); | |
12008 | ||
12009 | Append_To (Res, | |
12010 | Make_Subprogram_Declaration (Loc, | |
12011 | Specification => | |
12012 | Make_Disp_Get_Task_Id_Spec (Tag_Typ))); | |
12013 | ||
12014 | Append_To (Res, | |
12015 | Make_Subprogram_Declaration (Loc, | |
12016 | Specification => | |
12017 | Make_Disp_Requeue_Spec (Tag_Typ))); | |
12018 | ||
12019 | Append_To (Res, | |
12020 | Make_Subprogram_Declaration (Loc, | |
12021 | Specification => | |
12022 | Make_Disp_Timed_Select_Spec (Tag_Typ))); | |
12023 | end if; | |
10b93b2e HK |
12024 | end if; |
12025 | ||
df3e68b1 | 12026 | -- All tagged types receive their own Deep_Adjust and Deep_Finalize |
d3f70b35 | 12027 | -- regardless of whether they are controlled or may contain controlled |
df3e68b1 | 12028 | -- components. |
70482933 | 12029 | |
df3e68b1 | 12030 | -- Do not generate the routines if finalization is disabled |
70482933 | 12031 | |
df3e68b1 | 12032 | if Restriction_Active (No_Finalization) then |
70482933 RK |
12033 | null; |
12034 | ||
df3e68b1 | 12035 | else |
90e9a6be | 12036 | if not Is_Limited_Type (Tag_Typ) then |
d3f70b35 | 12037 | Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust)); |
70482933 RK |
12038 | end if; |
12039 | ||
d3f70b35 | 12040 | Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize)); |
70482933 RK |
12041 | end if; |
12042 | ||
12043 | Predef_List := Res; | |
12044 | end Make_Predefined_Primitive_Specs; | |
12045 | ||
26b043e0 AC |
12046 | ------------------------- |
12047 | -- Make_Tag_Assignment -- | |
12048 | ------------------------- | |
12049 | ||
12050 | function Make_Tag_Assignment (N : Node_Id) return Node_Id is | |
12051 | Loc : constant Source_Ptr := Sloc (N); | |
af10c962 | 12052 | Def_Id : constant Entity_Id := Defining_Identifier (N); |
3b5f3138 | 12053 | Expr : constant Node_Id := Expression (N); |
af10c962 | 12054 | Typ : constant Entity_Id := Etype (Def_Id); |
3b5f3138 EB |
12055 | Full_Typ : constant Entity_Id := Underlying_Type (Typ); |
12056 | ||
26b043e0 | 12057 | begin |
3b5f3138 | 12058 | -- This expansion activity is called during analysis |
c7d22ee7 | 12059 | |
26b043e0 | 12060 | if Is_Tagged_Type (Typ) |
3b5f3138 EB |
12061 | and then not Is_Class_Wide_Type (Typ) |
12062 | and then not Is_CPP_Class (Typ) | |
12063 | and then Tagged_Type_Expansion | |
af10c962 | 12064 | and then Nkind (Unqualify (Expr)) /= N_Aggregate |
26b043e0 | 12065 | then |
26b043e0 | 12066 | return |
af10c962 EB |
12067 | Make_Tag_Assignment_From_Type |
12068 | (Loc, New_Occurrence_Of (Def_Id, Loc), Full_Typ); | |
12069 | ||
26b043e0 AC |
12070 | else |
12071 | return Empty; | |
12072 | end if; | |
12073 | end Make_Tag_Assignment; | |
12074 | ||
70482933 RK |
12075 | ---------------------- |
12076 | -- Predef_Deep_Spec -- | |
12077 | ---------------------- | |
12078 | ||
12079 | function Predef_Deep_Spec | |
12080 | (Loc : Source_Ptr; | |
12081 | Tag_Typ : Entity_Id; | |
fbf5a39b | 12082 | Name : TSS_Name_Type; |
2e071734 | 12083 | For_Body : Boolean := False) return Node_Id |
70482933 | 12084 | is |
df3e68b1 | 12085 | Formals : List_Id; |
70482933 RK |
12086 | |
12087 | begin | |
df3e68b1 | 12088 | -- V : in out Tag_Typ |
70482933 | 12089 | |
df3e68b1 HK |
12090 | Formals := New_List ( |
12091 | Make_Parameter_Specification (Loc, | |
243cae0a AC |
12092 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), |
12093 | In_Present => True, | |
12094 | Out_Present => True, | |
e4494292 | 12095 | Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))); |
70482933 | 12096 | |
df3e68b1 | 12097 | -- F : Boolean := True |
70482933 | 12098 | |
df3e68b1 HK |
12099 | if Name = TSS_Deep_Adjust |
12100 | or else Name = TSS_Deep_Finalize | |
12101 | then | |
12102 | Append_To (Formals, | |
70482933 | 12103 | Make_Parameter_Specification (Loc, |
243cae0a | 12104 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_F), |
e4494292 RD |
12105 | Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), |
12106 | Expression => New_Occurrence_Of (Standard_True, Loc))); | |
df3e68b1 | 12107 | end if; |
70482933 | 12108 | |
df3e68b1 HK |
12109 | return |
12110 | Predef_Spec_Or_Body (Loc, | |
12111 | Name => Make_TSS_Name (Tag_Typ, Name), | |
12112 | Tag_Typ => Tag_Typ, | |
12113 | Profile => Formals, | |
12114 | For_Body => For_Body); | |
fbf5a39b AC |
12115 | |
12116 | exception | |
12117 | when RE_Not_Available => | |
12118 | return Empty; | |
70482933 RK |
12119 | end Predef_Deep_Spec; |
12120 | ||
12121 | ------------------------- | |
12122 | -- Predef_Spec_Or_Body -- | |
12123 | ------------------------- | |
12124 | ||
12125 | function Predef_Spec_Or_Body | |
12126 | (Loc : Source_Ptr; | |
12127 | Tag_Typ : Entity_Id; | |
12128 | Name : Name_Id; | |
12129 | Profile : List_Id; | |
12130 | Ret_Type : Entity_Id := Empty; | |
2e071734 | 12131 | For_Body : Boolean := False) return Node_Id |
70482933 | 12132 | is |
fbf5a39b | 12133 | Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name); |
70482933 RK |
12134 | Spec : Node_Id; |
12135 | ||
12136 | begin | |
12137 | Set_Is_Public (Id, Is_Public (Tag_Typ)); | |
12138 | ||
47cc8d6b ES |
12139 | -- The internal flag is set to mark these declarations because they have |
12140 | -- specific properties. First, they are primitives even if they are not | |
12141 | -- defined in the type scope (the freezing point is not necessarily in | |
12142 | -- the same scope). Second, the predefined equality can be overridden by | |
12143 | -- a user-defined equality, no body will be generated in this case. | |
70482933 RK |
12144 | |
12145 | Set_Is_Internal (Id); | |
12146 | ||
12147 | if not Debug_Generated_Code then | |
12148 | Set_Debug_Info_Off (Id); | |
12149 | end if; | |
12150 | ||
12151 | if No (Ret_Type) then | |
12152 | Spec := | |
12153 | Make_Procedure_Specification (Loc, | |
12154 | Defining_Unit_Name => Id, | |
12155 | Parameter_Specifications => Profile); | |
12156 | else | |
12157 | Spec := | |
12158 | Make_Function_Specification (Loc, | |
12159 | Defining_Unit_Name => Id, | |
12160 | Parameter_Specifications => Profile, | |
e4494292 | 12161 | Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); |
70482933 RK |
12162 | end if; |
12163 | ||
72e324b6 GD |
12164 | -- Declare an abstract subprogram for primitive subprograms of an |
12165 | -- interface type (except for "="). | |
12166 | ||
4ce9a2d8 | 12167 | if Is_Interface (Tag_Typ) then |
72e324b6 GD |
12168 | if Name /= Name_Op_Eq then |
12169 | return Make_Abstract_Subprogram_Declaration (Loc, Spec); | |
12170 | ||
12171 | -- The equality function (if any) for an interface type is defined | |
12172 | -- to be nonabstract, so we create an expression function for it that | |
12173 | -- always returns False. Note that the function can never actually be | |
12174 | -- invoked because interface types are abstract, so there aren't any | |
12175 | -- objects of such types (and their equality operation will always | |
12176 | -- dispatch). | |
12177 | ||
12178 | else | |
12179 | return Make_Expression_Function | |
12180 | (Loc, Spec, New_Occurrence_Of (Standard_False, Loc)); | |
12181 | end if; | |
4ce9a2d8 | 12182 | |
47cc8d6b ES |
12183 | -- If body case, return empty subprogram body. Note that this is ill- |
12184 | -- formed, because there is not even a null statement, and certainly not | |
12185 | -- a return in the function case. The caller is expected to do surgery | |
12186 | -- on the body to add the appropriate stuff. | |
70482933 | 12187 | |
4ce9a2d8 | 12188 | elsif For_Body then |
70482933 RK |
12189 | return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty); |
12190 | ||
93188a0b GD |
12191 | -- For the case of an Input attribute predefined for an abstract type, |
12192 | -- generate an abstract specification. This will never be called, but we | |
12193 | -- need the slot allocated in the dispatching table so that attributes | |
47cc8d6b | 12194 | -- typ'Class'Input and typ'Class'Output will work properly. |
70482933 | 12195 | |
93188a0b | 12196 | elsif Is_TSS (Name, TSS_Stream_Input) |
ea1941af | 12197 | and then Is_Abstract_Type (Tag_Typ) |
70482933 RK |
12198 | then |
12199 | return Make_Abstract_Subprogram_Declaration (Loc, Spec); | |
12200 | ||
12201 | -- Normal spec case, where we return a subprogram declaration | |
12202 | ||
12203 | else | |
12204 | return Make_Subprogram_Declaration (Loc, Spec); | |
12205 | end if; | |
12206 | end Predef_Spec_Or_Body; | |
12207 | ||
12208 | ----------------------------- | |
12209 | -- Predef_Stream_Attr_Spec -- | |
12210 | ----------------------------- | |
12211 | ||
12212 | function Predef_Stream_Attr_Spec | |
35338c60 ES |
12213 | (Loc : Source_Ptr; |
12214 | Tag_Typ : Entity_Id; | |
12215 | Name : TSS_Name_Type) return Node_Id | |
70482933 RK |
12216 | is |
12217 | Ret_Type : Entity_Id; | |
12218 | ||
12219 | begin | |
fbf5a39b | 12220 | if Name = TSS_Stream_Input then |
70482933 RK |
12221 | Ret_Type := Tag_Typ; |
12222 | else | |
12223 | Ret_Type := Empty; | |
12224 | end if; | |
12225 | ||
243cae0a AC |
12226 | return |
12227 | Predef_Spec_Or_Body | |
12228 | (Loc, | |
12229 | Name => Make_TSS_Name (Tag_Typ, Name), | |
12230 | Tag_Typ => Tag_Typ, | |
12231 | Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name), | |
12232 | Ret_Type => Ret_Type, | |
35338c60 | 12233 | For_Body => False); |
70482933 RK |
12234 | end Predef_Stream_Attr_Spec; |
12235 | ||
5ae5ba7a PT |
12236 | ---------------------------------- |
12237 | -- Predefined_Primitive_Eq_Body -- | |
12238 | ---------------------------------- | |
70482933 | 12239 | |
5ae5ba7a PT |
12240 | procedure Predefined_Primitive_Eq_Body |
12241 | (Tag_Typ : Entity_Id; | |
12242 | Predef_List : List_Id; | |
12243 | Renamed_Eq : Entity_Id) | |
70482933 | 12244 | is |
70482933 | 12245 | Decl : Node_Id; |
70482933 RK |
12246 | Eq_Needed : Boolean; |
12247 | Eq_Name : Name_Id; | |
5ae5ba7a | 12248 | Prim : Elmt_Id; |
110d0820 | 12249 | |
70482933 RK |
12250 | begin |
12251 | -- See if we have a predefined "=" operator | |
12252 | ||
12253 | if Present (Renamed_Eq) then | |
12254 | Eq_Needed := True; | |
12255 | Eq_Name := Chars (Renamed_Eq); | |
12256 | ||
4ce9a2d8 HK |
12257 | -- If the parent is an interface type then it has defined all the |
12258 | -- predefined primitives abstract and we need to check if the type | |
0d66cee5 AC |
12259 | -- has some user defined "=" function which matches the profile of |
12260 | -- the Ada predefined equality operator to avoid generating it. | |
4ce9a2d8 HK |
12261 | |
12262 | elsif Is_Interface (Etype (Tag_Typ)) then | |
12263 | Eq_Needed := True; | |
12264 | Eq_Name := Name_Op_Eq; | |
12265 | ||
12266 | Prim := First_Elmt (Primitive_Operations (Tag_Typ)); | |
12267 | while Present (Prim) loop | |
909ce352 | 12268 | if Is_User_Defined_Equality (Node (Prim)) |
4ce9a2d8 HK |
12269 | and then not Is_Internal (Node (Prim)) |
12270 | then | |
12271 | Eq_Needed := False; | |
12272 | Eq_Name := No_Name; | |
12273 | exit; | |
12274 | end if; | |
12275 | ||
12276 | Next_Elmt (Prim); | |
12277 | end loop; | |
12278 | ||
70482933 RK |
12279 | else |
12280 | Eq_Needed := False; | |
12281 | Eq_Name := No_Name; | |
12282 | ||
12283 | Prim := First_Elmt (Primitive_Operations (Tag_Typ)); | |
12284 | while Present (Prim) loop | |
909ce352 | 12285 | if Is_User_Defined_Equality (Node (Prim)) |
70482933 RK |
12286 | and then Is_Internal (Node (Prim)) |
12287 | then | |
12288 | Eq_Needed := True; | |
12289 | Eq_Name := Name_Op_Eq; | |
4ce9a2d8 | 12290 | exit; |
70482933 RK |
12291 | end if; |
12292 | ||
12293 | Next_Elmt (Prim); | |
12294 | end loop; | |
12295 | end if; | |
12296 | ||
5ae5ba7a PT |
12297 | -- If equality is needed, we will have its name |
12298 | ||
12299 | pragma Assert (Eq_Needed = Present (Eq_Name)); | |
12300 | ||
12301 | -- Body for equality | |
12302 | ||
12303 | if Eq_Needed then | |
12304 | Decl := Make_Eq_Body (Tag_Typ, Eq_Name); | |
12305 | Append_To (Predef_List, Decl); | |
12306 | end if; | |
12307 | ||
12308 | -- Body for inequality (if required) | |
12309 | ||
12310 | Decl := Make_Neq_Body (Tag_Typ); | |
12311 | ||
12312 | if Present (Decl) then | |
12313 | Append_To (Predef_List, Decl); | |
12314 | end if; | |
12315 | end Predefined_Primitive_Eq_Body; | |
12316 | ||
12317 | --------------------------------- | |
12318 | -- Predefined_Primitive_Bodies -- | |
12319 | --------------------------------- | |
12320 | ||
12321 | function Predefined_Primitive_Bodies | |
12322 | (Tag_Typ : Entity_Id; | |
12323 | Renamed_Eq : Entity_Id) return List_Id | |
12324 | is | |
12325 | Loc : constant Source_Ptr := Sloc (Tag_Typ); | |
12326 | Res : constant List_Id := New_List; | |
12327 | Adj_Call : Node_Id; | |
12328 | Decl : Node_Id; | |
12329 | Fin_Call : Node_Id; | |
12330 | Ent : Entity_Id; | |
12331 | ||
12332 | pragma Warnings (Off, Ent); | |
12333 | ||
12334 | use Exp_Put_Image; | |
12335 | ||
12336 | begin | |
12337 | pragma Assert (not Is_Interface (Tag_Typ)); | |
12338 | ||
70482933 RK |
12339 | -- Body of _Size |
12340 | ||
12341 | Decl := Predef_Spec_Or_Body (Loc, | |
12342 | Tag_Typ => Tag_Typ, | |
12343 | Name => Name_uSize, | |
12344 | Profile => New_List ( | |
12345 | Make_Parameter_Specification (Loc, | |
12346 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
e4494292 | 12347 | Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), |
70482933 RK |
12348 | |
12349 | Ret_Type => Standard_Long_Long_Integer, | |
12350 | For_Body => True); | |
12351 | ||
12352 | Set_Handled_Statement_Sequence (Decl, | |
12353 | Make_Handled_Sequence_Of_Statements (Loc, New_List ( | |
04df6250 | 12354 | Make_Simple_Return_Statement (Loc, |
70482933 RK |
12355 | Expression => |
12356 | Make_Attribute_Reference (Loc, | |
7675ad4f | 12357 | Prefix => Make_Identifier (Loc, Name_X), |
70482933 RK |
12358 | Attribute_Name => Name_Size))))); |
12359 | ||
12360 | Append_To (Res, Decl); | |
12361 | ||
110d0820 BD |
12362 | -- Body of Put_Image |
12363 | ||
09768159 | 12364 | if No (TSS (Tag_Typ, TSS_Put_Image)) |
8f563162 | 12365 | and then not No_Run_Time_Mode |
09768159 | 12366 | and then RTE_Available (RE_Root_Buffer_Type) |
110d0820 BD |
12367 | then |
12368 | Build_Record_Put_Image_Procedure (Loc, Tag_Typ, Decl, Ent); | |
12369 | Append_To (Res, Decl); | |
12370 | end if; | |
12371 | ||
70482933 RK |
12372 | -- Bodies for Dispatching stream IO routines. We need these only for |
12373 | -- non-limited types (in the limited case there is no dispatching). | |
49d41397 RD |
12374 | -- We also skip them if dispatching or finalization are not available |
12375 | -- or if stream operations are prohibited by restriction No_Streams or | |
12376 | -- from use of pragma/aspect No_Tagged_Streams. | |
70482933 | 12377 | |
d2d3604c TQ |
12378 | if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read) |
12379 | and then No (TSS (Tag_Typ, TSS_Stream_Read)) | |
12380 | then | |
82a205eb | 12381 | Build_Record_Read_Procedure (Tag_Typ, Decl, Ent); |
d2d3604c TQ |
12382 | Append_To (Res, Decl); |
12383 | end if; | |
70482933 | 12384 | |
d2d3604c TQ |
12385 | if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write) |
12386 | and then No (TSS (Tag_Typ, TSS_Stream_Write)) | |
12387 | then | |
82a205eb | 12388 | Build_Record_Write_Procedure (Tag_Typ, Decl, Ent); |
d2d3604c TQ |
12389 | Append_To (Res, Decl); |
12390 | end if; | |
70482933 | 12391 | |
93188a0b GD |
12392 | -- Skip body of _Input for the abstract case, since the corresponding |
12393 | -- spec is abstract (see Predef_Spec_Or_Body). | |
70482933 | 12394 | |
93188a0b GD |
12395 | if not Is_Abstract_Type (Tag_Typ) |
12396 | and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input) | |
12397 | and then No (TSS (Tag_Typ, TSS_Stream_Input)) | |
12398 | then | |
12399 | Build_Record_Or_Elementary_Input_Function | |
82a205eb | 12400 | (Tag_Typ, Decl, Ent); |
93188a0b GD |
12401 | Append_To (Res, Decl); |
12402 | end if; | |
70482933 | 12403 | |
93188a0b GD |
12404 | if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output) |
12405 | and then No (TSS (Tag_Typ, TSS_Stream_Output)) | |
12406 | then | |
82a205eb | 12407 | Build_Record_Or_Elementary_Output_Procedure (Tag_Typ, Decl, Ent); |
93188a0b | 12408 | Append_To (Res, Decl); |
70482933 RK |
12409 | end if; |
12410 | ||
47cc8d6b ES |
12411 | -- Ada 2005: Generate bodies for the following primitive operations for |
12412 | -- limited interfaces and synchronized types that implement a limited | |
12413 | -- interface. | |
f4d379b8 | 12414 | |
10b93b2e HK |
12415 | -- disp_asynchronous_select |
12416 | -- disp_conditional_select | |
12417 | -- disp_get_prim_op_kind | |
f4d379b8 | 12418 | -- disp_get_task_id |
10b93b2e | 12419 | -- disp_timed_select |
f4d379b8 | 12420 | |
47cc8d6b ES |
12421 | -- The interface versions will have null bodies |
12422 | ||
a59626c8 | 12423 | -- Disable the generation of these bodies if Ravenscar or ZFP is active |
4fbad0ba AC |
12424 | |
12425 | -- In VM targets we define these primitives in all root tagged types | |
12426 | -- that are not interface types. Done because in VM targets we don't | |
12427 | -- have secondary dispatch tables and any derivation of Tag_Typ may | |
12428 | -- cover limited interfaces (which always have these primitives since | |
12429 | -- they may be ancestors of synchronized interface types). | |
10b93b2e | 12430 | |
0791fbe9 | 12431 | if Ada_Version >= Ada_2005 |
f4d379b8 | 12432 | and then |
4ce9a2d8 | 12433 | ((Is_Interface (Etype (Tag_Typ)) |
052e0603 | 12434 | and then Is_Limited_Record (Etype (Tag_Typ))) |
4fbad0ba AC |
12435 | or else |
12436 | (Is_Concurrent_Record_Type (Tag_Typ) | |
052e0603 | 12437 | and then Has_Interfaces (Tag_Typ)) |
4fbad0ba AC |
12438 | or else |
12439 | (not Tagged_Type_Expansion | |
12440 | and then Tag_Typ = Root_Type (Tag_Typ))) | |
c09a557e | 12441 | and then not Restriction_Active (No_Select_Statements) |
3edf2f76 | 12442 | and then RTE_Available (RE_Select_Specific_Data) |
10b93b2e | 12443 | then |
f4d379b8 HK |
12444 | Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); |
12445 | Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); | |
12446 | Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ)); | |
12447 | Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ)); | |
4ce9a2d8 | 12448 | Append_To (Res, Make_Disp_Requeue_Body (Tag_Typ)); |
f4d379b8 | 12449 | Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ)); |
10b93b2e HK |
12450 | end if; |
12451 | ||
68880311 | 12452 | if not Is_Limited_Type (Tag_Typ) then |
5ae5ba7a | 12453 | -- Body for equality and inequality |
24d4b3d5 | 12454 | |
5ae5ba7a | 12455 | Predefined_Primitive_Eq_Body (Tag_Typ, Res, Renamed_Eq); |
cd20e505 | 12456 | |
70482933 RK |
12457 | -- Body for dispatching assignment |
12458 | ||
f4d379b8 HK |
12459 | Decl := |
12460 | Predef_Spec_Or_Body (Loc, | |
12461 | Tag_Typ => Tag_Typ, | |
12462 | Name => Name_uAssign, | |
12463 | Profile => New_List ( | |
12464 | Make_Parameter_Specification (Loc, | |
12465 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
12466 | Out_Present => True, | |
e4494292 | 12467 | Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)), |
f4d379b8 HK |
12468 | |
12469 | Make_Parameter_Specification (Loc, | |
12470 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), | |
e4494292 | 12471 | Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), |
f4d379b8 | 12472 | For_Body => True); |
70482933 RK |
12473 | |
12474 | Set_Handled_Statement_Sequence (Decl, | |
12475 | Make_Handled_Sequence_Of_Statements (Loc, New_List ( | |
12476 | Make_Assignment_Statement (Loc, | |
12477 | Name => Make_Identifier (Loc, Name_X), | |
12478 | Expression => Make_Identifier (Loc, Name_Y))))); | |
12479 | ||
12480 | Append_To (Res, Decl); | |
12481 | end if; | |
12482 | ||
df3e68b1 HK |
12483 | -- Generate empty bodies of routines Deep_Adjust and Deep_Finalize for |
12484 | -- tagged types which do not contain controlled components. | |
70482933 | 12485 | |
df3e68b1 | 12486 | -- Do not generate the routines if finalization is disabled |
70482933 | 12487 | |
df3e68b1 | 12488 | if Restriction_Active (No_Finalization) then |
70482933 RK |
12489 | null; |
12490 | ||
df3e68b1 | 12491 | elsif not Has_Controlled_Component (Tag_Typ) then |
70482933 | 12492 | if not Is_Limited_Type (Tag_Typ) then |
2168d7cc AC |
12493 | Adj_Call := Empty; |
12494 | Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True); | |
70482933 RK |
12495 | |
12496 | if Is_Controlled (Tag_Typ) then | |
2168d7cc AC |
12497 | Adj_Call := |
12498 | Make_Adjust_Call ( | |
12499 | Obj_Ref => Make_Identifier (Loc, Name_V), | |
12500 | Typ => Tag_Typ); | |
12501 | end if; | |
24d4b3d5 | 12502 | |
2168d7cc AC |
12503 | if No (Adj_Call) then |
12504 | Adj_Call := Make_Null_Statement (Loc); | |
70482933 RK |
12505 | end if; |
12506 | ||
2168d7cc AC |
12507 | Set_Handled_Statement_Sequence (Decl, |
12508 | Make_Handled_Sequence_Of_Statements (Loc, | |
12509 | Statements => New_List (Adj_Call))); | |
12510 | ||
70482933 RK |
12511 | Append_To (Res, Decl); |
12512 | end if; | |
12513 | ||
2168d7cc AC |
12514 | Fin_Call := Empty; |
12515 | Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True); | |
70482933 RK |
12516 | |
12517 | if Is_Controlled (Tag_Typ) then | |
2168d7cc AC |
12518 | Fin_Call := |
12519 | Make_Final_Call | |
12520 | (Obj_Ref => Make_Identifier (Loc, Name_V), | |
12521 | Typ => Tag_Typ); | |
12522 | end if; | |
24d4b3d5 | 12523 | |
2168d7cc AC |
12524 | if No (Fin_Call) then |
12525 | Fin_Call := Make_Null_Statement (Loc); | |
70482933 RK |
12526 | end if; |
12527 | ||
2168d7cc AC |
12528 | Set_Handled_Statement_Sequence (Decl, |
12529 | Make_Handled_Sequence_Of_Statements (Loc, | |
12530 | Statements => New_List (Fin_Call))); | |
12531 | ||
70482933 RK |
12532 | Append_To (Res, Decl); |
12533 | end if; | |
12534 | ||
12535 | return Res; | |
12536 | end Predefined_Primitive_Bodies; | |
12537 | ||
12538 | --------------------------------- | |
12539 | -- Predefined_Primitive_Freeze -- | |
12540 | --------------------------------- | |
12541 | ||
12542 | function Predefined_Primitive_Freeze | |
fbf5a39b | 12543 | (Tag_Typ : Entity_Id) return List_Id |
70482933 | 12544 | is |
243cae0a | 12545 | Res : constant List_Id := New_List; |
70482933 RK |
12546 | Prim : Elmt_Id; |
12547 | Frnodes : List_Id; | |
12548 | ||
12549 | begin | |
12550 | Prim := First_Elmt (Primitive_Operations (Tag_Typ)); | |
12551 | while Present (Prim) loop | |
47cc8d6b | 12552 | if Is_Predefined_Dispatching_Operation (Node (Prim)) then |
c159409f | 12553 | Frnodes := Freeze_Entity (Node (Prim), Tag_Typ); |
70482933 RK |
12554 | |
12555 | if Present (Frnodes) then | |
12556 | Append_List_To (Res, Frnodes); | |
12557 | end if; | |
12558 | end if; | |
12559 | ||
12560 | Next_Elmt (Prim); | |
12561 | end loop; | |
12562 | ||
12563 | return Res; | |
12564 | end Predefined_Primitive_Freeze; | |
a778d033 | 12565 | |
d2d3604c TQ |
12566 | ------------------------- |
12567 | -- Stream_Operation_OK -- | |
12568 | ------------------------- | |
12569 | ||
12570 | function Stream_Operation_OK | |
12571 | (Typ : Entity_Id; | |
12572 | Operation : TSS_Name_Type) return Boolean | |
12573 | is | |
19590d70 | 12574 | Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False; |
a778d033 | 12575 | |
a778d033 | 12576 | begin |
19590d70 GD |
12577 | -- Special case of a limited type extension: a default implementation |
12578 | -- of the stream attributes Read or Write exists if that attribute | |
12579 | -- has been specified or is available for an ancestor type; a default | |
12580 | -- implementation of the attribute Output (resp. Input) exists if the | |
12581 | -- attribute has been specified or Write (resp. Read) is available for | |
12582 | -- an ancestor type. The last condition only applies under Ada 2005. | |
12583 | ||
ee4eee0a | 12584 | if Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ) then |
19590d70 GD |
12585 | if Operation = TSS_Stream_Read then |
12586 | Has_Predefined_Or_Specified_Stream_Attribute := | |
12587 | Has_Specified_Stream_Read (Typ); | |
12588 | ||
12589 | elsif Operation = TSS_Stream_Write then | |
12590 | Has_Predefined_Or_Specified_Stream_Attribute := | |
12591 | Has_Specified_Stream_Write (Typ); | |
12592 | ||
12593 | elsif Operation = TSS_Stream_Input then | |
12594 | Has_Predefined_Or_Specified_Stream_Attribute := | |
12595 | Has_Specified_Stream_Input (Typ) | |
12596 | or else | |
0791fbe9 | 12597 | (Ada_Version >= Ada_2005 |
19590d70 GD |
12598 | and then Stream_Operation_OK (Typ, TSS_Stream_Read)); |
12599 | ||
12600 | elsif Operation = TSS_Stream_Output then | |
12601 | Has_Predefined_Or_Specified_Stream_Attribute := | |
12602 | Has_Specified_Stream_Output (Typ) | |
12603 | or else | |
0791fbe9 | 12604 | (Ada_Version >= Ada_2005 |
19590d70 GD |
12605 | and then Stream_Operation_OK (Typ, TSS_Stream_Write)); |
12606 | end if; | |
12607 | ||
12608 | -- Case of inherited TSS_Stream_Read or TSS_Stream_Write | |
d2d3604c | 12609 | |
19590d70 GD |
12610 | if not Has_Predefined_Or_Specified_Stream_Attribute |
12611 | and then Is_Derived_Type (Typ) | |
12612 | and then (Operation = TSS_Stream_Read | |
12613 | or else Operation = TSS_Stream_Write) | |
12614 | then | |
12615 | Has_Predefined_Or_Specified_Stream_Attribute := | |
12616 | Present | |
12617 | (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation)); | |
12618 | end if; | |
d2d3604c TQ |
12619 | end if; |
12620 | ||
93188a0b GD |
12621 | -- If the type is not limited, or else is limited but the attribute is |
12622 | -- explicitly specified or is predefined for the type, then return True, | |
12623 | -- unless other conditions prevail, such as restrictions prohibiting | |
ac72c9c5 AC |
12624 | -- streams or dispatching operations. We also return True for limited |
12625 | -- interfaces, because they may be extended by nonlimited types and | |
12626 | -- permit inheritance in this case (addresses cases where an abstract | |
12627 | -- extension doesn't get 'Input declared, as per comments below, but | |
12628 | -- 'Class'Input must still be allowed). Note that attempts to apply | |
12629 | -- stream attributes to a limited interface or its class-wide type | |
12630 | -- (or limited extensions thereof) will still get properly rejected | |
12631 | -- by Check_Stream_Attribute. | |
93188a0b GD |
12632 | |
12633 | -- We exclude the Input operation from being a predefined subprogram in | |
12634 | -- the case where the associated type is an abstract extension, because | |
12635 | -- the attribute is not callable in that case, per 13.13.2(49/2). Also, | |
12636 | -- we don't want an abstract version created because types derived from | |
12637 | -- the abstract type may not even have Input available (for example if | |
12638 | -- derived from a private view of the abstract type that doesn't have | |
57d3adcd | 12639 | -- a visible Input). |
93188a0b | 12640 | |
d3f70b35 AC |
12641 | -- Do not generate stream routines for type Finalization_Master because |
12642 | -- a master may never appear in types and therefore cannot be read or | |
12643 | -- written. | |
df3e68b1 HK |
12644 | |
12645 | return | |
12646 | (not Is_Limited_Type (Typ) | |
12647 | or else Is_Interface (Typ) | |
12648 | or else Has_Predefined_Or_Specified_Stream_Attribute) | |
12649 | and then | |
12650 | (Operation /= TSS_Stream_Input | |
12651 | or else not Is_Abstract_Type (Typ) | |
12652 | or else not Is_Derived_Type (Typ)) | |
19590d70 | 12653 | and then not Has_Unknown_Discriminants (Typ) |
6cf7cc8c | 12654 | and then not Is_Concurrent_Interface (Typ) |
19590d70 GD |
12655 | and then not Restriction_Active (No_Streams) |
12656 | and then not Restriction_Active (No_Dispatch) | |
49d41397 | 12657 | and then No (No_Tagged_Streams_Pragma (Typ)) |
19590d70 GD |
12658 | and then not No_Run_Time_Mode |
12659 | and then RTE_Available (RE_Tag) | |
276e7ed0 | 12660 | and then No (Type_Without_Stream_Operation (Typ)) |
df3e68b1 | 12661 | and then RTE_Available (RE_Root_Stream_Type) |
d3f70b35 | 12662 | and then not Is_RTE (Typ, RE_Finalization_Master); |
d2d3604c | 12663 | end Stream_Operation_OK; |
19590d70 | 12664 | |
70482933 | 12665 | end Exp_Ch3; |