]>
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 | -- -- | |
f2cbd970 | 9 | -- Copyright (C) 1992-2008, 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 | ||
26 | with Atree; use Atree; | |
27 | with Checks; use Checks; | |
28 | with Einfo; use Einfo; | |
07fc65c4 | 29 | with Errout; use Errout; |
70482933 | 30 | with Exp_Aggr; use Exp_Aggr; |
ea1941af | 31 | with Exp_Atag; use Exp_Atag; |
70482933 | 32 | with Exp_Ch4; use Exp_Ch4; |
3476f949 | 33 | with Exp_Ch6; use Exp_Ch6; |
70482933 RK |
34 | with Exp_Ch7; use Exp_Ch7; |
35 | with Exp_Ch9; use Exp_Ch9; | |
36 | with Exp_Ch11; use Exp_Ch11; | |
37 | with Exp_Disp; use Exp_Disp; | |
38 | with Exp_Dist; use Exp_Dist; | |
39 | with Exp_Smem; use Exp_Smem; | |
40 | with Exp_Strm; use Exp_Strm; | |
41 | with Exp_Tss; use Exp_Tss; | |
42 | with Exp_Util; use Exp_Util; | |
43 | with Freeze; use Freeze; | |
70482933 | 44 | with Nlists; use Nlists; |
47cc8d6b | 45 | with Namet; use Namet; |
70482933 RK |
46 | with Nmake; use Nmake; |
47 | with Opt; use Opt; | |
48 | with Restrict; use Restrict; | |
6e937c1c | 49 | with Rident; use Rident; |
70482933 RK |
50 | with Rtsfind; use Rtsfind; |
51 | with Sem; use Sem; | |
758c442c | 52 | with Sem_Attr; use Sem_Attr; |
3476f949 | 53 | with Sem_Cat; use Sem_Cat; |
70482933 RK |
54 | with Sem_Ch3; use Sem_Ch3; |
55 | with Sem_Ch8; use Sem_Ch8; | |
a05e99a2 | 56 | with Sem_Disp; use Sem_Disp; |
70482933 RK |
57 | with Sem_Eval; use Sem_Eval; |
58 | with Sem_Mech; use Sem_Mech; | |
59 | with Sem_Res; use Sem_Res; | |
ce2b6ba5 | 60 | with Sem_Type; use Sem_Type; |
70482933 RK |
61 | with Sem_Util; use Sem_Util; |
62 | with Sinfo; use Sinfo; | |
63 | with Stand; use Stand; | |
64 | with Snames; use Snames; | |
47cc8d6b | 65 | with Targparm; use Targparm; |
70482933 RK |
66 | with Tbuild; use Tbuild; |
67 | with Ttypes; use Ttypes; | |
70482933 RK |
68 | with Validsw; use Validsw; |
69 | ||
70 | package body Exp_Ch3 is | |
71 | ||
72 | ----------------------- | |
73 | -- Local Subprograms -- | |
74 | ----------------------- | |
75 | ||
04df6250 TQ |
76 | function Add_Final_Chain (Def_Id : Entity_Id) return Entity_Id; |
77 | -- Add the declaration of a finalization list to the freeze actions for | |
78 | -- Def_Id, and return its defining identifier. | |
79 | ||
70482933 RK |
80 | procedure Adjust_Discriminants (Rtype : Entity_Id); |
81 | -- This is used when freezing a record type. It attempts to construct | |
82 | -- more restrictive subtypes for discriminants so that the max size of | |
83 | -- the record can be calculated more accurately. See the body of this | |
84 | -- procedure for details. | |
85 | ||
86 | procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id); | |
87 | -- Build initialization procedure for given array type. Nod is a node | |
88 | -- used for attachment of any actions required in its construction. | |
89 | -- It also supplies the source location used for the procedure. | |
90 | ||
70482933 RK |
91 | function Build_Discriminant_Formals |
92 | (Rec_Id : Entity_Id; | |
2e071734 | 93 | Use_Dl : Boolean) return List_Id; |
70482933 RK |
94 | -- This function uses the discriminants of a type to build a list of |
95 | -- formal parameters, used in the following function. If the flag Use_Dl | |
96 | -- is set, the list is built using the already defined discriminals | |
97 | -- of the type. Otherwise new identifiers are created, with the source | |
98 | -- names of the discriminants. | |
99 | ||
47cc8d6b ES |
100 | function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id; |
101 | -- This function builds a static aggregate that can serve as the initial | |
102 | -- value for an array type whose bounds are static, and whose component | |
103 | -- type is a composite type that has a static equivalent aggregate. | |
104 | -- The equivalent array aggregate is used both for object initialization | |
105 | -- and for component initialization, when used in the following function. | |
106 | ||
107 | function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id; | |
108 | -- This function builds a static aggregate that can serve as the initial | |
109 | -- value for a record type whose components are scalar and initialized | |
04df6250 | 110 | -- with compile-time values, or arrays with similar initialization or |
47cc8d6b ES |
111 | -- defaults. When possible, initialization of an object of the type can |
112 | -- be achieved by using a copy of the aggregate as an initial value, thus | |
113 | -- removing the implicit call that would otherwise constitute elaboration | |
114 | -- code. | |
115 | ||
ea1941af ES |
116 | function Build_Master_Renaming |
117 | (N : Node_Id; | |
118 | T : Entity_Id) return Entity_Id; | |
119 | -- If the designated type of an access type is a task type or contains | |
120 | -- tasks, we make sure that a _Master variable is declared in the current | |
121 | -- scope, and then declare a renaming for it: | |
122 | -- | |
123 | -- atypeM : Master_Id renames _Master; | |
124 | -- | |
125 | -- where atyp is the name of the access type. This declaration is used when | |
126 | -- an allocator for the access type is expanded. The node is the full | |
127 | -- declaration of the designated type that contains tasks. The renaming | |
128 | -- declaration is inserted before N, and after the Master declaration. | |
129 | ||
70482933 RK |
130 | procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id); |
131 | -- Build record initialization procedure. N is the type declaration | |
132 | -- node, and Pe is the corresponding entity for the record type. | |
133 | ||
26fd4eae AC |
134 | procedure Build_Slice_Assignment (Typ : Entity_Id); |
135 | -- Build assignment procedure for one-dimensional arrays of controlled | |
136 | -- types. Other array and slice assignments are expanded in-line, but | |
137 | -- the code expansion for controlled components (when control actions | |
138 | -- are active) can lead to very large blocks that GCC3 handles poorly. | |
139 | ||
70482933 RK |
140 | procedure Build_Variant_Record_Equality (Typ : Entity_Id); |
141 | -- Create An Equality function for the non-tagged variant record 'Typ' | |
142 | -- and attach it to the TSS list | |
143 | ||
07fc65c4 | 144 | procedure Check_Stream_Attributes (Typ : Entity_Id); |
47cc8d6b ES |
145 | -- Check that if a limited extension has a parent with user-defined stream |
146 | -- attributes, and does not itself have user-defined stream-attributes, | |
147 | -- then any limited component of the extension also has the corresponding | |
148 | -- user-defined stream attributes. | |
07fc65c4 | 149 | |
3476f949 JM |
150 | procedure Clean_Task_Names |
151 | (Typ : Entity_Id; | |
152 | Proc_Id : Entity_Id); | |
153 | -- If an initialization procedure includes calls to generate names | |
154 | -- for task subcomponents, indicate that secondary stack cleanup is | |
155 | -- needed after an initialization. Typ is the component type, and Proc_Id | |
156 | -- the initialization procedure for the enclosing composite type. | |
157 | ||
70482933 RK |
158 | procedure Expand_Tagged_Root (T : Entity_Id); |
159 | -- Add a field _Tag at the beginning of the record. This field carries | |
160 | -- the value of the access to the Dispatch table. This procedure is only | |
3476f949 | 161 | -- called on root type, the _Tag field being inherited by the descendants. |
70482933 RK |
162 | |
163 | procedure Expand_Record_Controller (T : Entity_Id); | |
fbf5a39b AC |
164 | -- T must be a record type that Has_Controlled_Component. Add a field |
165 | -- _controller of type Record_Controller or Limited_Record_Controller | |
166 | -- in the record T. | |
70482933 RK |
167 | |
168 | procedure Freeze_Array_Type (N : Node_Id); | |
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 | ||
174 | procedure Freeze_Enumeration_Type (N : Node_Id); | |
175 | -- Freeze enumeration type with non-standard representation. Builds the | |
176 | -- array and function needed to convert between enumeration pos and | |
177 | -- enumeration representation values. N is the N_Freeze_Entity node | |
178 | -- for the type. | |
179 | ||
180 | procedure Freeze_Record_Type (N : Node_Id); | |
181 | -- Freeze record type. Builds all necessary discriminant checking | |
182 | -- and other ancillary functions, and builds dispatch tables where | |
183 | -- needed. The argument N is the N_Freeze_Entity node. This processing | |
184 | -- applies only to E_Record_Type entities, not to class wide types, | |
185 | -- record subtypes, or private types. | |
186 | ||
07fc65c4 GB |
187 | procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id); |
188 | -- Treat user-defined stream operations as renaming_as_body if the | |
189 | -- subprogram they rename is not frozen when the type is frozen. | |
190 | ||
47cc8d6b ES |
191 | procedure Initialization_Warning (E : Entity_Id); |
192 | -- If static elaboration of the package is requested, indicate | |
193 | -- when a type does meet the conditions for static initialization. If | |
194 | -- E is a type, it has components that have no static initialization. | |
195 | -- if E is an entity, its initial expression is not compile-time known. | |
196 | ||
70482933 RK |
197 | function Init_Formals (Typ : Entity_Id) return List_Id; |
198 | -- This function builds the list of formals for an initialization routine. | |
199 | -- The first formal is always _Init with the given type. For task value | |
200 | -- record types and types containing tasks, three additional formals are | |
201 | -- added: | |
202 | -- | |
fbf5a39b AC |
203 | -- _Master : Master_Id |
204 | -- _Chain : in out Activation_Chain | |
205 | -- _Task_Name : String | |
70482933 RK |
206 | -- |
207 | -- The caller must append additional entries for discriminants if required. | |
208 | ||
209 | function In_Runtime (E : Entity_Id) return Boolean; | |
210 | -- Check if E is defined in the RTL (in a child of Ada or System). Used | |
211 | -- to avoid to bring in the overhead of _Input, _Output for tagged types. | |
212 | ||
04df6250 TQ |
213 | function Is_Variable_Size_Record (E : Entity_Id) return Boolean; |
214 | -- Returns true if E has variable size components | |
215 | ||
5d09245e AC |
216 | function Make_Eq_Case |
217 | (E : Entity_Id; | |
218 | CL : Node_Id; | |
219 | Discr : Entity_Id := Empty) return List_Id; | |
47cc8d6b ES |
220 | -- Building block for variant record equality. Defined to share the code |
221 | -- between the tagged and non-tagged case. Given a Component_List node CL, | |
222 | -- it generates an 'if' followed by a 'case' statement that compares all | |
223 | -- components of local temporaries named X and Y (that are declared as | |
224 | -- formals at some upper level). E provides the Sloc to be used for the | |
225 | -- generated code. Discr is used as the case statement switch in the case | |
226 | -- of Unchecked_Union equality. | |
70482933 | 227 | |
5d09245e AC |
228 | function Make_Eq_If |
229 | (E : Entity_Id; | |
230 | L : List_Id) return Node_Id; | |
47cc8d6b ES |
231 | -- Building block for variant record equality. Defined to share the code |
232 | -- between the tagged and non-tagged case. Given the list of components | |
233 | -- (or discriminants) L, it generates a return statement that compares all | |
234 | -- components of local temporaries named X and Y (that are declared as | |
235 | -- formals at some upper level). E provides the Sloc to be used for the | |
236 | -- generated code. | |
70482933 RK |
237 | |
238 | procedure Make_Predefined_Primitive_Specs | |
239 | (Tag_Typ : Entity_Id; | |
240 | Predef_List : out List_Id; | |
4ce9a2d8 | 241 | Renamed_Eq : out Entity_Id); |
70482933 | 242 | -- Create a list with the specs of the predefined primitive operations. |
4ce9a2d8 HK |
243 | -- For tagged types that are interfaces all these primitives are defined |
244 | -- abstract. | |
245 | -- | |
fbf5a39b AC |
246 | -- The following entries are present for all tagged types, and provide |
247 | -- the results of the corresponding attribute applied to the object. | |
248 | -- Dispatching is required in general, since the result of the attribute | |
249 | -- will vary with the actual object subtype. | |
250 | -- | |
251 | -- _alignment provides result of 'Alignment attribute | |
252 | -- _size provides result of 'Size attribute | |
253 | -- typSR provides result of 'Read attribute | |
254 | -- typSW provides result of 'Write attribute | |
255 | -- typSI provides result of 'Input attribute | |
256 | -- typSO provides result of 'Output attribute | |
257 | -- | |
47cc8d6b ES |
258 | -- The following entries are additionally present for non-limited tagged |
259 | -- types, and implement additional dispatching operations for predefined | |
260 | -- operations: | |
fbf5a39b AC |
261 | -- |
262 | -- _equality implements "=" operator | |
263 | -- _assign implements assignment operation | |
264 | -- typDF implements deep finalization | |
47cc8d6b | 265 | -- typDA implements deep adjust |
fbf5a39b AC |
266 | -- |
267 | -- The latter two are empty procedures unless the type contains some | |
268 | -- controlled components that require finalization actions (the deep | |
269 | -- in the name refers to the fact that the action applies to components). | |
270 | -- | |
47cc8d6b ES |
271 | -- The list is returned in Predef_List. The Parameter Renamed_Eq either |
272 | -- returns the value Empty, or else the defining unit name for the | |
273 | -- predefined equality function in the case where the type has a primitive | |
274 | -- operation that is a renaming of predefined equality (but only if there | |
275 | -- is also an overriding user-defined equality function). The returned | |
276 | -- Renamed_Eq will be passed to the corresponding parameter of | |
277 | -- Predefined_Primitive_Bodies. | |
70482933 RK |
278 | |
279 | function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean; | |
47cc8d6b ES |
280 | -- returns True if there are representation clauses for type T that are not |
281 | -- inherited. If the result is false, the init_proc and the discriminant | |
282 | -- checking functions of the parent can be reused by a derived type. | |
70482933 | 283 | |
a05e99a2 JM |
284 | procedure Make_Controlling_Function_Wrappers |
285 | (Tag_Typ : Entity_Id; | |
286 | Decl_List : out List_Id; | |
287 | Body_List : out List_Id); | |
288 | -- Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions | |
289 | -- associated with inherited functions with controlling results which | |
290 | -- are not overridden. The body of each wrapper function consists solely | |
291 | -- of a return statement whose expression is an extension aggregate | |
292 | -- invoking the inherited subprogram's parent subprogram and extended | |
293 | -- with a null association list. | |
294 | ||
3476f949 JM |
295 | procedure Make_Null_Procedure_Specs |
296 | (Tag_Typ : Entity_Id; | |
297 | Decl_List : out List_Id); | |
298 | -- Ada 2005 (AI-251): Makes specs for null procedures associated with any | |
299 | -- null procedures inherited from an interface type that have not been | |
300 | -- overridden. Only one null procedure will be created for a given set of | |
301 | -- inherited null procedures with homographic profiles. | |
302 | ||
70482933 RK |
303 | function Predef_Spec_Or_Body |
304 | (Loc : Source_Ptr; | |
305 | Tag_Typ : Entity_Id; | |
306 | Name : Name_Id; | |
307 | Profile : List_Id; | |
308 | Ret_Type : Entity_Id := Empty; | |
2e071734 | 309 | For_Body : Boolean := False) return Node_Id; |
70482933 RK |
310 | -- This function generates the appropriate expansion for a predefined |
311 | -- primitive operation specified by its name, parameter profile and | |
312 | -- return type (Empty means this is a procedure). If For_Body is false, | |
313 | -- then the returned node is a subprogram declaration. If For_Body is | |
314 | -- true, then the returned node is a empty subprogram body containing | |
315 | -- no declarations and no statements. | |
316 | ||
317 | function Predef_Stream_Attr_Spec | |
318 | (Loc : Source_Ptr; | |
319 | Tag_Typ : Entity_Id; | |
fbf5a39b | 320 | Name : TSS_Name_Type; |
2e071734 | 321 | For_Body : Boolean := False) return Node_Id; |
fbf5a39b AC |
322 | -- Specialized version of Predef_Spec_Or_Body that apply to read, write, |
323 | -- input and output attribute whose specs are constructed in Exp_Strm. | |
70482933 RK |
324 | |
325 | function Predef_Deep_Spec | |
326 | (Loc : Source_Ptr; | |
327 | Tag_Typ : Entity_Id; | |
fbf5a39b | 328 | Name : TSS_Name_Type; |
2e071734 | 329 | For_Body : Boolean := False) return Node_Id; |
70482933 RK |
330 | -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust |
331 | -- and _deep_finalize | |
332 | ||
333 | function Predefined_Primitive_Bodies | |
334 | (Tag_Typ : Entity_Id; | |
4ce9a2d8 | 335 | Renamed_Eq : Entity_Id) return List_Id; |
70482933 RK |
336 | -- Create the bodies of the predefined primitives that are described in |
337 | -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote | |
338 | -- the defining unit name of the type's predefined equality as returned | |
339 | -- by Make_Predefined_Primitive_Specs. | |
340 | ||
341 | function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id; | |
342 | -- Freeze entities of all predefined primitive operations. This is needed | |
47cc8d6b | 343 | -- because the bodies of these operations do not normally do any freezing. |
70482933 | 344 | |
d2d3604c TQ |
345 | function Stream_Operation_OK |
346 | (Typ : Entity_Id; | |
347 | Operation : TSS_Name_Type) return Boolean; | |
348 | -- Check whether the named stream operation must be emitted for a given | |
349 | -- type. The rules for inheritance of stream attributes by type extensions | |
350 | -- are enforced by this function. Furthermore, various restrictions prevent | |
351 | -- the generation of these operations, as a useful optimization or for | |
352 | -- certification purposes. | |
a778d033 | 353 | |
04df6250 TQ |
354 | --------------------- |
355 | -- Add_Final_Chain -- | |
356 | --------------------- | |
357 | ||
358 | function Add_Final_Chain (Def_Id : Entity_Id) return Entity_Id is | |
359 | Loc : constant Source_Ptr := Sloc (Def_Id); | |
360 | Flist : Entity_Id; | |
361 | ||
362 | begin | |
363 | Flist := | |
364 | Make_Defining_Identifier (Loc, | |
365 | New_External_Name (Chars (Def_Id), 'L')); | |
366 | ||
367 | Append_Freeze_Action (Def_Id, | |
368 | Make_Object_Declaration (Loc, | |
369 | Defining_Identifier => Flist, | |
370 | Object_Definition => | |
371 | New_Reference_To (RTE (RE_List_Controller), Loc))); | |
372 | ||
373 | return Flist; | |
374 | end Add_Final_Chain; | |
375 | ||
70482933 RK |
376 | -------------------------- |
377 | -- Adjust_Discriminants -- | |
378 | -------------------------- | |
379 | ||
47cc8d6b ES |
380 | -- This procedure attempts to define subtypes for discriminants that are |
381 | -- more restrictive than those declared. Such a replacement is possible if | |
382 | -- we can demonstrate that values outside the restricted range would cause | |
383 | -- constraint errors in any case. The advantage of restricting the | |
384 | -- discriminant types in this way is that the maximum size of the variant | |
385 | -- record can be calculated more conservatively. | |
70482933 RK |
386 | |
387 | -- An example of a situation in which we can perform this type of | |
388 | -- restriction is the following: | |
389 | ||
390 | -- subtype B is range 1 .. 10; | |
391 | -- type Q is array (B range <>) of Integer; | |
392 | ||
393 | -- type V (N : Natural) is record | |
394 | -- C : Q (1 .. N); | |
395 | -- end record; | |
396 | ||
397 | -- In this situation, we can restrict the upper bound of N to 10, since | |
398 | -- any larger value would cause a constraint error in any case. | |
399 | ||
400 | -- There are many situations in which such restriction is possible, but | |
401 | -- for now, we just look for cases like the above, where the component | |
402 | -- in question is a one dimensional array whose upper bound is one of | |
403 | -- the record discriminants. Also the component must not be part of | |
404 | -- any variant part, since then the component does not always exist. | |
405 | ||
406 | procedure Adjust_Discriminants (Rtype : Entity_Id) is | |
407 | Loc : constant Source_Ptr := Sloc (Rtype); | |
408 | Comp : Entity_Id; | |
409 | Ctyp : Entity_Id; | |
410 | Ityp : Entity_Id; | |
411 | Lo : Node_Id; | |
412 | Hi : Node_Id; | |
413 | P : Node_Id; | |
414 | Loval : Uint; | |
415 | Discr : Entity_Id; | |
416 | Dtyp : Entity_Id; | |
417 | Dhi : Node_Id; | |
418 | Dhiv : Uint; | |
419 | Ahi : Node_Id; | |
420 | Ahiv : Uint; | |
421 | Tnn : Entity_Id; | |
422 | ||
423 | begin | |
424 | Comp := First_Component (Rtype); | |
425 | while Present (Comp) loop | |
426 | ||
427 | -- If our parent is a variant, quit, we do not look at components | |
428 | -- that are in variant parts, because they may not always exist. | |
429 | ||
430 | P := Parent (Comp); -- component declaration | |
431 | P := Parent (P); -- component list | |
432 | ||
433 | exit when Nkind (Parent (P)) = N_Variant; | |
434 | ||
435 | -- We are looking for a one dimensional array type | |
436 | ||
437 | Ctyp := Etype (Comp); | |
438 | ||
439 | if not Is_Array_Type (Ctyp) | |
440 | or else Number_Dimensions (Ctyp) > 1 | |
441 | then | |
442 | goto Continue; | |
443 | end if; | |
444 | ||
445 | -- The lower bound must be constant, and the upper bound is a | |
446 | -- discriminant (which is a discriminant of the current record). | |
447 | ||
448 | Ityp := Etype (First_Index (Ctyp)); | |
449 | Lo := Type_Low_Bound (Ityp); | |
450 | Hi := Type_High_Bound (Ityp); | |
451 | ||
452 | if not Compile_Time_Known_Value (Lo) | |
453 | or else Nkind (Hi) /= N_Identifier | |
454 | or else No (Entity (Hi)) | |
455 | or else Ekind (Entity (Hi)) /= E_Discriminant | |
456 | then | |
457 | goto Continue; | |
458 | end if; | |
459 | ||
460 | -- We have an array with appropriate bounds | |
461 | ||
462 | Loval := Expr_Value (Lo); | |
463 | Discr := Entity (Hi); | |
464 | Dtyp := Etype (Discr); | |
465 | ||
466 | -- See if the discriminant has a known upper bound | |
467 | ||
468 | Dhi := Type_High_Bound (Dtyp); | |
469 | ||
470 | if not Compile_Time_Known_Value (Dhi) then | |
471 | goto Continue; | |
472 | end if; | |
473 | ||
474 | Dhiv := Expr_Value (Dhi); | |
475 | ||
476 | -- See if base type of component array has known upper bound | |
477 | ||
478 | Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp)))); | |
479 | ||
480 | if not Compile_Time_Known_Value (Ahi) then | |
481 | goto Continue; | |
482 | end if; | |
483 | ||
484 | Ahiv := Expr_Value (Ahi); | |
485 | ||
486 | -- The condition for doing the restriction is that the high bound | |
487 | -- of the discriminant is greater than the low bound of the array, | |
488 | -- and is also greater than the high bound of the base type index. | |
489 | ||
490 | if Dhiv > Loval and then Dhiv > Ahiv then | |
491 | ||
492 | -- We can reset the upper bound of the discriminant type to | |
493 | -- whichever is larger, the low bound of the component, or | |
494 | -- the high bound of the base type array index. | |
495 | ||
496 | -- We build a subtype that is declared as | |
497 | ||
498 | -- subtype Tnn is discr_type range discr_type'First .. max; | |
499 | ||
500 | -- And insert this declaration into the tree. The type of the | |
501 | -- discriminant is then reset to this more restricted subtype. | |
502 | ||
503 | Tnn := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); | |
504 | ||
505 | Insert_Action (Declaration_Node (Rtype), | |
506 | Make_Subtype_Declaration (Loc, | |
507 | Defining_Identifier => Tnn, | |
508 | Subtype_Indication => | |
509 | Make_Subtype_Indication (Loc, | |
510 | Subtype_Mark => New_Occurrence_Of (Dtyp, Loc), | |
511 | Constraint => | |
512 | Make_Range_Constraint (Loc, | |
513 | Range_Expression => | |
514 | Make_Range (Loc, | |
515 | Low_Bound => | |
516 | Make_Attribute_Reference (Loc, | |
517 | Attribute_Name => Name_First, | |
518 | Prefix => New_Occurrence_Of (Dtyp, Loc)), | |
519 | High_Bound => | |
520 | Make_Integer_Literal (Loc, | |
521 | Intval => UI_Max (Loval, Ahiv))))))); | |
522 | ||
523 | Set_Etype (Discr, Tnn); | |
524 | end if; | |
525 | ||
526 | <<Continue>> | |
527 | Next_Component (Comp); | |
528 | end loop; | |
70482933 RK |
529 | end Adjust_Discriminants; |
530 | ||
531 | --------------------------- | |
532 | -- Build_Array_Init_Proc -- | |
533 | --------------------------- | |
534 | ||
535 | procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is | |
c5ecf679 GD |
536 | Loc : constant Source_Ptr := Sloc (Nod); |
537 | Comp_Type : constant Entity_Id := Component_Type (A_Type); | |
538 | Index_List : List_Id; | |
539 | Proc_Id : Entity_Id; | |
540 | Body_Stmts : List_Id; | |
541 | Has_Default_Init : Boolean; | |
70482933 RK |
542 | |
543 | function Init_Component return List_Id; | |
544 | -- Create one statement to initialize one array component, designated | |
545 | -- by a full set of indices. | |
546 | ||
547 | function Init_One_Dimension (N : Int) return List_Id; | |
548 | -- Create loop to initialize one dimension of the array. The single | |
549 | -- statement in the loop body initializes the inner dimensions if any, | |
550 | -- or else the single component. Note that this procedure is called | |
551 | -- recursively, with N being the dimension to be initialized. A call | |
552 | -- with N greater than the number of dimensions simply generates the | |
553 | -- component initialization, terminating the recursion. | |
554 | ||
555 | -------------------- | |
556 | -- Init_Component -- | |
557 | -------------------- | |
558 | ||
559 | function Init_Component return List_Id is | |
560 | Comp : Node_Id; | |
561 | ||
562 | begin | |
563 | Comp := | |
564 | Make_Indexed_Component (Loc, | |
565 | Prefix => Make_Identifier (Loc, Name_uInit), | |
566 | Expressions => Index_List); | |
567 | ||
568 | if Needs_Simple_Initialization (Comp_Type) then | |
569 | Set_Assignment_OK (Comp); | |
570 | return New_List ( | |
571 | Make_Assignment_Statement (Loc, | |
572 | Name => Comp, | |
82c80734 RD |
573 | Expression => |
574 | Get_Simple_Init_Val | |
f2cbd970 | 575 | (Comp_Type, Nod, Component_Size (A_Type)))); |
70482933 RK |
576 | |
577 | else | |
3476f949 | 578 | Clean_Task_Names (Comp_Type, Proc_Id); |
70482933 | 579 | return |
ea1941af ES |
580 | Build_Initialization_Call |
581 | (Loc, Comp, Comp_Type, | |
582 | In_Init_Proc => True, | |
583 | Enclos_Type => A_Type); | |
70482933 RK |
584 | end if; |
585 | end Init_Component; | |
586 | ||
587 | ------------------------ | |
588 | -- Init_One_Dimension -- | |
589 | ------------------------ | |
590 | ||
591 | function Init_One_Dimension (N : Int) return List_Id is | |
592 | Index : Entity_Id; | |
593 | ||
594 | begin | |
595 | -- If the component does not need initializing, then there is nothing | |
596 | -- to do here, so we return a null body. This occurs when generating | |
597 | -- the dummy Init_Proc needed for Initialize_Scalars processing. | |
598 | ||
599 | if not Has_Non_Null_Base_Init_Proc (Comp_Type) | |
600 | and then not Needs_Simple_Initialization (Comp_Type) | |
601 | and then not Has_Task (Comp_Type) | |
602 | then | |
603 | return New_List (Make_Null_Statement (Loc)); | |
604 | ||
605 | -- If all dimensions dealt with, we simply initialize the component | |
606 | ||
607 | elsif N > Number_Dimensions (A_Type) then | |
608 | return Init_Component; | |
609 | ||
610 | -- Here we generate the required loop | |
611 | ||
612 | else | |
613 | Index := | |
614 | Make_Defining_Identifier (Loc, New_External_Name ('J', N)); | |
615 | ||
616 | Append (New_Reference_To (Index, Loc), Index_List); | |
617 | ||
618 | return New_List ( | |
619 | Make_Implicit_Loop_Statement (Nod, | |
620 | Identifier => Empty, | |
621 | Iteration_Scheme => | |
622 | Make_Iteration_Scheme (Loc, | |
623 | Loop_Parameter_Specification => | |
624 | Make_Loop_Parameter_Specification (Loc, | |
625 | Defining_Identifier => Index, | |
626 | Discrete_Subtype_Definition => | |
627 | Make_Attribute_Reference (Loc, | |
628 | Prefix => Make_Identifier (Loc, Name_uInit), | |
629 | Attribute_Name => Name_Range, | |
630 | Expressions => New_List ( | |
631 | Make_Integer_Literal (Loc, N))))), | |
632 | Statements => Init_One_Dimension (N + 1))); | |
633 | end if; | |
634 | end Init_One_Dimension; | |
635 | ||
636 | -- Start of processing for Build_Array_Init_Proc | |
637 | ||
638 | begin | |
ae7adb1b ES |
639 | -- Nothing to generate in the following cases: |
640 | ||
641 | -- 1. Initialization is suppressed for the type | |
642 | -- 2. The type is a value type, in the CIL sense. | |
643 | -- 3. An initialization already exists for the base type | |
644 | ||
645 | if Suppress_Init_Proc (A_Type) | |
646 | or else Is_Value_Type (Comp_Type) | |
647 | or else Present (Base_Init_Proc (A_Type)) | |
648 | then | |
70482933 RK |
649 | return; |
650 | end if; | |
651 | ||
652 | Index_List := New_List; | |
653 | ||
654 | -- We need an initialization procedure if any of the following is true: | |
655 | ||
656 | -- 1. The component type has an initialization procedure | |
657 | -- 2. The component type needs simple initialization | |
658 | -- 3. Tasks are present | |
47cc8d6b | 659 | -- 4. The type is marked as a public entity |
70482933 RK |
660 | |
661 | -- The reason for the public entity test is to deal properly with the | |
662 | -- Initialize_Scalars pragma. This pragma can be set in the client and | |
663 | -- not in the declaring package, this means the client will make a call | |
664 | -- to the initialization procedure (because one of conditions 1-3 must | |
665 | -- apply in this case), and we must generate a procedure (even if it is | |
666 | -- null) to satisfy the call in this case. | |
667 | ||
82c80734 RD |
668 | -- Exception: do not build an array init_proc for a type whose root |
669 | -- type is Standard.String or Standard.Wide_[Wide_]String, since there | |
670 | -- is no place to put the code, and in any case we handle initialization | |
671 | -- of such types (in the Initialize_Scalars case, that's the only time | |
672 | -- the issue arises) in a special manner anyway which does not need an | |
673 | -- init_proc. | |
70482933 | 674 | |
c5ecf679 GD |
675 | Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type) |
676 | or else Needs_Simple_Initialization (Comp_Type) | |
677 | or else Has_Task (Comp_Type); | |
678 | ||
679 | if Has_Default_Init | |
6e937c1c | 680 | or else (not Restriction_Active (No_Initialize_Scalars) |
c5ecf679 GD |
681 | and then Is_Public (A_Type) |
682 | and then Root_Type (A_Type) /= Standard_String | |
683 | and then Root_Type (A_Type) /= Standard_Wide_String | |
684 | and then Root_Type (A_Type) /= Standard_Wide_Wide_String) | |
70482933 RK |
685 | then |
686 | Proc_Id := | |
f2cbd970 JM |
687 | Make_Defining_Identifier (Loc, |
688 | Chars => Make_Init_Proc_Name (A_Type)); | |
689 | ||
690 | -- If No_Default_Initialization restriction is active, then we don't | |
691 | -- want to build an init_proc, but we need to mark that an init_proc | |
692 | -- would be needed if this restriction was not active (so that we can | |
693 | -- detect attempts to call it), so set a dummy init_proc in place. | |
c5ecf679 GD |
694 | -- This is only done though when actual default initialization is |
695 | -- needed, so we exclude the setting in the Is_Public case, such | |
696 | -- as for arrays of scalars, since otherwise such objects would be | |
697 | -- wrongly flagged as violating the restriction. | |
f2cbd970 JM |
698 | |
699 | if Restriction_Active (No_Default_Initialization) then | |
c5ecf679 GD |
700 | if Has_Default_Init then |
701 | Set_Init_Proc (A_Type, Proc_Id); | |
702 | end if; | |
703 | ||
f2cbd970 JM |
704 | return; |
705 | end if; | |
70482933 RK |
706 | |
707 | Body_Stmts := Init_One_Dimension (1); | |
708 | ||
fbf5a39b | 709 | Discard_Node ( |
70482933 RK |
710 | Make_Subprogram_Body (Loc, |
711 | Specification => | |
712 | Make_Procedure_Specification (Loc, | |
713 | Defining_Unit_Name => Proc_Id, | |
714 | Parameter_Specifications => Init_Formals (A_Type)), | |
715 | Declarations => New_List, | |
716 | Handled_Statement_Sequence => | |
717 | Make_Handled_Sequence_Of_Statements (Loc, | |
fbf5a39b | 718 | Statements => Body_Stmts))); |
70482933 RK |
719 | |
720 | Set_Ekind (Proc_Id, E_Procedure); | |
721 | Set_Is_Public (Proc_Id, Is_Public (A_Type)); | |
70482933 RK |
722 | Set_Is_Internal (Proc_Id); |
723 | Set_Has_Completion (Proc_Id); | |
724 | ||
725 | if not Debug_Generated_Code then | |
726 | Set_Debug_Info_Off (Proc_Id); | |
727 | end if; | |
728 | ||
07fc65c4 GB |
729 | -- Set inlined unless controlled stuff or tasks around, in which |
730 | -- case we do not want to inline, because nested stuff may cause | |
47cc8d6b | 731 | -- difficulties in inter-unit inlining, and furthermore there is |
07fc65c4 GB |
732 | -- in any case no point in inlining such complex init procs. |
733 | ||
734 | if not Has_Task (Proc_Id) | |
735 | and then not Controlled_Type (Proc_Id) | |
736 | then | |
737 | Set_Is_Inlined (Proc_Id); | |
738 | end if; | |
739 | ||
70482933 RK |
740 | -- Associate Init_Proc with type, and determine if the procedure |
741 | -- is null (happens because of the Initialize_Scalars pragma case, | |
742 | -- where we have to generate a null procedure in case it is called | |
743 | -- by a client with Initialize_Scalars set). Such procedures have | |
744 | -- to be generated, but do not have to be called, so we mark them | |
745 | -- as null to suppress the call. | |
746 | ||
747 | Set_Init_Proc (A_Type, Proc_Id); | |
748 | ||
749 | if List_Length (Body_Stmts) = 1 | |
750 | and then Nkind (First (Body_Stmts)) = N_Null_Statement | |
751 | then | |
752 | Set_Is_Null_Init_Proc (Proc_Id); | |
47cc8d6b ES |
753 | |
754 | else | |
755 | -- Try to build a static aggregate to initialize statically | |
756 | -- objects of the type. This can only be done for constrained | |
757 | -- one-dimensional arrays with static bounds. | |
758 | ||
759 | Set_Static_Initialization | |
760 | (Proc_Id, | |
761 | Build_Equivalent_Array_Aggregate (First_Subtype (A_Type))); | |
70482933 RK |
762 | end if; |
763 | end if; | |
70482933 RK |
764 | end Build_Array_Init_Proc; |
765 | ||
766 | ----------------------------- | |
767 | -- Build_Class_Wide_Master -- | |
768 | ----------------------------- | |
769 | ||
770 | procedure Build_Class_Wide_Master (T : Entity_Id) is | |
771 | Loc : constant Source_Ptr := Sloc (T); | |
772 | M_Id : Entity_Id; | |
773 | Decl : Node_Id; | |
774 | P : Node_Id; | |
f4d379b8 | 775 | Par : Node_Id; |
70482933 RK |
776 | |
777 | begin | |
a5b62485 | 778 | -- Nothing to do if there is no task hierarchy |
70482933 | 779 | |
6e937c1c | 780 | if Restriction_Active (No_Task_Hierarchy) then |
70482933 RK |
781 | return; |
782 | end if; | |
783 | ||
47cc8d6b ES |
784 | -- Find declaration that created the access type: either a type |
785 | -- declaration, or an object declaration with an access definition, | |
786 | -- in which case the type is anonymous. | |
f4d379b8 HK |
787 | |
788 | if Is_Itype (T) then | |
789 | P := Associated_Node_For_Itype (T); | |
790 | else | |
791 | P := Parent (T); | |
792 | end if; | |
793 | ||
70482933 RK |
794 | -- Nothing to do if we already built a master entity for this scope |
795 | ||
796 | if not Has_Master_Entity (Scope (T)) then | |
82c80734 | 797 | |
47cc8d6b | 798 | -- First build the master entity |
70482933 | 799 | -- _Master : constant Master_Id := Current_Master.all; |
47cc8d6b | 800 | -- and insert it just before the current declaration. |
70482933 RK |
801 | |
802 | Decl := | |
803 | Make_Object_Declaration (Loc, | |
804 | Defining_Identifier => | |
805 | Make_Defining_Identifier (Loc, Name_uMaster), | |
806 | Constant_Present => True, | |
807 | Object_Definition => New_Reference_To (Standard_Integer, Loc), | |
808 | Expression => | |
809 | Make_Explicit_Dereference (Loc, | |
810 | New_Reference_To (RTE (RE_Current_Master), Loc))); | |
811 | ||
47cc8d6b | 812 | Insert_Action (P, Decl); |
70482933 RK |
813 | Analyze (Decl); |
814 | Set_Has_Master_Entity (Scope (T)); | |
815 | ||
816 | -- Now mark the containing scope as a task master | |
817 | ||
f4d379b8 HK |
818 | Par := P; |
819 | while Nkind (Par) /= N_Compilation_Unit loop | |
820 | Par := Parent (Par); | |
70482933 RK |
821 | |
822 | -- If we fall off the top, we are at the outer level, and the | |
823 | -- environment task is our effective master, so nothing to mark. | |
824 | ||
4ce9a2d8 HK |
825 | if Nkind_In |
826 | (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body) | |
70482933 | 827 | then |
f4d379b8 | 828 | Set_Is_Task_Master (Par, True); |
70482933 RK |
829 | exit; |
830 | end if; | |
831 | end loop; | |
832 | end if; | |
833 | ||
a5b62485 | 834 | -- Now define the renaming of the master_id |
70482933 RK |
835 | |
836 | M_Id := | |
837 | Make_Defining_Identifier (Loc, | |
838 | New_External_Name (Chars (T), 'M')); | |
839 | ||
840 | Decl := | |
841 | Make_Object_Renaming_Declaration (Loc, | |
842 | Defining_Identifier => M_Id, | |
843 | Subtype_Mark => New_Reference_To (Standard_Integer, Loc), | |
844 | Name => Make_Identifier (Loc, Name_uMaster)); | |
f4d379b8 | 845 | Insert_Before (P, Decl); |
70482933 RK |
846 | Analyze (Decl); |
847 | ||
848 | Set_Master_Id (T, M_Id); | |
fbf5a39b AC |
849 | |
850 | exception | |
851 | when RE_Not_Available => | |
852 | return; | |
70482933 RK |
853 | end Build_Class_Wide_Master; |
854 | ||
855 | -------------------------------- | |
856 | -- Build_Discr_Checking_Funcs -- | |
857 | -------------------------------- | |
858 | ||
859 | procedure Build_Discr_Checking_Funcs (N : Node_Id) is | |
860 | Rec_Id : Entity_Id; | |
861 | Loc : Source_Ptr; | |
862 | Enclosing_Func_Id : Entity_Id; | |
863 | Sequence : Nat := 1; | |
864 | Type_Def : Node_Id; | |
865 | V : Node_Id; | |
866 | ||
867 | function Build_Case_Statement | |
868 | (Case_Id : Entity_Id; | |
2e071734 | 869 | Variant : Node_Id) return Node_Id; |
47cc8d6b ES |
870 | -- Build a case statement containing only two alternatives. The first |
871 | -- alternative corresponds exactly to the discrete choices given on the | |
872 | -- variant with contains the components that we are generating the | |
873 | -- checks for. If the discriminant is one of these return False. The | |
874 | -- second alternative is an OTHERS choice that will return True | |
875 | -- indicating the discriminant did not match. | |
70482933 RK |
876 | |
877 | function Build_Dcheck_Function | |
878 | (Case_Id : Entity_Id; | |
2e071734 | 879 | Variant : Node_Id) return Entity_Id; |
70482933 RK |
880 | -- Build the discriminant checking function for a given variant |
881 | ||
882 | procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id); | |
883 | -- Builds the discriminant checking function for each variant of the | |
884 | -- given variant part of the record type. | |
885 | ||
886 | -------------------------- | |
887 | -- Build_Case_Statement -- | |
888 | -------------------------- | |
889 | ||
890 | function Build_Case_Statement | |
891 | (Case_Id : Entity_Id; | |
2e071734 | 892 | Variant : Node_Id) return Node_Id |
70482933 | 893 | is |
fbf5a39b | 894 | Alt_List : constant List_Id := New_List; |
70482933 | 895 | Actuals_List : List_Id; |
70482933 RK |
896 | Case_Node : Node_Id; |
897 | Case_Alt_Node : Node_Id; | |
898 | Choice : Node_Id; | |
899 | Choice_List : List_Id; | |
900 | D : Entity_Id; | |
901 | Return_Node : Node_Id; | |
902 | ||
903 | begin | |
70482933 RK |
904 | Case_Node := New_Node (N_Case_Statement, Loc); |
905 | ||
47cc8d6b ES |
906 | -- Replace the discriminant which controls the variant, with the name |
907 | -- of the formal of the checking function. | |
70482933 RK |
908 | |
909 | Set_Expression (Case_Node, | |
fbf5a39b | 910 | Make_Identifier (Loc, Chars (Case_Id))); |
70482933 RK |
911 | |
912 | Choice := First (Discrete_Choices (Variant)); | |
913 | ||
914 | if Nkind (Choice) = N_Others_Choice then | |
915 | Choice_List := New_Copy_List (Others_Discrete_Choices (Choice)); | |
916 | else | |
917 | Choice_List := New_Copy_List (Discrete_Choices (Variant)); | |
918 | end if; | |
919 | ||
920 | if not Is_Empty_List (Choice_List) then | |
921 | Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); | |
922 | Set_Discrete_Choices (Case_Alt_Node, Choice_List); | |
923 | ||
924 | -- In case this is a nested variant, we need to return the result | |
925 | -- of the discriminant checking function for the immediately | |
926 | -- enclosing variant. | |
927 | ||
928 | if Present (Enclosing_Func_Id) then | |
929 | Actuals_List := New_List; | |
930 | ||
931 | D := First_Discriminant (Rec_Id); | |
932 | while Present (D) loop | |
933 | Append (Make_Identifier (Loc, Chars (D)), Actuals_List); | |
934 | Next_Discriminant (D); | |
935 | end loop; | |
936 | ||
937 | Return_Node := | |
04df6250 | 938 | Make_Simple_Return_Statement (Loc, |
70482933 RK |
939 | Expression => |
940 | Make_Function_Call (Loc, | |
941 | Name => | |
942 | New_Reference_To (Enclosing_Func_Id, Loc), | |
943 | Parameter_Associations => | |
944 | Actuals_List)); | |
945 | ||
946 | else | |
947 | Return_Node := | |
04df6250 | 948 | Make_Simple_Return_Statement (Loc, |
70482933 RK |
949 | Expression => |
950 | New_Reference_To (Standard_False, Loc)); | |
951 | end if; | |
952 | ||
953 | Set_Statements (Case_Alt_Node, New_List (Return_Node)); | |
954 | Append (Case_Alt_Node, Alt_List); | |
955 | end if; | |
956 | ||
957 | Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); | |
958 | Choice_List := New_List (New_Node (N_Others_Choice, Loc)); | |
959 | Set_Discrete_Choices (Case_Alt_Node, Choice_List); | |
960 | ||
961 | Return_Node := | |
04df6250 | 962 | Make_Simple_Return_Statement (Loc, |
70482933 RK |
963 | Expression => |
964 | New_Reference_To (Standard_True, Loc)); | |
965 | ||
966 | Set_Statements (Case_Alt_Node, New_List (Return_Node)); | |
967 | Append (Case_Alt_Node, Alt_List); | |
968 | ||
969 | Set_Alternatives (Case_Node, Alt_List); | |
970 | return Case_Node; | |
971 | end Build_Case_Statement; | |
972 | ||
973 | --------------------------- | |
974 | -- Build_Dcheck_Function -- | |
975 | --------------------------- | |
976 | ||
977 | function Build_Dcheck_Function | |
978 | (Case_Id : Entity_Id; | |
2e071734 | 979 | Variant : Node_Id) return Entity_Id |
70482933 RK |
980 | is |
981 | Body_Node : Node_Id; | |
982 | Func_Id : Entity_Id; | |
983 | Parameter_List : List_Id; | |
984 | Spec_Node : Node_Id; | |
985 | ||
986 | begin | |
987 | Body_Node := New_Node (N_Subprogram_Body, Loc); | |
988 | Sequence := Sequence + 1; | |
989 | ||
990 | Func_Id := | |
991 | Make_Defining_Identifier (Loc, | |
992 | Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence)); | |
993 | ||
994 | Spec_Node := New_Node (N_Function_Specification, Loc); | |
995 | Set_Defining_Unit_Name (Spec_Node, Func_Id); | |
996 | ||
997 | Parameter_List := Build_Discriminant_Formals (Rec_Id, False); | |
998 | ||
999 | Set_Parameter_Specifications (Spec_Node, Parameter_List); | |
10b93b2e HK |
1000 | Set_Result_Definition (Spec_Node, |
1001 | New_Reference_To (Standard_Boolean, Loc)); | |
70482933 RK |
1002 | Set_Specification (Body_Node, Spec_Node); |
1003 | Set_Declarations (Body_Node, New_List); | |
1004 | ||
1005 | Set_Handled_Statement_Sequence (Body_Node, | |
1006 | Make_Handled_Sequence_Of_Statements (Loc, | |
1007 | Statements => New_List ( | |
1008 | Build_Case_Statement (Case_Id, Variant)))); | |
1009 | ||
1010 | Set_Ekind (Func_Id, E_Function); | |
1011 | Set_Mechanism (Func_Id, Default_Mechanism); | |
1012 | Set_Is_Inlined (Func_Id, True); | |
1013 | Set_Is_Pure (Func_Id, True); | |
1014 | Set_Is_Public (Func_Id, Is_Public (Rec_Id)); | |
1015 | Set_Is_Internal (Func_Id, True); | |
1016 | ||
1017 | if not Debug_Generated_Code then | |
1018 | Set_Debug_Info_Off (Func_Id); | |
1019 | end if; | |
1020 | ||
fbf5a39b AC |
1021 | Analyze (Body_Node); |
1022 | ||
70482933 RK |
1023 | Append_Freeze_Action (Rec_Id, Body_Node); |
1024 | Set_Dcheck_Function (Variant, Func_Id); | |
1025 | return Func_Id; | |
1026 | end Build_Dcheck_Function; | |
1027 | ||
1028 | ---------------------------- | |
1029 | -- Build_Dcheck_Functions -- | |
1030 | ---------------------------- | |
1031 | ||
1032 | procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is | |
1033 | Component_List_Node : Node_Id; | |
1034 | Decl : Entity_Id; | |
1035 | Discr_Name : Entity_Id; | |
1036 | Func_Id : Entity_Id; | |
1037 | Variant : Node_Id; | |
1038 | Saved_Enclosing_Func_Id : Entity_Id; | |
1039 | ||
1040 | begin | |
d70d147e GD |
1041 | -- Build the discriminant-checking function for each variant, and |
1042 | -- label all components of that variant with the function's name. | |
1043 | -- We only Generate a discriminant-checking function when the | |
f2cbd970 | 1044 | -- variant is not empty, to prevent the creation of dead code. |
d70d147e GD |
1045 | -- The exception to that is when Frontend_Layout_On_Target is set, |
1046 | -- because the variant record size function generated in package | |
1047 | -- Layout needs to generate calls to all discriminant-checking | |
1048 | -- functions, including those for empty variants. | |
70482933 RK |
1049 | |
1050 | Discr_Name := Entity (Name (Variant_Part_Node)); | |
1051 | Variant := First_Non_Pragma (Variants (Variant_Part_Node)); | |
1052 | ||
1053 | while Present (Variant) loop | |
70482933 RK |
1054 | Component_List_Node := Component_List (Variant); |
1055 | ||
d70d147e GD |
1056 | if not Null_Present (Component_List_Node) |
1057 | or else Frontend_Layout_On_Target | |
1058 | then | |
f2cbd970 | 1059 | Func_Id := Build_Dcheck_Function (Discr_Name, Variant); |
70482933 RK |
1060 | Decl := |
1061 | First_Non_Pragma (Component_Items (Component_List_Node)); | |
1062 | ||
1063 | while Present (Decl) loop | |
1064 | Set_Discriminant_Checking_Func | |
1065 | (Defining_Identifier (Decl), Func_Id); | |
1066 | ||
1067 | Next_Non_Pragma (Decl); | |
1068 | end loop; | |
1069 | ||
1070 | if Present (Variant_Part (Component_List_Node)) then | |
1071 | Saved_Enclosing_Func_Id := Enclosing_Func_Id; | |
1072 | Enclosing_Func_Id := Func_Id; | |
1073 | Build_Dcheck_Functions (Variant_Part (Component_List_Node)); | |
1074 | Enclosing_Func_Id := Saved_Enclosing_Func_Id; | |
1075 | end if; | |
1076 | end if; | |
1077 | ||
1078 | Next_Non_Pragma (Variant); | |
1079 | end loop; | |
1080 | end Build_Dcheck_Functions; | |
1081 | ||
1082 | -- Start of processing for Build_Discr_Checking_Funcs | |
1083 | ||
1084 | begin | |
1085 | -- Only build if not done already | |
1086 | ||
1087 | if not Discr_Check_Funcs_Built (N) then | |
1088 | Type_Def := Type_Definition (N); | |
1089 | ||
1090 | if Nkind (Type_Def) = N_Record_Definition then | |
1091 | if No (Component_List (Type_Def)) then -- null record. | |
1092 | return; | |
1093 | else | |
1094 | V := Variant_Part (Component_List (Type_Def)); | |
1095 | end if; | |
1096 | ||
1097 | else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition); | |
1098 | if No (Component_List (Record_Extension_Part (Type_Def))) then | |
1099 | return; | |
1100 | else | |
1101 | V := Variant_Part | |
1102 | (Component_List (Record_Extension_Part (Type_Def))); | |
1103 | end if; | |
1104 | end if; | |
1105 | ||
1106 | Rec_Id := Defining_Identifier (N); | |
1107 | ||
1108 | if Present (V) and then not Is_Unchecked_Union (Rec_Id) then | |
1109 | Loc := Sloc (N); | |
1110 | Enclosing_Func_Id := Empty; | |
1111 | Build_Dcheck_Functions (V); | |
1112 | end if; | |
1113 | ||
1114 | Set_Discr_Check_Funcs_Built (N); | |
1115 | end if; | |
1116 | end Build_Discr_Checking_Funcs; | |
1117 | ||
1118 | -------------------------------- | |
1119 | -- Build_Discriminant_Formals -- | |
1120 | -------------------------------- | |
1121 | ||
1122 | function Build_Discriminant_Formals | |
1123 | (Rec_Id : Entity_Id; | |
2e071734 | 1124 | Use_Dl : Boolean) return List_Id |
70482933 | 1125 | is |
fbf5a39b AC |
1126 | Loc : Source_Ptr := Sloc (Rec_Id); |
1127 | Parameter_List : constant List_Id := New_List; | |
70482933 RK |
1128 | D : Entity_Id; |
1129 | Formal : Entity_Id; | |
70482933 | 1130 | Param_Spec_Node : Node_Id; |
70482933 RK |
1131 | |
1132 | begin | |
1133 | if Has_Discriminants (Rec_Id) then | |
1134 | D := First_Discriminant (Rec_Id); | |
70482933 RK |
1135 | while Present (D) loop |
1136 | Loc := Sloc (D); | |
1137 | ||
1138 | if Use_Dl then | |
1139 | Formal := Discriminal (D); | |
1140 | else | |
fbf5a39b | 1141 | Formal := Make_Defining_Identifier (Loc, Chars (D)); |
70482933 RK |
1142 | end if; |
1143 | ||
1144 | Param_Spec_Node := | |
1145 | Make_Parameter_Specification (Loc, | |
1146 | Defining_Identifier => Formal, | |
1147 | Parameter_Type => | |
1148 | New_Reference_To (Etype (D), Loc)); | |
1149 | Append (Param_Spec_Node, Parameter_List); | |
1150 | Next_Discriminant (D); | |
1151 | end loop; | |
1152 | end if; | |
1153 | ||
1154 | return Parameter_List; | |
1155 | end Build_Discriminant_Formals; | |
1156 | ||
47cc8d6b ES |
1157 | -------------------------------------- |
1158 | -- Build_Equivalent_Array_Aggregate -- | |
1159 | -------------------------------------- | |
1160 | ||
1161 | function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is | |
1162 | Loc : constant Source_Ptr := Sloc (T); | |
1163 | Comp_Type : constant Entity_Id := Component_Type (T); | |
1164 | Index_Type : constant Entity_Id := Etype (First_Index (T)); | |
1165 | Proc : constant Entity_Id := Base_Init_Proc (T); | |
1166 | Lo, Hi : Node_Id; | |
1167 | Aggr : Node_Id; | |
1168 | Expr : Node_Id; | |
1169 | ||
1170 | begin | |
1171 | if not Is_Constrained (T) | |
1172 | or else Number_Dimensions (T) > 1 | |
1173 | or else No (Proc) | |
1174 | then | |
1175 | Initialization_Warning (T); | |
1176 | return Empty; | |
1177 | end if; | |
1178 | ||
1179 | Lo := Type_Low_Bound (Index_Type); | |
1180 | Hi := Type_High_Bound (Index_Type); | |
1181 | ||
1182 | if not Compile_Time_Known_Value (Lo) | |
1183 | or else not Compile_Time_Known_Value (Hi) | |
1184 | then | |
1185 | Initialization_Warning (T); | |
1186 | return Empty; | |
1187 | end if; | |
1188 | ||
1189 | if Is_Record_Type (Comp_Type) | |
1190 | and then Present (Base_Init_Proc (Comp_Type)) | |
1191 | then | |
1192 | Expr := Static_Initialization (Base_Init_Proc (Comp_Type)); | |
1193 | ||
1194 | if No (Expr) then | |
1195 | Initialization_Warning (T); | |
1196 | return Empty; | |
1197 | end if; | |
1198 | ||
1199 | else | |
1200 | Initialization_Warning (T); | |
1201 | return Empty; | |
1202 | end if; | |
1203 | ||
1204 | Aggr := Make_Aggregate (Loc, No_List, New_List); | |
1205 | Set_Etype (Aggr, T); | |
1206 | Set_Aggregate_Bounds (Aggr, | |
1207 | Make_Range (Loc, | |
1208 | Low_Bound => New_Copy (Lo), | |
1209 | High_Bound => New_Copy (Hi))); | |
1210 | Set_Parent (Aggr, Parent (Proc)); | |
1211 | ||
1212 | Append_To (Component_Associations (Aggr), | |
1213 | Make_Component_Association (Loc, | |
1214 | Choices => | |
1215 | New_List ( | |
1216 | Make_Range (Loc, | |
1217 | Low_Bound => New_Copy (Lo), | |
1218 | High_Bound => New_Copy (Hi))), | |
1219 | Expression => Expr)); | |
1220 | ||
1221 | if Static_Array_Aggregate (Aggr) then | |
1222 | return Aggr; | |
1223 | else | |
1224 | Initialization_Warning (T); | |
1225 | return Empty; | |
1226 | end if; | |
1227 | end Build_Equivalent_Array_Aggregate; | |
1228 | ||
1229 | --------------------------------------- | |
1230 | -- Build_Equivalent_Record_Aggregate -- | |
1231 | --------------------------------------- | |
1232 | ||
1233 | function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is | |
1234 | Agg : Node_Id; | |
1235 | Comp : Entity_Id; | |
1236 | ||
1237 | -- Start of processing for Build_Equivalent_Record_Aggregate | |
1238 | ||
1239 | begin | |
1240 | if not Is_Record_Type (T) | |
1241 | or else Has_Discriminants (T) | |
1242 | or else Is_Limited_Type (T) | |
1243 | or else Has_Non_Standard_Rep (T) | |
1244 | then | |
1245 | Initialization_Warning (T); | |
1246 | return Empty; | |
1247 | end if; | |
1248 | ||
1249 | Comp := First_Component (T); | |
1250 | ||
1251 | -- A null record needs no warning | |
1252 | ||
1253 | if No (Comp) then | |
1254 | return Empty; | |
1255 | end if; | |
1256 | ||
1257 | while Present (Comp) loop | |
1258 | ||
1259 | -- Array components are acceptable if initialized by a positional | |
1260 | -- aggregate with static components. | |
1261 | ||
1262 | if Is_Array_Type (Etype (Comp)) then | |
1263 | declare | |
1264 | Comp_Type : constant Entity_Id := Component_Type (Etype (Comp)); | |
1265 | ||
1266 | begin | |
1267 | if Nkind (Parent (Comp)) /= N_Component_Declaration | |
1268 | or else No (Expression (Parent (Comp))) | |
1269 | or else Nkind (Expression (Parent (Comp))) /= N_Aggregate | |
1270 | then | |
1271 | Initialization_Warning (T); | |
1272 | return Empty; | |
1273 | ||
1274 | elsif Is_Scalar_Type (Component_Type (Etype (Comp))) | |
1275 | and then | |
1276 | (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type)) | |
1277 | or else not Compile_Time_Known_Value | |
1278 | (Type_High_Bound (Comp_Type))) | |
1279 | then | |
1280 | Initialization_Warning (T); | |
1281 | return Empty; | |
1282 | ||
1283 | elsif | |
1284 | not Static_Array_Aggregate (Expression (Parent (Comp))) | |
1285 | then | |
1286 | Initialization_Warning (T); | |
1287 | return Empty; | |
1288 | end if; | |
1289 | end; | |
1290 | ||
1291 | elsif Is_Scalar_Type (Etype (Comp)) then | |
1292 | if Nkind (Parent (Comp)) /= N_Component_Declaration | |
1293 | or else No (Expression (Parent (Comp))) | |
1294 | or else not Compile_Time_Known_Value (Expression (Parent (Comp))) | |
1295 | then | |
1296 | Initialization_Warning (T); | |
1297 | return Empty; | |
1298 | end if; | |
1299 | ||
1300 | -- For now, other types are excluded | |
1301 | ||
1302 | else | |
1303 | Initialization_Warning (T); | |
1304 | return Empty; | |
1305 | end if; | |
1306 | ||
1307 | Next_Component (Comp); | |
1308 | end loop; | |
1309 | ||
1310 | -- All components have static initialization. Build positional | |
1311 | -- aggregate from the given expressions or defaults. | |
1312 | ||
1313 | Agg := Make_Aggregate (Sloc (T), New_List, New_List); | |
1314 | Set_Parent (Agg, Parent (T)); | |
1315 | ||
1316 | Comp := First_Component (T); | |
1317 | while Present (Comp) loop | |
1318 | Append | |
1319 | (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg)); | |
1320 | Next_Component (Comp); | |
1321 | end loop; | |
1322 | ||
1323 | Analyze_And_Resolve (Agg, T); | |
1324 | return Agg; | |
1325 | end Build_Equivalent_Record_Aggregate; | |
1326 | ||
70482933 RK |
1327 | ------------------------------- |
1328 | -- Build_Initialization_Call -- | |
1329 | ------------------------------- | |
1330 | ||
47cc8d6b ES |
1331 | -- References to a discriminant inside the record type declaration can |
1332 | -- appear either in the subtype_indication to constrain a record or an | |
1333 | -- array, or as part of a larger expression given for the initial value | |
1334 | -- of a component. In both of these cases N appears in the record | |
1335 | -- initialization procedure and needs to be replaced by the formal | |
1336 | -- parameter of the initialization procedure which corresponds to that | |
1337 | -- discriminant. | |
70482933 RK |
1338 | |
1339 | -- In the example below, references to discriminants D1 and D2 in proc_1 | |
1340 | -- are replaced by references to formals with the same name | |
1341 | -- (discriminals) | |
1342 | ||
47cc8d6b ES |
1343 | -- A similar replacement is done for calls to any record initialization |
1344 | -- procedure for any components that are themselves of a record type. | |
70482933 RK |
1345 | |
1346 | -- type R (D1, D2 : Integer) is record | |
1347 | -- X : Integer := F * D1; | |
1348 | -- Y : Integer := F * D2; | |
1349 | -- end record; | |
1350 | ||
1351 | -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is | |
1352 | -- begin | |
1353 | -- Out_2.D1 := D1; | |
1354 | -- Out_2.D2 := D2; | |
1355 | -- Out_2.X := F * D1; | |
1356 | -- Out_2.Y := F * D2; | |
1357 | -- end; | |
1358 | ||
1359 | function Build_Initialization_Call | |
c45b6ae0 AC |
1360 | (Loc : Source_Ptr; |
1361 | Id_Ref : Node_Id; | |
1362 | Typ : Entity_Id; | |
1363 | In_Init_Proc : Boolean := False; | |
1364 | Enclos_Type : Entity_Id := Empty; | |
1365 | Discr_Map : Elist_Id := New_Elmt_List; | |
2e071734 | 1366 | With_Default_Init : Boolean := False) return List_Id |
70482933 RK |
1367 | is |
1368 | First_Arg : Node_Id; | |
1369 | Args : List_Id; | |
1370 | Decls : List_Id; | |
1371 | Decl : Node_Id; | |
1372 | Discr : Entity_Id; | |
1373 | Arg : Node_Id; | |
1374 | Proc : constant Entity_Id := Base_Init_Proc (Typ); | |
1375 | Init_Type : constant Entity_Id := Etype (First_Formal (Proc)); | |
1376 | Full_Init_Type : constant Entity_Id := Underlying_Type (Init_Type); | |
fbf5a39b | 1377 | Res : constant List_Id := New_List; |
70482933 RK |
1378 | Full_Type : Entity_Id := Typ; |
1379 | Controller_Typ : Entity_Id; | |
1380 | ||
1381 | begin | |
2820d220 | 1382 | -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars |
70482933 RK |
1383 | -- is active (in which case we make the call anyway, since in the |
1384 | -- actual compiled client it may be non null). | |
47cc8d6b | 1385 | -- Also nothing to do for value types. |
70482933 | 1386 | |
47cc8d6b ES |
1387 | if (Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars) |
1388 | or else Is_Value_Type (Typ) | |
1389 | or else Is_Value_Type (Component_Type (Typ)) | |
1390 | then | |
70482933 RK |
1391 | return Empty_List; |
1392 | end if; | |
1393 | ||
fbf5a39b AC |
1394 | -- Go to full view if private type. In the case of successive |
1395 | -- private derivations, this can require more than one step. | |
70482933 | 1396 | |
fbf5a39b AC |
1397 | while Is_Private_Type (Full_Type) |
1398 | and then Present (Full_View (Full_Type)) | |
1399 | loop | |
1400 | Full_Type := Full_View (Full_Type); | |
1401 | end loop; | |
70482933 RK |
1402 | |
1403 | -- If Typ is derived, the procedure is the initialization procedure for | |
1404 | -- the root type. Wrap the argument in an conversion to make it type | |
1405 | -- honest. Actually it isn't quite type honest, because there can be | |
1406 | -- conflicts of views in the private type case. That is why we set | |
1407 | -- Conversion_OK in the conversion node. | |
a05e99a2 | 1408 | |
70482933 RK |
1409 | if (Is_Record_Type (Typ) |
1410 | or else Is_Array_Type (Typ) | |
1411 | or else Is_Private_Type (Typ)) | |
1412 | and then Init_Type /= Base_Type (Typ) | |
1413 | then | |
1414 | First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref); | |
1415 | Set_Etype (First_Arg, Init_Type); | |
1416 | ||
1417 | else | |
1418 | First_Arg := Id_Ref; | |
1419 | end if; | |
1420 | ||
1421 | Args := New_List (Convert_Concurrent (First_Arg, Typ)); | |
1422 | ||
1423 | -- In the tasks case, add _Master as the value of the _Master parameter | |
1424 | -- and _Chain as the value of the _Chain parameter. At the outer level, | |
1425 | -- these will be variables holding the corresponding values obtained | |
1426 | -- from GNARL. At inner levels, they will be the parameters passed down | |
1427 | -- through the outer routines. | |
1428 | ||
1429 | if Has_Task (Full_Type) then | |
6e937c1c | 1430 | if Restriction_Active (No_Task_Hierarchy) then |
70482933 RK |
1431 | |
1432 | -- See comments in System.Tasking.Initialization.Init_RTS | |
fbf5a39b | 1433 | -- for the value 3 (should be rtsfindable constant ???) |
70482933 RK |
1434 | |
1435 | Append_To (Args, Make_Integer_Literal (Loc, 3)); | |
ea1941af | 1436 | |
70482933 RK |
1437 | else |
1438 | Append_To (Args, Make_Identifier (Loc, Name_uMaster)); | |
1439 | end if; | |
1440 | ||
1441 | Append_To (Args, Make_Identifier (Loc, Name_uChain)); | |
1442 | ||
0ab80019 | 1443 | -- Ada 2005 (AI-287): In case of default initialized components |
c45b6ae0 AC |
1444 | -- with tasks, we generate a null string actual parameter. |
1445 | -- This is just a workaround that must be improved later??? | |
70482933 | 1446 | |
c45b6ae0 | 1447 | if With_Default_Init then |
1d571f3b AC |
1448 | Append_To (Args, |
1449 | Make_String_Literal (Loc, | |
1450 | Strval => "")); | |
1451 | ||
c45b6ae0 | 1452 | else |
3476f949 JM |
1453 | Decls := |
1454 | Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc); | |
c45b6ae0 AC |
1455 | Decl := Last (Decls); |
1456 | ||
1457 | Append_To (Args, | |
1458 | New_Occurrence_Of (Defining_Identifier (Decl), Loc)); | |
1459 | Append_List (Decls, Res); | |
1460 | end if; | |
70482933 RK |
1461 | |
1462 | else | |
1463 | Decls := No_List; | |
1464 | Decl := Empty; | |
1465 | end if; | |
1466 | ||
1467 | -- Add discriminant values if discriminants are present | |
1468 | ||
1469 | if Has_Discriminants (Full_Init_Type) then | |
1470 | Discr := First_Discriminant (Full_Init_Type); | |
1471 | ||
1472 | while Present (Discr) loop | |
1473 | ||
1474 | -- If this is a discriminated concurrent type, the init_proc | |
47cc8d6b ES |
1475 | -- for the corresponding record is being called. Use that type |
1476 | -- directly to find the discriminant value, to handle properly | |
1477 | -- intervening renamed discriminants. | |
70482933 RK |
1478 | |
1479 | declare | |
1480 | T : Entity_Id := Full_Type; | |
1481 | ||
1482 | begin | |
1483 | if Is_Protected_Type (T) then | |
1484 | T := Corresponding_Record_Type (T); | |
fbf5a39b AC |
1485 | |
1486 | elsif Is_Private_Type (T) | |
1487 | and then Present (Underlying_Full_View (T)) | |
1488 | and then Is_Protected_Type (Underlying_Full_View (T)) | |
1489 | then | |
1490 | T := Corresponding_Record_Type (Underlying_Full_View (T)); | |
70482933 RK |
1491 | end if; |
1492 | ||
1493 | Arg := | |
1494 | Get_Discriminant_Value ( | |
1495 | Discr, | |
1496 | T, | |
1497 | Discriminant_Constraint (Full_Type)); | |
1498 | end; | |
1499 | ||
1500 | if In_Init_Proc then | |
1501 | ||
1502 | -- Replace any possible references to the discriminant in the | |
1503 | -- call to the record initialization procedure with references | |
1504 | -- to the appropriate formal parameter. | |
1505 | ||
1506 | if Nkind (Arg) = N_Identifier | |
1507 | and then Ekind (Entity (Arg)) = E_Discriminant | |
1508 | then | |
1509 | Arg := New_Reference_To (Discriminal (Entity (Arg)), Loc); | |
1510 | ||
1511 | -- Case of access discriminants. We replace the reference | |
1512 | -- to the type by a reference to the actual object | |
1513 | ||
1514 | elsif Nkind (Arg) = N_Attribute_Reference | |
1515 | and then Is_Access_Type (Etype (Arg)) | |
1516 | and then Is_Entity_Name (Prefix (Arg)) | |
1517 | and then Is_Type (Entity (Prefix (Arg))) | |
1518 | then | |
1519 | Arg := | |
1520 | Make_Attribute_Reference (Loc, | |
1521 | Prefix => New_Copy (Prefix (Id_Ref)), | |
1522 | Attribute_Name => Name_Unrestricted_Access); | |
1523 | ||
47cc8d6b ES |
1524 | -- Otherwise make a copy of the default expression. Note that |
1525 | -- we use the current Sloc for this, because we do not want the | |
1526 | -- call to appear to be at the declaration point. Within the | |
1527 | -- expression, replace discriminants with their discriminals. | |
70482933 RK |
1528 | |
1529 | else | |
1530 | Arg := | |
1531 | New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc); | |
1532 | end if; | |
1533 | ||
1534 | else | |
1535 | if Is_Constrained (Full_Type) then | |
fbf5a39b | 1536 | Arg := Duplicate_Subexpr_No_Checks (Arg); |
70482933 | 1537 | else |
47cc8d6b ES |
1538 | -- The constraints come from the discriminant default exps, |
1539 | -- they must be reevaluated, so we use New_Copy_Tree but we | |
1540 | -- ensure the proper Sloc (for any embedded calls). | |
70482933 RK |
1541 | |
1542 | Arg := New_Copy_Tree (Arg, New_Sloc => Loc); | |
1543 | end if; | |
1544 | end if; | |
1545 | ||
1baa4d2d | 1546 | -- Ada 2005 (AI-287): In case of default initialized components, |
0ab80019 | 1547 | -- we need to generate the corresponding selected component node |
c45b6ae0 AC |
1548 | -- to access the discriminant value. In other cases this is not |
1549 | -- required because we are inside the init proc and we use the | |
1550 | -- corresponding formal. | |
1551 | ||
1552 | if With_Default_Init | |
1553 | and then Nkind (Id_Ref) = N_Selected_Component | |
a05e99a2 | 1554 | and then Nkind (Arg) = N_Identifier |
c45b6ae0 AC |
1555 | then |
1556 | Append_To (Args, | |
1557 | Make_Selected_Component (Loc, | |
1558 | Prefix => New_Copy_Tree (Prefix (Id_Ref)), | |
1559 | Selector_Name => Arg)); | |
1560 | else | |
1561 | Append_To (Args, Arg); | |
1562 | end if; | |
70482933 RK |
1563 | |
1564 | Next_Discriminant (Discr); | |
1565 | end loop; | |
1566 | end if; | |
1567 | ||
1568 | -- If this is a call to initialize the parent component of a derived | |
1569 | -- tagged type, indicate that the tag should not be set in the parent. | |
1570 | ||
1571 | if Is_Tagged_Type (Full_Init_Type) | |
1572 | and then not Is_CPP_Class (Full_Init_Type) | |
1573 | and then Nkind (Id_Ref) = N_Selected_Component | |
1574 | and then Chars (Selector_Name (Id_Ref)) = Name_uParent | |
1575 | then | |
1576 | Append_To (Args, New_Occurrence_Of (Standard_False, Loc)); | |
1577 | end if; | |
1578 | ||
1579 | Append_To (Res, | |
1580 | Make_Procedure_Call_Statement (Loc, | |
1581 | Name => New_Occurrence_Of (Proc, Loc), | |
1582 | Parameter_Associations => Args)); | |
1583 | ||
1584 | if Controlled_Type (Typ) | |
1585 | and then Nkind (Id_Ref) = N_Selected_Component | |
1586 | then | |
1587 | if Chars (Selector_Name (Id_Ref)) /= Name_uParent then | |
1588 | Append_List_To (Res, | |
1589 | Make_Init_Call ( | |
1590 | Ref => New_Copy_Tree (First_Arg), | |
1591 | Typ => Typ, | |
1592 | Flist_Ref => | |
1593 | Find_Final_List (Typ, New_Copy_Tree (First_Arg)), | |
1594 | With_Attach => Make_Integer_Literal (Loc, 1))); | |
1595 | ||
1596 | -- If the enclosing type is an extension with new controlled | |
1597 | -- components, it has his own record controller. If the parent | |
1598 | -- also had a record controller, attach it to the new one. | |
47cc8d6b | 1599 | |
70482933 RK |
1600 | -- Build_Init_Statements relies on the fact that in this specific |
1601 | -- case the last statement of the result is the attach call to | |
1602 | -- the controller. If this is changed, it must be synchronized. | |
1603 | ||
1604 | elsif Present (Enclos_Type) | |
1605 | and then Has_New_Controlled_Component (Enclos_Type) | |
1606 | and then Has_Controlled_Component (Typ) | |
1607 | then | |
3476f949 | 1608 | if Is_Inherently_Limited_Type (Typ) then |
70482933 RK |
1609 | Controller_Typ := RTE (RE_Limited_Record_Controller); |
1610 | else | |
1611 | Controller_Typ := RTE (RE_Record_Controller); | |
1612 | end if; | |
1613 | ||
1614 | Append_List_To (Res, | |
1615 | Make_Init_Call ( | |
1616 | Ref => | |
1617 | Make_Selected_Component (Loc, | |
1618 | Prefix => New_Copy_Tree (First_Arg), | |
1619 | Selector_Name => Make_Identifier (Loc, Name_uController)), | |
1620 | Typ => Controller_Typ, | |
1621 | Flist_Ref => Find_Final_List (Typ, New_Copy_Tree (First_Arg)), | |
1622 | With_Attach => Make_Integer_Literal (Loc, 1))); | |
1623 | end if; | |
1624 | end if; | |
1625 | ||
70482933 | 1626 | return Res; |
fbf5a39b AC |
1627 | |
1628 | exception | |
1629 | when RE_Not_Available => | |
1630 | return Empty_List; | |
70482933 RK |
1631 | end Build_Initialization_Call; |
1632 | ||
1633 | --------------------------- | |
1634 | -- Build_Master_Renaming -- | |
1635 | --------------------------- | |
1636 | ||
ea1941af ES |
1637 | function Build_Master_Renaming |
1638 | (N : Node_Id; | |
1639 | T : Entity_Id) return Entity_Id | |
1640 | is | |
70482933 RK |
1641 | Loc : constant Source_Ptr := Sloc (N); |
1642 | M_Id : Entity_Id; | |
1643 | Decl : Node_Id; | |
1644 | ||
1645 | begin | |
a5b62485 | 1646 | -- Nothing to do if there is no task hierarchy |
70482933 | 1647 | |
6e937c1c | 1648 | if Restriction_Active (No_Task_Hierarchy) then |
ea1941af | 1649 | return Empty; |
70482933 RK |
1650 | end if; |
1651 | ||
1652 | M_Id := | |
1653 | Make_Defining_Identifier (Loc, | |
1654 | New_External_Name (Chars (T), 'M')); | |
1655 | ||
1656 | Decl := | |
1657 | Make_Object_Renaming_Declaration (Loc, | |
1658 | Defining_Identifier => M_Id, | |
1659 | Subtype_Mark => New_Reference_To (RTE (RE_Master_Id), Loc), | |
1660 | Name => Make_Identifier (Loc, Name_uMaster)); | |
1661 | Insert_Before (N, Decl); | |
1662 | Analyze (Decl); | |
ea1941af | 1663 | return M_Id; |
70482933 | 1664 | |
ea1941af ES |
1665 | exception |
1666 | when RE_Not_Available => | |
1667 | return Empty; | |
1668 | end Build_Master_Renaming; | |
1669 | ||
1670 | --------------------------- | |
1671 | -- Build_Master_Renaming -- | |
1672 | --------------------------- | |
1673 | ||
1674 | procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is | |
1675 | M_Id : Entity_Id; | |
1676 | ||
1677 | begin | |
1678 | -- Nothing to do if there is no task hierarchy | |
1679 | ||
1680 | if Restriction_Active (No_Task_Hierarchy) then | |
1681 | return; | |
1682 | end if; | |
1683 | ||
1684 | M_Id := Build_Master_Renaming (N, T); | |
70482933 RK |
1685 | Set_Master_Id (T, M_Id); |
1686 | ||
fbf5a39b AC |
1687 | exception |
1688 | when RE_Not_Available => | |
1689 | return; | |
70482933 RK |
1690 | end Build_Master_Renaming; |
1691 | ||
1692 | ---------------------------- | |
1693 | -- Build_Record_Init_Proc -- | |
1694 | ---------------------------- | |
1695 | ||
1696 | procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is | |
1697 | Loc : Source_Ptr := Sloc (N); | |
fbf5a39b | 1698 | Discr_Map : constant Elist_Id := New_Elmt_List; |
70482933 RK |
1699 | Proc_Id : Entity_Id; |
1700 | Rec_Type : Entity_Id; | |
70482933 RK |
1701 | Set_Tag : Entity_Id := Empty; |
1702 | ||
1703 | function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; | |
47cc8d6b ES |
1704 | -- Build a assignment statement node which assigns to record component |
1705 | -- its default expression if defined. The assignment left hand side is | |
1706 | -- marked Assignment_OK so that initialization of limited private | |
1707 | -- records works correctly, Return also the adjustment call for | |
1708 | -- controlled objects | |
70482933 RK |
1709 | |
1710 | procedure Build_Discriminant_Assignments (Statement_List : List_Id); | |
1711 | -- If the record has discriminants, adds assignment statements to | |
1712 | -- statement list to initialize the discriminant values from the | |
1713 | -- arguments of the initialization procedure. | |
1714 | ||
1715 | function Build_Init_Statements (Comp_List : Node_Id) return List_Id; | |
1716 | -- Build a list representing a sequence of statements which initialize | |
1717 | -- components of the given component list. This may involve building | |
1718 | -- case statements for the variant parts. | |
1719 | ||
2e071734 | 1720 | function Build_Init_Call_Thru (Parameters : List_Id) return List_Id; |
70482933 RK |
1721 | -- Given a non-tagged type-derivation that declares discriminants, |
1722 | -- such as | |
1723 | -- | |
1724 | -- type R (R1, R2 : Integer) is record ... end record; | |
1725 | -- | |
1726 | -- type D (D1 : Integer) is new R (1, D1); | |
1727 | -- | |
1728 | -- we make the _init_proc of D be | |
1729 | -- | |
1730 | -- procedure _init_proc(X : D; D1 : Integer) is | |
1731 | -- begin | |
1732 | -- _init_proc( R(X), 1, D1); | |
1733 | -- end _init_proc; | |
1734 | -- | |
1735 | -- This function builds the call statement in this _init_proc. | |
1736 | ||
1737 | procedure Build_Init_Procedure; | |
1738 | -- Build the tree corresponding to the procedure specification and body | |
1739 | -- of the initialization procedure (by calling all the preceding | |
1740 | -- auxiliary routines), and install it as the _init TSS. | |
1741 | ||
a05e99a2 JM |
1742 | procedure Build_Offset_To_Top_Functions; |
1743 | -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec | |
1744 | -- and body of the Offset_To_Top function that is generated when the | |
1745 | -- parent of a type with discriminants has secondary dispatch tables. | |
1746 | ||
07fc65c4 | 1747 | procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id); |
47cc8d6b | 1748 | -- Add range checks to components of discriminated records. S is a |
07fc65c4 GB |
1749 | -- subtype indication of a record component. Check_List is a list |
1750 | -- to which the check actions are appended. | |
70482933 RK |
1751 | |
1752 | function Component_Needs_Simple_Initialization | |
2e071734 | 1753 | (T : Entity_Id) return Boolean; |
758c442c GD |
1754 | -- Determines if a component needs simple initialization, given its type |
1755 | -- T. This is the same as Needs_Simple_Initialization except for the | |
47cc8d6b ES |
1756 | -- following difference: the types Tag and Interface_Tag, that are |
1757 | -- access types which would normally require simple initialization to | |
1758 | -- null, do not require initialization as components, since they are | |
1759 | -- explicitly initialized by other means. | |
70482933 RK |
1760 | |
1761 | procedure Constrain_Array | |
07fc65c4 GB |
1762 | (SI : Node_Id; |
1763 | Check_List : List_Id); | |
70482933 RK |
1764 | -- Called from Build_Record_Checks. |
1765 | -- Apply a list of index constraints to an unconstrained array type. | |
1766 | -- The first parameter is the entity for the resulting subtype. | |
07fc65c4 | 1767 | -- Check_List is a list to which the check actions are appended. |
70482933 RK |
1768 | |
1769 | procedure Constrain_Index | |
07fc65c4 GB |
1770 | (Index : Node_Id; |
1771 | S : Node_Id; | |
1772 | Check_List : List_Id); | |
70482933 RK |
1773 | -- Process an index constraint in a constrained array declaration. |
1774 | -- The constraint can be a subtype name, or a range with or without | |
1775 | -- an explicit subtype mark. The index is the corresponding index of the | |
1776 | -- unconstrained array. S is the range expression. Check_List is a list | |
47cc8d6b ES |
1777 | -- to which the check actions are appended (called from |
1778 | -- Build_Record_Checks). | |
70482933 RK |
1779 | |
1780 | function Parent_Subtype_Renaming_Discrims return Boolean; | |
1781 | -- Returns True for base types N that rename discriminants, else False | |
1782 | ||
1783 | function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean; | |
1784 | -- Determines whether a record initialization procedure needs to be | |
1785 | -- generated for the given record type. | |
1786 | ||
1787 | ---------------------- | |
1788 | -- Build_Assignment -- | |
1789 | ---------------------- | |
1790 | ||
1791 | function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is | |
1792 | Exp : Node_Id := N; | |
1793 | Lhs : Node_Id; | |
1794 | Typ : constant Entity_Id := Underlying_Type (Etype (Id)); | |
1795 | Kind : Node_Kind := Nkind (N); | |
1796 | Res : List_Id; | |
1797 | ||
1798 | begin | |
1799 | Loc := Sloc (N); | |
1800 | Lhs := | |
1801 | Make_Selected_Component (Loc, | |
1802 | Prefix => Make_Identifier (Loc, Name_uInit), | |
1803 | Selector_Name => New_Occurrence_Of (Id, Loc)); | |
1804 | Set_Assignment_OK (Lhs); | |
1805 | ||
c885d7a1 AC |
1806 | -- Case of an access attribute applied to the current instance. |
1807 | -- Replace the reference to the type by a reference to the actual | |
1808 | -- object. (Note that this handles the case of the top level of | |
1809 | -- the expression being given by such an attribute, but does not | |
1810 | -- cover uses nested within an initial value expression. Nested | |
1811 | -- uses are unlikely to occur in practice, but are theoretically | |
1812 | -- possible. It is not clear how to handle them without fully | |
1813 | -- traversing the expression. ??? | |
70482933 RK |
1814 | |
1815 | if Kind = N_Attribute_Reference | |
1816 | and then (Attribute_Name (N) = Name_Unchecked_Access | |
1817 | or else | |
1818 | Attribute_Name (N) = Name_Unrestricted_Access) | |
1819 | and then Is_Entity_Name (Prefix (N)) | |
1820 | and then Is_Type (Entity (Prefix (N))) | |
1821 | and then Entity (Prefix (N)) = Rec_Type | |
1822 | then | |
1823 | Exp := | |
1824 | Make_Attribute_Reference (Loc, | |
1825 | Prefix => Make_Identifier (Loc, Name_uInit), | |
1826 | Attribute_Name => Name_Unrestricted_Access); | |
1827 | end if; | |
1828 | ||
47cc8d6b ES |
1829 | -- Take a copy of Exp to ensure that later copies of this component |
1830 | -- declaration in derived types see the original tree, not a node | |
1831 | -- rewritten during expansion of the init_proc. | |
c885d7a1 AC |
1832 | |
1833 | Exp := New_Copy_Tree (Exp); | |
1834 | ||
70482933 RK |
1835 | Res := New_List ( |
1836 | Make_Assignment_Statement (Loc, | |
1837 | Name => Lhs, | |
1838 | Expression => Exp)); | |
1839 | ||
1840 | Set_No_Ctrl_Actions (First (Res)); | |
1841 | ||
1842 | -- Adjust the tag if tagged (because of possible view conversions). | |
47cc8d6b | 1843 | -- Suppress the tag adjustment when VM_Target because VM tags are |
70482933 RK |
1844 | -- represented implicitly in objects. |
1845 | ||
47cc8d6b | 1846 | if Is_Tagged_Type (Typ) and then VM_Target = No_VM then |
70482933 RK |
1847 | Append_To (Res, |
1848 | Make_Assignment_Statement (Loc, | |
1849 | Name => | |
1850 | Make_Selected_Component (Loc, | |
1851 | Prefix => New_Copy_Tree (Lhs), | |
1852 | Selector_Name => | |
a9d8907c | 1853 | New_Reference_To (First_Tag_Component (Typ), Loc)), |
70482933 RK |
1854 | |
1855 | Expression => | |
1856 | Unchecked_Convert_To (RTE (RE_Tag), | |
a9d8907c JM |
1857 | New_Reference_To |
1858 | (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)))); | |
70482933 RK |
1859 | end if; |
1860 | ||
47cc8d6b ES |
1861 | -- Adjust the component if controlled except if it is an aggregate |
1862 | -- that will be expanded inline | |
70482933 RK |
1863 | |
1864 | if Kind = N_Qualified_Expression then | |
9bc43c53 | 1865 | Kind := Nkind (Expression (N)); |
70482933 RK |
1866 | end if; |
1867 | ||
1868 | if Controlled_Type (Typ) | |
1869 | and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate) | |
47cc8d6b | 1870 | and then not Is_Inherently_Limited_Type (Typ) |
70482933 RK |
1871 | then |
1872 | Append_List_To (Res, | |
1873 | Make_Adjust_Call ( | |
1874 | Ref => New_Copy_Tree (Lhs), | |
1875 | Typ => Etype (Id), | |
1876 | Flist_Ref => | |
1877 | Find_Final_List (Etype (Id), New_Copy_Tree (Lhs)), | |
1878 | With_Attach => Make_Integer_Literal (Loc, 1))); | |
1879 | end if; | |
1880 | ||
1881 | return Res; | |
fbf5a39b AC |
1882 | |
1883 | exception | |
1884 | when RE_Not_Available => | |
1885 | return Empty_List; | |
70482933 RK |
1886 | end Build_Assignment; |
1887 | ||
1888 | ------------------------------------ | |
1889 | -- Build_Discriminant_Assignments -- | |
1890 | ------------------------------------ | |
1891 | ||
1892 | procedure Build_Discriminant_Assignments (Statement_List : List_Id) is | |
1893 | D : Entity_Id; | |
1894 | Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type); | |
1895 | ||
1896 | begin | |
1897 | if Has_Discriminants (Rec_Type) | |
1898 | and then not Is_Unchecked_Union (Rec_Type) | |
1899 | then | |
1900 | D := First_Discriminant (Rec_Type); | |
1901 | ||
1902 | while Present (D) loop | |
1903 | -- Don't generate the assignment for discriminants in derived | |
1904 | -- tagged types if the discriminant is a renaming of some | |
a05e99a2 | 1905 | -- ancestor discriminant. This initialization will be done |
70482933 RK |
1906 | -- when initializing the _parent field of the derived record. |
1907 | ||
1908 | if Is_Tagged and then | |
1909 | Present (Corresponding_Discriminant (D)) | |
1910 | then | |
1911 | null; | |
1912 | ||
1913 | else | |
1914 | Loc := Sloc (D); | |
1915 | Append_List_To (Statement_List, | |
1916 | Build_Assignment (D, | |
1917 | New_Reference_To (Discriminal (D), Loc))); | |
1918 | end if; | |
1919 | ||
1920 | Next_Discriminant (D); | |
1921 | end loop; | |
1922 | end if; | |
1923 | end Build_Discriminant_Assignments; | |
1924 | ||
1925 | -------------------------- | |
1926 | -- Build_Init_Call_Thru -- | |
1927 | -------------------------- | |
1928 | ||
2e071734 AC |
1929 | function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is |
1930 | Parent_Proc : constant Entity_Id := | |
1931 | Base_Init_Proc (Etype (Rec_Type)); | |
70482933 | 1932 | |
2e071734 AC |
1933 | Parent_Type : constant Entity_Id := |
1934 | Etype (First_Formal (Parent_Proc)); | |
70482933 | 1935 | |
2e071734 AC |
1936 | Uparent_Type : constant Entity_Id := |
1937 | Underlying_Type (Parent_Type); | |
70482933 RK |
1938 | |
1939 | First_Discr_Param : Node_Id; | |
1940 | ||
1941 | Parent_Discr : Entity_Id; | |
1942 | First_Arg : Node_Id; | |
1943 | Args : List_Id; | |
1944 | Arg : Node_Id; | |
1945 | Res : List_Id; | |
1946 | ||
1947 | begin | |
1948 | -- First argument (_Init) is the object to be initialized. | |
1949 | -- ??? not sure where to get a reasonable Loc for First_Arg | |
1950 | ||
1951 | First_Arg := | |
1952 | OK_Convert_To (Parent_Type, | |
1953 | New_Reference_To (Defining_Identifier (First (Parameters)), Loc)); | |
1954 | ||
1955 | Set_Etype (First_Arg, Parent_Type); | |
1956 | ||
1957 | Args := New_List (Convert_Concurrent (First_Arg, Rec_Type)); | |
1958 | ||
1959 | -- In the tasks case, | |
1960 | -- add _Master as the value of the _Master parameter | |
1961 | -- add _Chain as the value of the _Chain parameter. | |
fbf5a39b | 1962 | -- add _Task_Name as the value of the _Task_Name parameter. |
70482933 RK |
1963 | -- At the outer level, these will be variables holding the |
1964 | -- corresponding values obtained from GNARL or the expander. | |
1965 | -- | |
1966 | -- At inner levels, they will be the parameters passed down through | |
1967 | -- the outer routines. | |
1968 | ||
1969 | First_Discr_Param := Next (First (Parameters)); | |
1970 | ||
1971 | if Has_Task (Rec_Type) then | |
6e937c1c | 1972 | if Restriction_Active (No_Task_Hierarchy) then |
70482933 RK |
1973 | |
1974 | -- See comments in System.Tasking.Initialization.Init_RTS | |
1975 | -- for the value 3. | |
1976 | ||
1977 | Append_To (Args, Make_Integer_Literal (Loc, 3)); | |
1978 | else | |
1979 | Append_To (Args, Make_Identifier (Loc, Name_uMaster)); | |
1980 | end if; | |
1981 | ||
1982 | Append_To (Args, Make_Identifier (Loc, Name_uChain)); | |
fbf5a39b | 1983 | Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); |
70482933 RK |
1984 | First_Discr_Param := Next (Next (Next (First_Discr_Param))); |
1985 | end if; | |
1986 | ||
1987 | -- Append discriminant values | |
1988 | ||
1989 | if Has_Discriminants (Uparent_Type) then | |
1990 | pragma Assert (not Is_Tagged_Type (Uparent_Type)); | |
1991 | ||
1992 | Parent_Discr := First_Discriminant (Uparent_Type); | |
1993 | while Present (Parent_Discr) loop | |
1994 | ||
1995 | -- Get the initial value for this discriminant | |
fbf5a39b | 1996 | -- ??? needs to be cleaned up to use parent_Discr_Constr |
70482933 RK |
1997 | -- directly. |
1998 | ||
1999 | declare | |
2000 | Discr_Value : Elmt_Id := | |
2001 | First_Elmt | |
fbf5a39b | 2002 | (Stored_Constraint (Rec_Type)); |
70482933 RK |
2003 | |
2004 | Discr : Entity_Id := | |
fbf5a39b | 2005 | First_Stored_Discriminant (Uparent_Type); |
70482933 RK |
2006 | begin |
2007 | while Original_Record_Component (Parent_Discr) /= Discr loop | |
fbf5a39b | 2008 | Next_Stored_Discriminant (Discr); |
70482933 RK |
2009 | Next_Elmt (Discr_Value); |
2010 | end loop; | |
2011 | ||
2012 | Arg := Node (Discr_Value); | |
2013 | end; | |
2014 | ||
2015 | -- Append it to the list | |
2016 | ||
2017 | if Nkind (Arg) = N_Identifier | |
2018 | and then Ekind (Entity (Arg)) = E_Discriminant | |
2019 | then | |
2020 | Append_To (Args, | |
2021 | New_Reference_To (Discriminal (Entity (Arg)), Loc)); | |
2022 | ||
2023 | -- Case of access discriminants. We replace the reference | |
3476f949 | 2024 | -- to the type by a reference to the actual object. |
70482933 | 2025 | |
3476f949 JM |
2026 | -- Is above comment right??? Use of New_Copy below seems mighty |
2027 | -- suspicious ??? | |
70482933 RK |
2028 | |
2029 | else | |
2030 | Append_To (Args, New_Copy (Arg)); | |
2031 | end if; | |
2032 | ||
2033 | Next_Discriminant (Parent_Discr); | |
2034 | end loop; | |
2035 | end if; | |
2036 | ||
2037 | Res := | |
2038 | New_List ( | |
2039 | Make_Procedure_Call_Statement (Loc, | |
2040 | Name => New_Occurrence_Of (Parent_Proc, Loc), | |
2041 | Parameter_Associations => Args)); | |
2042 | ||
2043 | return Res; | |
2044 | end Build_Init_Call_Thru; | |
2045 | ||
a05e99a2 JM |
2046 | ----------------------------------- |
2047 | -- Build_Offset_To_Top_Functions -- | |
2048 | ----------------------------------- | |
2049 | ||
2050 | procedure Build_Offset_To_Top_Functions is | |
a05e99a2 | 2051 | |
04df6250 TQ |
2052 | procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id); |
2053 | -- Generate: | |
2054 | -- function Fxx (O : in Rec_Typ) return Storage_Offset is | |
2055 | -- begin | |
2056 | -- return O.Iface_Comp'Position; | |
2057 | -- end Fxx; | |
a05e99a2 | 2058 | |
04df6250 TQ |
2059 | ------------------------------ |
2060 | -- Build_Offset_To_Top_Body -- | |
2061 | ------------------------------ | |
2062 | ||
2063 | procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is | |
2064 | Body_Node : Node_Id; | |
2065 | Func_Id : Entity_Id; | |
2066 | Spec_Node : Node_Id; | |
a05e99a2 | 2067 | |
a05e99a2 | 2068 | begin |
04df6250 TQ |
2069 | Func_Id := |
2070 | Make_Defining_Identifier (Loc, | |
2071 | Chars => New_Internal_Name ('F')); | |
a05e99a2 | 2072 | |
04df6250 | 2073 | Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id); |
ea1941af | 2074 | |
04df6250 TQ |
2075 | -- Generate |
2076 | -- function Fxx (O : in Rec_Typ) return Storage_Offset; | |
a05e99a2 | 2077 | |
04df6250 TQ |
2078 | Spec_Node := New_Node (N_Function_Specification, Loc); |
2079 | Set_Defining_Unit_Name (Spec_Node, Func_Id); | |
2080 | Set_Parameter_Specifications (Spec_Node, New_List ( | |
2081 | Make_Parameter_Specification (Loc, | |
2082 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), | |
2083 | In_Present => True, | |
2084 | Parameter_Type => New_Reference_To (Rec_Type, Loc)))); | |
2085 | Set_Result_Definition (Spec_Node, | |
2086 | New_Reference_To (RTE (RE_Storage_Offset), Loc)); | |
2087 | ||
2088 | -- Generate | |
2089 | -- function Fxx (O : in Rec_Typ) return Storage_Offset is | |
2090 | -- begin | |
2091 | -- return O.Iface_Comp'Position; | |
2092 | -- end Fxx; | |
2093 | ||
2094 | Body_Node := New_Node (N_Subprogram_Body, Loc); | |
2095 | Set_Specification (Body_Node, Spec_Node); | |
2096 | Set_Declarations (Body_Node, New_List); | |
2097 | Set_Handled_Statement_Sequence (Body_Node, | |
2098 | Make_Handled_Sequence_Of_Statements (Loc, | |
2099 | Statements => New_List ( | |
2100 | Make_Simple_Return_Statement (Loc, | |
2101 | Expression => | |
2102 | Make_Attribute_Reference (Loc, | |
2103 | Prefix => | |
2104 | Make_Selected_Component (Loc, | |
2105 | Prefix => Make_Identifier (Loc, Name_uO), | |
2106 | Selector_Name => New_Reference_To | |
2107 | (Iface_Comp, Loc)), | |
2108 | Attribute_Name => Name_Position))))); | |
2109 | ||
2110 | Set_Ekind (Func_Id, E_Function); | |
2111 | Set_Mechanism (Func_Id, Default_Mechanism); | |
2112 | Set_Is_Internal (Func_Id, True); | |
2113 | ||
2114 | if not Debug_Generated_Code then | |
2115 | Set_Debug_Info_Off (Func_Id); | |
a05e99a2 JM |
2116 | end if; |
2117 | ||
04df6250 | 2118 | Analyze (Body_Node); |
a05e99a2 | 2119 | |
04df6250 TQ |
2120 | Append_Freeze_Action (Rec_Type, Body_Node); |
2121 | end Build_Offset_To_Top_Function; | |
a05e99a2 | 2122 | |
04df6250 | 2123 | -- Local variables |
a05e99a2 | 2124 | |
04df6250 TQ |
2125 | Ifaces_List : Elist_Id; |
2126 | Ifaces_Comp_List : Elist_Id; | |
2127 | Ifaces_Tag_List : Elist_Id; | |
2128 | Iface_Elmt : Elmt_Id; | |
2129 | Comp_Elmt : Elmt_Id; | |
a05e99a2 | 2130 | |
ae7adb1b ES |
2131 | pragma Warnings (Off, Ifaces_Tag_List); |
2132 | ||
a05e99a2 JM |
2133 | -- Start of processing for Build_Offset_To_Top_Functions |
2134 | ||
2135 | begin | |
04df6250 TQ |
2136 | -- Offset_To_Top_Functions are built only for derivations of types |
2137 | -- with discriminants that cover interface types. | |
4ce9a2d8 HK |
2138 | -- Nothing is needed either in case of virtual machines, since |
2139 | -- interfaces are handled directly by the VM. | |
ea1941af | 2140 | |
04df6250 TQ |
2141 | if not Is_Tagged_Type (Rec_Type) |
2142 | or else Etype (Rec_Type) = Rec_Type | |
a05e99a2 | 2143 | or else not Has_Discriminants (Etype (Rec_Type)) |
4ce9a2d8 | 2144 | or else VM_Target /= No_VM |
a05e99a2 JM |
2145 | then |
2146 | return; | |
2147 | end if; | |
2148 | ||
ae7adb1b ES |
2149 | Collect_Interfaces_Info |
2150 | (Rec_Type, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List); | |
a05e99a2 | 2151 | |
04df6250 TQ |
2152 | -- For each interface type with secondary dispatch table we generate |
2153 | -- the Offset_To_Top_Functions (required to displace the pointer in | |
2154 | -- interface conversions) | |
a05e99a2 | 2155 | |
04df6250 TQ |
2156 | Iface_Elmt := First_Elmt (Ifaces_List); |
2157 | Comp_Elmt := First_Elmt (Ifaces_Comp_List); | |
2158 | while Present (Iface_Elmt) loop | |
a05e99a2 | 2159 | |
04df6250 TQ |
2160 | -- If the interface is a parent of Rec_Type it shares the primary |
2161 | -- dispatch table and hence there is no need to build the function | |
2162 | ||
ce2b6ba5 | 2163 | if not Is_Ancestor (Node (Iface_Elmt), Rec_Type) then |
04df6250 TQ |
2164 | Build_Offset_To_Top_Function (Iface_Comp => Node (Comp_Elmt)); |
2165 | end if; | |
2166 | ||
2167 | Next_Elmt (Iface_Elmt); | |
2168 | Next_Elmt (Comp_Elmt); | |
2169 | end loop; | |
a05e99a2 JM |
2170 | end Build_Offset_To_Top_Functions; |
2171 | ||
70482933 RK |
2172 | -------------------------- |
2173 | -- Build_Init_Procedure -- | |
2174 | -------------------------- | |
2175 | ||
2176 | procedure Build_Init_Procedure is | |
2177 | Body_Node : Node_Id; | |
2178 | Handled_Stmt_Node : Node_Id; | |
2179 | Parameters : List_Id; | |
2180 | Proc_Spec_Node : Node_Id; | |
2181 | Body_Stmts : List_Id; | |
2182 | Record_Extension_Node : Node_Id; | |
04df6250 | 2183 | Init_Tags_List : List_Id; |
70482933 RK |
2184 | |
2185 | begin | |
2186 | Body_Stmts := New_List; | |
2187 | Body_Node := New_Node (N_Subprogram_Body, Loc); | |
70482933 RK |
2188 | Set_Ekind (Proc_Id, E_Procedure); |
2189 | ||
2190 | Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); | |
2191 | Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); | |
2192 | ||
2193 | Parameters := Init_Formals (Rec_Type); | |
2194 | Append_List_To (Parameters, | |
2195 | Build_Discriminant_Formals (Rec_Type, True)); | |
2196 | ||
2197 | -- For tagged types, we add a flag to indicate whether the routine | |
2198 | -- is called to initialize a parent component in the init_proc of | |
2199 | -- a type extension. If the flag is false, we do not set the tag | |
2200 | -- because it has been set already in the extension. | |
2201 | ||
2202 | if Is_Tagged_Type (Rec_Type) | |
2203 | and then not Is_CPP_Class (Rec_Type) | |
2204 | then | |
2205 | Set_Tag := | |
47cc8d6b ES |
2206 | Make_Defining_Identifier (Loc, |
2207 | Chars => New_Internal_Name ('P')); | |
70482933 RK |
2208 | |
2209 | Append_To (Parameters, | |
2210 | Make_Parameter_Specification (Loc, | |
2211 | Defining_Identifier => Set_Tag, | |
2212 | Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), | |
2213 | Expression => New_Occurrence_Of (Standard_True, Loc))); | |
2214 | end if; | |
2215 | ||
2216 | Set_Parameter_Specifications (Proc_Spec_Node, Parameters); | |
2217 | Set_Specification (Body_Node, Proc_Spec_Node); | |
2218 | Set_Declarations (Body_Node, New_List); | |
2219 | ||
2220 | if Parent_Subtype_Renaming_Discrims then | |
2221 | ||
2222 | -- N is a Derived_Type_Definition that renames the parameters | |
a05e99a2 JM |
2223 | -- of the ancestor type. We initialize it by expanding our |
2224 | -- discriminants and call the ancestor _init_proc with a | |
2225 | -- type-converted object | |
70482933 RK |
2226 | |
2227 | Append_List_To (Body_Stmts, | |
fbf5a39b | 2228 | Build_Init_Call_Thru (Parameters)); |
70482933 RK |
2229 | |
2230 | elsif Nkind (Type_Definition (N)) = N_Record_Definition then | |
2231 | Build_Discriminant_Assignments (Body_Stmts); | |
2232 | ||
2233 | if not Null_Present (Type_Definition (N)) then | |
2234 | Append_List_To (Body_Stmts, | |
2235 | Build_Init_Statements ( | |
2236 | Component_List (Type_Definition (N)))); | |
2237 | end if; | |
2238 | ||
2239 | else | |
2240 | -- N is a Derived_Type_Definition with a possible non-empty | |
2241 | -- extension. The initialization of a type extension consists | |
2242 | -- in the initialization of the components in the extension. | |
2243 | ||
2244 | Build_Discriminant_Assignments (Body_Stmts); | |
2245 | ||
2246 | Record_Extension_Node := | |
2247 | Record_Extension_Part (Type_Definition (N)); | |
2248 | ||
2249 | if not Null_Present (Record_Extension_Node) then | |
2250 | declare | |
fbf5a39b AC |
2251 | Stmts : constant List_Id := |
2252 | Build_Init_Statements ( | |
2253 | Component_List (Record_Extension_Node)); | |
70482933 RK |
2254 | |
2255 | begin | |
2256 | -- The parent field must be initialized first because | |
2257 | -- the offset of the new discriminants may depend on it | |
2258 | ||
2259 | Prepend_To (Body_Stmts, Remove_Head (Stmts)); | |
2260 | Append_List_To (Body_Stmts, Stmts); | |
2261 | end; | |
2262 | end if; | |
2263 | end if; | |
2264 | ||
2265 | -- Add here the assignment to instantiate the Tag | |
2266 | ||
47cc8d6b | 2267 | -- The assignment corresponds to the code: |
70482933 RK |
2268 | |
2269 | -- _Init._Tag := Typ'Tag; | |
2270 | ||
47cc8d6b ES |
2271 | -- Suppress the tag assignment when VM_Target because VM tags are |
2272 | -- represented implicitly in objects. It is also suppressed in case | |
2273 | -- of CPP_Class types because in this case the tag is initialized in | |
2274 | -- the C++ side. | |
70482933 RK |
2275 | |
2276 | if Is_Tagged_Type (Rec_Type) | |
2277 | and then not Is_CPP_Class (Rec_Type) | |
47cc8d6b ES |
2278 | and then VM_Target = No_VM |
2279 | and then not No_Run_Time_Mode | |
70482933 | 2280 | then |
04df6250 TQ |
2281 | -- Initialize the primary tag |
2282 | ||
2283 | Init_Tags_List := New_List ( | |
70482933 RK |
2284 | Make_Assignment_Statement (Loc, |
2285 | Name => | |
2286 | Make_Selected_Component (Loc, | |
2287 | Prefix => Make_Identifier (Loc, Name_uInit), | |
2288 | Selector_Name => | |
a9d8907c | 2289 | New_Reference_To (First_Tag_Component (Rec_Type), Loc)), |
70482933 RK |
2290 | |
2291 | Expression => | |
a9d8907c | 2292 | New_Reference_To |
04df6250 TQ |
2293 | (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); |
2294 | ||
2295 | -- Ada 2005 (AI-251): Initialize the secondary tags components | |
2296 | -- located at fixed positions (tags whose position depends on | |
2297 | -- variable size components are initialized later ---see below). | |
2298 | ||
2299 | if Ada_Version >= Ada_05 | |
2300 | and then not Is_Interface (Rec_Type) | |
ce2b6ba5 | 2301 | and then Has_Interfaces (Rec_Type) |
04df6250 TQ |
2302 | then |
2303 | Init_Secondary_Tags | |
2304 | (Typ => Rec_Type, | |
2305 | Target => Make_Identifier (Loc, Name_uInit), | |
2306 | Stmts_List => Init_Tags_List, | |
2307 | Fixed_Comps => True, | |
2308 | Variable_Comps => False); | |
2309 | end if; | |
70482933 RK |
2310 | |
2311 | -- The tag must be inserted before the assignments to other | |
2312 | -- components, because the initial value of the component may | |
47cc8d6b | 2313 | -- depend on the tag (eg. through a dispatching operation on |
70482933 RK |
2314 | -- an access to the current type). The tag assignment is not done |
2315 | -- when initializing the parent component of a type extension, | |
2316 | -- because in that case the tag is set in the extension. | |
47cc8d6b | 2317 | |
70482933 RK |
2318 | -- Extensions of imported C++ classes add a final complication, |
2319 | -- because we cannot inhibit tag setting in the constructor for | |
2320 | -- the parent. In that case we insert the tag initialization | |
2321 | -- after the calls to initialize the parent. | |
2322 | ||
ae7adb1b | 2323 | if not Is_CPP_Class (Root_Type (Rec_Type)) then |
04df6250 | 2324 | Prepend_To (Body_Stmts, |
3476f949 JM |
2325 | Make_If_Statement (Loc, |
2326 | Condition => New_Occurrence_Of (Set_Tag, Loc), | |
04df6250 | 2327 | Then_Statements => Init_Tags_List)); |
758c442c | 2328 | |
ae7adb1b ES |
2329 | -- CPP_Class derivation: In this case the dispatch table of the |
2330 | -- parent was built in the C++ side and we copy the table of the | |
2331 | -- parent to initialize the new dispatch table. | |
47cc8d6b | 2332 | |
70482933 RK |
2333 | else |
2334 | declare | |
04df6250 | 2335 | Nod : Node_Id; |
70482933 RK |
2336 | |
2337 | begin | |
2338 | -- We assume the first init_proc call is for the parent | |
2339 | ||
04df6250 | 2340 | Nod := First (Body_Stmts); |
70482933 RK |
2341 | while Present (Next (Nod)) |
2342 | and then (Nkind (Nod) /= N_Procedure_Call_Statement | |
fbf5a39b | 2343 | or else not Is_Init_Proc (Name (Nod))) |
70482933 RK |
2344 | loop |
2345 | Nod := Next (Nod); | |
2346 | end loop; | |
2347 | ||
3476f949 JM |
2348 | -- Generate: |
2349 | -- ancestor_constructor (_init.parent); | |
2350 | -- if Arg2 then | |
ea1941af | 2351 | -- inherit_prim_ops (_init._tag, new_dt, num_prims); |
3476f949 JM |
2352 | -- _init._tag := new_dt; |
2353 | -- end if; | |
2354 | ||
04df6250 | 2355 | Prepend_To (Init_Tags_List, |
ea1941af | 2356 | Build_Inherit_Prims (Loc, |
04df6250 | 2357 | Typ => Rec_Type, |
ea1941af ES |
2358 | Old_Tag_Node => |
2359 | Make_Selected_Component (Loc, | |
04df6250 TQ |
2360 | Prefix => |
2361 | Make_Identifier (Loc, | |
2362 | Chars => Name_uInit), | |
ea1941af ES |
2363 | Selector_Name => |
2364 | New_Reference_To | |
2365 | (First_Tag_Component (Rec_Type), Loc)), | |
2366 | New_Tag_Node => | |
2367 | New_Reference_To | |
2368 | (Node (First_Elmt (Access_Disp_Table (Rec_Type))), | |
2369 | Loc), | |
04df6250 | 2370 | Num_Prims => |
ea1941af | 2371 | UI_To_Int |
04df6250 | 2372 | (DT_Entry_Count (First_Tag_Component (Rec_Type))))); |
ea1941af | 2373 | |
04df6250 | 2374 | Insert_After (Nod, |
ea1941af ES |
2375 | Make_If_Statement (Loc, |
2376 | Condition => New_Occurrence_Of (Set_Tag, Loc), | |
04df6250 | 2377 | Then_Statements => Init_Tags_List)); |
ea1941af | 2378 | |
47cc8d6b ES |
2379 | -- We have inherited table of the parent from the CPP side. |
2380 | -- Now we fill the slots associated with Ada primitives. | |
2381 | -- This needs more work to avoid its execution each time | |
2382 | -- an object is initialized??? | |
ea1941af ES |
2383 | |
2384 | declare | |
2385 | E : Elmt_Id; | |
2386 | Prim : Node_Id; | |
3476f949 | 2387 | |
ea1941af ES |
2388 | begin |
2389 | E := First_Elmt (Primitive_Operations (Rec_Type)); | |
2390 | while Present (E) loop | |
2391 | Prim := Node (E); | |
2392 | ||
2393 | if not Is_Imported (Prim) | |
2394 | and then Convention (Prim) = Convention_CPP | |
ce2b6ba5 | 2395 | and then not Present (Interface_Alias (Prim)) |
ea1941af | 2396 | then |
47cc8d6b ES |
2397 | Register_Primitive (Loc, |
2398 | Prim => Prim, | |
04df6250 | 2399 | Ins_Nod => Last (Init_Tags_List)); |
ea1941af | 2400 | end if; |
3476f949 | 2401 | |
ea1941af ES |
2402 | Next_Elmt (E); |
2403 | end loop; | |
2404 | end; | |
70482933 RK |
2405 | end; |
2406 | end if; | |
3476f949 | 2407 | |
04df6250 TQ |
2408 | -- Ada 2005 (AI-251): Initialize the secondary tag components |
2409 | -- located at variable positions. We delay the generation of this | |
2410 | -- code until here because the value of the attribute 'Position | |
2411 | -- applied to variable size components of the parent type that | |
2412 | -- depend on discriminants is only safely read at runtime after | |
2413 | -- the parent components have been initialized. | |
3476f949 | 2414 | |
04df6250 | 2415 | if Ada_Version >= Ada_05 |
3476f949 | 2416 | and then not Is_Interface (Rec_Type) |
ce2b6ba5 | 2417 | and then Has_Interfaces (Rec_Type) |
04df6250 TQ |
2418 | and then Has_Discriminants (Etype (Rec_Type)) |
2419 | and then Is_Variable_Size_Record (Etype (Rec_Type)) | |
3476f949 | 2420 | then |
04df6250 TQ |
2421 | Init_Tags_List := New_List; |
2422 | ||
3476f949 | 2423 | Init_Secondary_Tags |
04df6250 TQ |
2424 | (Typ => Rec_Type, |
2425 | Target => Make_Identifier (Loc, Name_uInit), | |
2426 | Stmts_List => Init_Tags_List, | |
2427 | Fixed_Comps => False, | |
2428 | Variable_Comps => True); | |
2429 | ||
2430 | if Is_Non_Empty_List (Init_Tags_List) then | |
2431 | Append_List_To (Body_Stmts, Init_Tags_List); | |
2432 | end if; | |
3476f949 | 2433 | end if; |
70482933 RK |
2434 | end if; |
2435 | ||
2436 | Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc); | |
2437 | Set_Statements (Handled_Stmt_Node, Body_Stmts); | |
2438 | Set_Exception_Handlers (Handled_Stmt_Node, No_List); | |
2439 | Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); | |
2440 | ||
2441 | if not Debug_Generated_Code then | |
2442 | Set_Debug_Info_Off (Proc_Id); | |
2443 | end if; | |
2444 | ||
2445 | -- Associate Init_Proc with type, and determine if the procedure | |
2446 | -- is null (happens because of the Initialize_Scalars pragma case, | |
2447 | -- where we have to generate a null procedure in case it is called | |
2448 | -- by a client with Initialize_Scalars set). Such procedures have | |
2449 | -- to be generated, but do not have to be called, so we mark them | |
2450 | -- as null to suppress the call. | |
2451 | ||
2452 | Set_Init_Proc (Rec_Type, Proc_Id); | |
2453 | ||
2454 | if List_Length (Body_Stmts) = 1 | |
2455 | and then Nkind (First (Body_Stmts)) = N_Null_Statement | |
47cc8d6b | 2456 | and then VM_Target /= CLI_Target |
70482933 | 2457 | then |
47cc8d6b ES |
2458 | -- Even though the init proc may be null at this time it might get |
2459 | -- some stuff added to it later by the CIL backend, so always keep | |
2460 | -- it when VM_Target = CLI_Target. | |
2461 | ||
70482933 RK |
2462 | Set_Is_Null_Init_Proc (Proc_Id); |
2463 | end if; | |
2464 | end Build_Init_Procedure; | |
2465 | ||
2466 | --------------------------- | |
2467 | -- Build_Init_Statements -- | |
2468 | --------------------------- | |
2469 | ||
2470 | function Build_Init_Statements (Comp_List : Node_Id) return List_Id is | |
fbf5a39b | 2471 | Check_List : constant List_Id := New_List; |
70482933 | 2472 | Alt_List : List_Id; |
c42e6724 HK |
2473 | Decl : Node_Id; |
2474 | Id : Entity_Id; | |
2475 | Names : Node_Id; | |
70482933 RK |
2476 | Statement_List : List_Id; |
2477 | Stmts : List_Id; | |
c42e6724 HK |
2478 | Typ : Entity_Id; |
2479 | Variant : Node_Id; | |
70482933 RK |
2480 | |
2481 | Per_Object_Constraint_Components : Boolean; | |
2482 | ||
5d09245e AC |
2483 | function Has_Access_Constraint (E : Entity_Id) return Boolean; |
2484 | -- Components with access discriminants that depend on the current | |
2485 | -- instance must be initialized after all other components. | |
2486 | ||
2487 | --------------------------- | |
2488 | -- Has_Access_Constraint -- | |
2489 | --------------------------- | |
2490 | ||
2491 | function Has_Access_Constraint (E : Entity_Id) return Boolean is | |
2492 | Disc : Entity_Id; | |
2493 | T : constant Entity_Id := Etype (E); | |
2494 | ||
2495 | begin | |
2496 | if Has_Per_Object_Constraint (E) | |
2497 | and then Has_Discriminants (T) | |
2498 | then | |
2499 | Disc := First_Discriminant (T); | |
2500 | while Present (Disc) loop | |
2501 | if Is_Access_Type (Etype (Disc)) then | |
2502 | return True; | |
2503 | end if; | |
2504 | ||
2505 | Next_Discriminant (Disc); | |
2506 | end loop; | |
2507 | ||
2508 | return False; | |
2509 | else | |
2510 | return False; | |
2511 | end if; | |
2512 | end Has_Access_Constraint; | |
2513 | ||
2514 | -- Start of processing for Build_Init_Statements | |
2515 | ||
70482933 RK |
2516 | begin |
2517 | if Null_Present (Comp_List) then | |
2518 | return New_List (Make_Null_Statement (Loc)); | |
2519 | end if; | |
2520 | ||
2521 | Statement_List := New_List; | |
2522 | ||
2523 | -- Loop through components, skipping pragmas, in 2 steps. The first | |
2524 | -- step deals with regular components. The second step deals with | |
2525 | -- components have per object constraints, and no explicit initia- | |
2526 | -- lization. | |
2527 | ||
2528 | Per_Object_Constraint_Components := False; | |
2529 | ||
5d09245e | 2530 | -- First step : regular components |
70482933 RK |
2531 | |
2532 | Decl := First_Non_Pragma (Component_Items (Comp_List)); | |
2533 | while Present (Decl) loop | |
2534 | Loc := Sloc (Decl); | |
a397db96 AC |
2535 | Build_Record_Checks |
2536 | (Subtype_Indication (Component_Definition (Decl)), Check_List); | |
70482933 RK |
2537 | |
2538 | Id := Defining_Identifier (Decl); | |
2539 | Typ := Etype (Id); | |
2540 | ||
5d09245e | 2541 | if Has_Access_Constraint (Id) |
70482933 RK |
2542 | and then No (Expression (Decl)) |
2543 | then | |
2544 | -- Skip processing for now and ask for a second pass | |
2545 | ||
2546 | Per_Object_Constraint_Components := True; | |
fbf5a39b | 2547 | |
70482933 | 2548 | else |
fbf5a39b AC |
2549 | -- Case of explicit initialization |
2550 | ||
70482933 RK |
2551 | if Present (Expression (Decl)) then |
2552 | Stmts := Build_Assignment (Id, Expression (Decl)); | |
2553 | ||
fbf5a39b AC |
2554 | -- Case of composite component with its own Init_Proc |
2555 | ||
4d744221 JM |
2556 | elsif not Is_Interface (Typ) |
2557 | and then Has_Non_Null_Base_Init_Proc (Typ) | |
2558 | then | |
70482933 | 2559 | Stmts := |
fbf5a39b AC |
2560 | Build_Initialization_Call |
2561 | (Loc, | |
2562 | Make_Selected_Component (Loc, | |
2563 | Prefix => Make_Identifier (Loc, Name_uInit), | |
2564 | Selector_Name => New_Occurrence_Of (Id, Loc)), | |
2565 | Typ, | |
ea1941af ES |
2566 | In_Init_Proc => True, |
2567 | Enclos_Type => Rec_Type, | |
fbf5a39b AC |
2568 | Discr_Map => Discr_Map); |
2569 | ||
3476f949 JM |
2570 | Clean_Task_Names (Typ, Proc_Id); |
2571 | ||
fbf5a39b | 2572 | -- Case of component needing simple initialization |
70482933 RK |
2573 | |
2574 | elsif Component_Needs_Simple_Initialization (Typ) then | |
2575 | Stmts := | |
82c80734 | 2576 | Build_Assignment |
f2cbd970 | 2577 | (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))); |
70482933 | 2578 | |
fbf5a39b AC |
2579 | -- Nothing needed for this case |
2580 | ||
70482933 RK |
2581 | else |
2582 | Stmts := No_List; | |
2583 | end if; | |
2584 | ||
2585 | if Present (Check_List) then | |
2586 | Append_List_To (Statement_List, Check_List); | |
2587 | end if; | |
2588 | ||
2589 | if Present (Stmts) then | |
2590 | ||
fbf5a39b AC |
2591 | -- Add the initialization of the record controller before |
2592 | -- the _Parent field is attached to it when the attachment | |
2593 | -- can occur. It does not work to simply initialize the | |
2594 | -- controller first: it must be initialized after the parent | |
47cc8d6b ES |
2595 | -- if the parent holds discriminants that can be used to |
2596 | -- compute the offset of the controller. We assume here that | |
2597 | -- the last statement of the initialization call is the | |
ea1941af | 2598 | -- attachment of the parent (see Build_Initialization_Call) |
70482933 RK |
2599 | |
2600 | if Chars (Id) = Name_uController | |
2601 | and then Rec_Type /= Etype (Rec_Type) | |
2602 | and then Has_Controlled_Component (Etype (Rec_Type)) | |
2603 | and then Has_New_Controlled_Component (Rec_Type) | |
47cc8d6b | 2604 | and then Present (Last (Statement_List)) |
70482933 RK |
2605 | then |
2606 | Insert_List_Before (Last (Statement_List), Stmts); | |
2607 | else | |
2608 | Append_List_To (Statement_List, Stmts); | |
2609 | end if; | |
2610 | end if; | |
2611 | end if; | |
2612 | ||
2613 | Next_Non_Pragma (Decl); | |
2614 | end loop; | |
2615 | ||
2616 | if Per_Object_Constraint_Components then | |
2617 | ||
2618 | -- Second pass: components with per-object constraints | |
2619 | ||
2620 | Decl := First_Non_Pragma (Component_Items (Comp_List)); | |
70482933 RK |
2621 | while Present (Decl) loop |
2622 | Loc := Sloc (Decl); | |
2623 | Id := Defining_Identifier (Decl); | |
2624 | Typ := Etype (Id); | |
2625 | ||
5d09245e | 2626 | if Has_Access_Constraint (Id) |
70482933 RK |
2627 | and then No (Expression (Decl)) |
2628 | then | |
2629 | if Has_Non_Null_Base_Init_Proc (Typ) then | |
2630 | Append_List_To (Statement_List, | |
2631 | Build_Initialization_Call (Loc, | |
2632 | Make_Selected_Component (Loc, | |
ea1941af | 2633 | Prefix => Make_Identifier (Loc, Name_uInit), |
70482933 | 2634 | Selector_Name => New_Occurrence_Of (Id, Loc)), |
ea1941af ES |
2635 | Typ, |
2636 | In_Init_Proc => True, | |
2637 | Enclos_Type => Rec_Type, | |
2638 | Discr_Map => Discr_Map)); | |
70482933 | 2639 | |
3476f949 JM |
2640 | Clean_Task_Names (Typ, Proc_Id); |
2641 | ||
70482933 RK |
2642 | elsif Component_Needs_Simple_Initialization (Typ) then |
2643 | Append_List_To (Statement_List, | |
82c80734 | 2644 | Build_Assignment |
f2cbd970 | 2645 | (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)))); |
70482933 RK |
2646 | end if; |
2647 | end if; | |
2648 | ||
2649 | Next_Non_Pragma (Decl); | |
2650 | end loop; | |
2651 | end if; | |
2652 | ||
2653 | -- Process the variant part | |
2654 | ||
2655 | if Present (Variant_Part (Comp_List)) then | |
2656 | Alt_List := New_List; | |
2657 | Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); | |
70482933 RK |
2658 | while Present (Variant) loop |
2659 | Loc := Sloc (Variant); | |
2660 | Append_To (Alt_List, | |
2661 | Make_Case_Statement_Alternative (Loc, | |
2662 | Discrete_Choices => | |
2663 | New_Copy_List (Discrete_Choices (Variant)), | |
2664 | Statements => | |
2665 | Build_Init_Statements (Component_List (Variant)))); | |
70482933 RK |
2666 | Next_Non_Pragma (Variant); |
2667 | end loop; | |
2668 | ||
2669 | -- The expression of the case statement which is a reference | |
2670 | -- to one of the discriminants is replaced by the appropriate | |
2671 | -- formal parameter of the initialization procedure. | |
2672 | ||
2673 | Append_To (Statement_List, | |
2674 | Make_Case_Statement (Loc, | |
2675 | Expression => | |
2676 | New_Reference_To (Discriminal ( | |
2677 | Entity (Name (Variant_Part (Comp_List)))), Loc), | |
2678 | Alternatives => Alt_List)); | |
2679 | end if; | |
2680 | ||
2681 | -- For a task record type, add the task create call and calls | |
2682 | -- to bind any interrupt (signal) entries. | |
2683 | ||
2684 | if Is_Task_Record_Type (Rec_Type) then | |
523456db AC |
2685 | |
2686 | -- In the case of the restricted run time the ATCB has already | |
2687 | -- been preallocated. | |
2688 | ||
2689 | if Restricted_Profile then | |
2690 | Append_To (Statement_List, | |
2691 | Make_Assignment_Statement (Loc, | |
2692 | Name => Make_Selected_Component (Loc, | |
2693 | Prefix => Make_Identifier (Loc, Name_uInit), | |
2694 | Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), | |
2695 | Expression => Make_Attribute_Reference (Loc, | |
2696 | Prefix => | |
2697 | Make_Selected_Component (Loc, | |
2698 | Prefix => Make_Identifier (Loc, Name_uInit), | |
2699 | Selector_Name => | |
2700 | Make_Identifier (Loc, Name_uATCB)), | |
2701 | Attribute_Name => Name_Unchecked_Access))); | |
2702 | end if; | |
2703 | ||
70482933 RK |
2704 | Append_To (Statement_List, Make_Task_Create_Call (Rec_Type)); |
2705 | ||
c42e6724 HK |
2706 | -- Generate the statements which map a string entry name to a |
2707 | -- task entry index. Note that the task may not have entries. | |
2708 | ||
2709 | if Entry_Names_OK then | |
2710 | Names := Build_Entry_Names (Rec_Type); | |
2711 | ||
2712 | if Present (Names) then | |
2713 | Append_To (Statement_List, Names); | |
2714 | end if; | |
2715 | end if; | |
2716 | ||
70482933 RK |
2717 | declare |
2718 | Task_Type : constant Entity_Id := | |
2719 | Corresponding_Concurrent_Type (Rec_Type); | |
2720 | Task_Decl : constant Node_Id := Parent (Task_Type); | |
2721 | Task_Def : constant Node_Id := Task_Definition (Task_Decl); | |
2722 | Vis_Decl : Node_Id; | |
2723 | Ent : Entity_Id; | |
2724 | ||
2725 | begin | |
2726 | if Present (Task_Def) then | |
2727 | Vis_Decl := First (Visible_Declarations (Task_Def)); | |
2728 | while Present (Vis_Decl) loop | |
2729 | Loc := Sloc (Vis_Decl); | |
2730 | ||
2731 | if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then | |
2732 | if Get_Attribute_Id (Chars (Vis_Decl)) = | |
2733 | Attribute_Address | |
2734 | then | |
2735 | Ent := Entity (Name (Vis_Decl)); | |
2736 | ||
2737 | if Ekind (Ent) = E_Entry then | |
2738 | Append_To (Statement_List, | |
2739 | Make_Procedure_Call_Statement (Loc, | |
2740 | Name => New_Reference_To ( | |
2741 | RTE (RE_Bind_Interrupt_To_Entry), Loc), | |
2742 | Parameter_Associations => New_List ( | |
2743 | Make_Selected_Component (Loc, | |
2744 | Prefix => | |
2745 | Make_Identifier (Loc, Name_uInit), | |
2746 | Selector_Name => | |
2747 | Make_Identifier (Loc, Name_uTask_Id)), | |
2748 | Entry_Index_Expression ( | |
2749 | Loc, Ent, Empty, Task_Type), | |
2750 | Expression (Vis_Decl)))); | |
2751 | end if; | |
2752 | end if; | |
2753 | end if; | |
2754 | ||
2755 | Next (Vis_Decl); | |
2756 | end loop; | |
2757 | end if; | |
2758 | end; | |
2759 | end if; | |
2760 | ||
2761 | -- For a protected type, add statements generated by | |
2762 | -- Make_Initialize_Protection. | |
2763 | ||
2764 | if Is_Protected_Record_Type (Rec_Type) then | |
2765 | Append_List_To (Statement_List, | |
2766 | Make_Initialize_Protection (Rec_Type)); | |
c42e6724 HK |
2767 | |
2768 | -- Generate the statements which map a string entry name to a | |
2769 | -- protected entry index. Note that the protected type may not | |
2770 | -- have entries. | |
2771 | ||
2772 | if Entry_Names_OK then | |
2773 | Names := Build_Entry_Names (Rec_Type); | |
2774 | ||
2775 | if Present (Names) then | |
2776 | Append_To (Statement_List, Names); | |
2777 | end if; | |
2778 | end if; | |
70482933 RK |
2779 | end if; |
2780 | ||
2781 | -- If no initializations when generated for component declarations | |
2782 | -- corresponding to this Statement_List, append a null statement | |
2783 | -- to the Statement_List to make it a valid Ada tree. | |
2784 | ||
2785 | if Is_Empty_List (Statement_List) then | |
2786 | Append (New_Node (N_Null_Statement, Loc), Statement_List); | |
2787 | end if; | |
2788 | ||
2789 | return Statement_List; | |
fbf5a39b AC |
2790 | |
2791 | exception | |
2792 | when RE_Not_Available => | |
2793 | return Empty_List; | |
70482933 RK |
2794 | end Build_Init_Statements; |
2795 | ||
2796 | ------------------------- | |
2797 | -- Build_Record_Checks -- | |
2798 | ------------------------- | |
2799 | ||
07fc65c4 | 2800 | procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is |
70482933 | 2801 | Subtype_Mark_Id : Entity_Id; |
70482933 | 2802 | |
07fc65c4 | 2803 | begin |
70482933 RK |
2804 | if Nkind (S) = N_Subtype_Indication then |
2805 | Find_Type (Subtype_Mark (S)); | |
70482933 RK |
2806 | Subtype_Mark_Id := Entity (Subtype_Mark (S)); |
2807 | ||
2808 | -- Remaining processing depends on type | |
2809 | ||
2810 | case Ekind (Subtype_Mark_Id) is | |
2811 | ||
2812 | when Array_Kind => | |
07fc65c4 | 2813 | Constrain_Array (S, Check_List); |
70482933 RK |
2814 | |
2815 | when others => | |
2816 | null; | |
2817 | end case; | |
2818 | end if; | |
70482933 RK |
2819 | end Build_Record_Checks; |
2820 | ||
2821 | ------------------------------------------- | |
2822 | -- Component_Needs_Simple_Initialization -- | |
2823 | ------------------------------------------- | |
2824 | ||
2825 | function Component_Needs_Simple_Initialization | |
2e071734 | 2826 | (T : Entity_Id) return Boolean |
70482933 RK |
2827 | is |
2828 | begin | |
2829 | return | |
2830 | Needs_Simple_Initialization (T) | |
2831 | and then not Is_RTE (T, RE_Tag) | |
a05e99a2 JM |
2832 | |
2833 | -- Ada 2005 (AI-251): Check also the tag of abstract interfaces | |
2834 | ||
2835 | and then not Is_RTE (T, RE_Interface_Tag); | |
70482933 RK |
2836 | end Component_Needs_Simple_Initialization; |
2837 | ||
2838 | --------------------- | |
2839 | -- Constrain_Array -- | |
2840 | --------------------- | |
2841 | ||
2842 | procedure Constrain_Array | |
2843 | (SI : Node_Id; | |
70482933 RK |
2844 | Check_List : List_Id) |
2845 | is | |
2846 | C : constant Node_Id := Constraint (SI); | |
2847 | Number_Of_Constraints : Nat := 0; | |
2848 | Index : Node_Id; | |
2849 | S, T : Entity_Id; | |
2850 | ||
2851 | begin | |
2852 | T := Entity (Subtype_Mark (SI)); | |
2853 | ||
2854 | if Ekind (T) in Access_Kind then | |
2855 | T := Designated_Type (T); | |
2856 | end if; | |
2857 | ||
2858 | S := First (Constraints (C)); | |
2859 | ||
2860 | while Present (S) loop | |
2861 | Number_Of_Constraints := Number_Of_Constraints + 1; | |
2862 | Next (S); | |
2863 | end loop; | |
2864 | ||
2865 | -- In either case, the index constraint must provide a discrete | |
2866 | -- range for each index of the array type and the type of each | |
2867 | -- discrete range must be the same as that of the corresponding | |
2868 | -- index. (RM 3.6.1) | |
2869 | ||
2870 | S := First (Constraints (C)); | |
2871 | Index := First_Index (T); | |
2872 | Analyze (Index); | |
2873 | ||
2874 | -- Apply constraints to each index type | |
2875 | ||
2876 | for J in 1 .. Number_Of_Constraints loop | |
07fc65c4 | 2877 | Constrain_Index (Index, S, Check_List); |
70482933 RK |
2878 | Next (Index); |
2879 | Next (S); | |
2880 | end loop; | |
2881 | ||
2882 | end Constrain_Array; | |
2883 | ||
2884 | --------------------- | |
2885 | -- Constrain_Index -- | |
2886 | --------------------- | |
2887 | ||
2888 | procedure Constrain_Index | |
2889 | (Index : Node_Id; | |
2890 | S : Node_Id; | |
70482933 RK |
2891 | Check_List : List_Id) |
2892 | is | |
2893 | T : constant Entity_Id := Etype (Index); | |
2894 | ||
2895 | begin | |
2896 | if Nkind (S) = N_Range then | |
07fc65c4 | 2897 | Process_Range_Expr_In_Decl (S, T, Check_List); |
70482933 RK |
2898 | end if; |
2899 | end Constrain_Index; | |
2900 | ||
2901 | -------------------------------------- | |
2902 | -- Parent_Subtype_Renaming_Discrims -- | |
2903 | -------------------------------------- | |
2904 | ||
2905 | function Parent_Subtype_Renaming_Discrims return Boolean is | |
2906 | De : Entity_Id; | |
2907 | Dp : Entity_Id; | |
2908 | ||
2909 | begin | |
2910 | if Base_Type (Pe) /= Pe then | |
2911 | return False; | |
2912 | end if; | |
2913 | ||
2914 | if Etype (Pe) = Pe | |
2915 | or else not Has_Discriminants (Pe) | |
2916 | or else Is_Constrained (Pe) | |
2917 | or else Is_Tagged_Type (Pe) | |
2918 | then | |
2919 | return False; | |
2920 | end if; | |
2921 | ||
fbf5a39b | 2922 | -- If there are no explicit stored discriminants we have inherited |
70482933 RK |
2923 | -- the root type discriminants so far, so no renamings occurred. |
2924 | ||
fbf5a39b | 2925 | if First_Discriminant (Pe) = First_Stored_Discriminant (Pe) then |
70482933 RK |
2926 | return False; |
2927 | end if; | |
2928 | ||
2929 | -- Check if we have done some trivial renaming of the parent | |
47cc8d6b | 2930 | -- discriminants, i.e. something like |
70482933 RK |
2931 | -- |
2932 | -- type DT (X1,X2: int) is new PT (X1,X2); | |
2933 | ||
2934 | De := First_Discriminant (Pe); | |
2935 | Dp := First_Discriminant (Etype (Pe)); | |
2936 | ||
2937 | while Present (De) loop | |
2938 | pragma Assert (Present (Dp)); | |
2939 | ||
2940 | if Corresponding_Discriminant (De) /= Dp then | |
2941 | return True; | |
2942 | end if; | |
2943 | ||
2944 | Next_Discriminant (De); | |
2945 | Next_Discriminant (Dp); | |
2946 | end loop; | |
2947 | ||
2948 | return Present (Dp); | |
2949 | end Parent_Subtype_Renaming_Discrims; | |
2950 | ||
2951 | ------------------------ | |
2952 | -- Requires_Init_Proc -- | |
2953 | ------------------------ | |
2954 | ||
2955 | function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is | |
2956 | Comp_Decl : Node_Id; | |
2957 | Id : Entity_Id; | |
2958 | Typ : Entity_Id; | |
2959 | ||
2960 | begin | |
2961 | -- Definitely do not need one if specifically suppressed | |
2962 | ||
2963 | if Suppress_Init_Proc (Rec_Id) then | |
2964 | return False; | |
2965 | end if; | |
2966 | ||
f4d379b8 HK |
2967 | -- If it is a type derived from a type with unknown discriminants, |
2968 | -- we cannot build an initialization procedure for it. | |
2969 | ||
2970 | if Has_Unknown_Discriminants (Rec_Id) then | |
2971 | return False; | |
2972 | end if; | |
2973 | ||
70482933 RK |
2974 | -- Otherwise we need to generate an initialization procedure if |
2975 | -- Is_CPP_Class is False and at least one of the following applies: | |
2976 | ||
2977 | -- 1. Discriminants are present, since they need to be initialized | |
2978 | -- with the appropriate discriminant constraint expressions. | |
2979 | -- However, the discriminant of an unchecked union does not | |
2980 | -- count, since the discriminant is not present. | |
2981 | ||
2982 | -- 2. The type is a tagged type, since the implicit Tag component | |
2983 | -- needs to be initialized with a pointer to the dispatch table. | |
2984 | ||
2985 | -- 3. The type contains tasks | |
2986 | ||
2987 | -- 4. One or more components has an initial value | |
2988 | ||
2989 | -- 5. One or more components is for a type which itself requires | |
2990 | -- an initialization procedure. | |
2991 | ||
2992 | -- 6. One or more components is a type that requires simple | |
2993 | -- initialization (see Needs_Simple_Initialization), except | |
758c442c | 2994 | -- that types Tag and Interface_Tag are excluded, since fields |
70482933 RK |
2995 | -- of these types are initialized by other means. |
2996 | ||
2997 | -- 7. The type is the record type built for a task type (since at | |
2998 | -- the very least, Create_Task must be called) | |
2999 | ||
3000 | -- 8. The type is the record type built for a protected type (since | |
3001 | -- at least Initialize_Protection must be called) | |
3002 | ||
3003 | -- 9. The type is marked as a public entity. The reason we add this | |
3004 | -- case (even if none of the above apply) is to properly handle | |
3005 | -- Initialize_Scalars. If a package is compiled without an IS | |
3006 | -- pragma, and the client is compiled with an IS pragma, then | |
3007 | -- the client will think an initialization procedure is present | |
3008 | -- and call it, when in fact no such procedure is required, but | |
3009 | -- since the call is generated, there had better be a routine | |
3010 | -- at the other end of the call, even if it does nothing!) | |
3011 | ||
a05e99a2 JM |
3012 | -- Note: the reason we exclude the CPP_Class case is because in this |
3013 | -- case the initialization is performed in the C++ side. | |
70482933 RK |
3014 | |
3015 | if Is_CPP_Class (Rec_Id) then | |
3016 | return False; | |
3017 | ||
47cc8d6b ES |
3018 | elsif Is_Interface (Rec_Id) then |
3019 | return False; | |
3020 | ||
6e937c1c | 3021 | elsif not Restriction_Active (No_Initialize_Scalars) |
fbf5a39b AC |
3022 | and then Is_Public (Rec_Id) |
3023 | then | |
70482933 RK |
3024 | return True; |
3025 | ||
3026 | elsif (Has_Discriminants (Rec_Id) | |
3027 | and then not Is_Unchecked_Union (Rec_Id)) | |
3028 | or else Is_Tagged_Type (Rec_Id) | |
3029 | or else Is_Concurrent_Record_Type (Rec_Id) | |
3030 | or else Has_Task (Rec_Id) | |
3031 | then | |
3032 | return True; | |
3033 | end if; | |
3034 | ||
3035 | Id := First_Component (Rec_Id); | |
70482933 RK |
3036 | while Present (Id) loop |
3037 | Comp_Decl := Parent (Id); | |
3038 | Typ := Etype (Id); | |
3039 | ||
3040 | if Present (Expression (Comp_Decl)) | |
3041 | or else Has_Non_Null_Base_Init_Proc (Typ) | |
3042 | or else Component_Needs_Simple_Initialization (Typ) | |
3043 | then | |
3044 | return True; | |
3045 | end if; | |
3046 | ||
3047 | Next_Component (Id); | |
3048 | end loop; | |
3049 | ||
3050 | return False; | |
3051 | end Requires_Init_Proc; | |
3052 | ||
3053 | -- Start of processing for Build_Record_Init_Proc | |
3054 | ||
3055 | begin | |
f2cbd970 JM |
3056 | -- Check for value type, which means no initialization required |
3057 | ||
70482933 RK |
3058 | Rec_Type := Defining_Identifier (N); |
3059 | ||
47cc8d6b ES |
3060 | if Is_Value_Type (Rec_Type) then |
3061 | return; | |
3062 | end if; | |
3063 | ||
70482933 RK |
3064 | -- This may be full declaration of a private type, in which case |
3065 | -- the visible entity is a record, and the private entity has been | |
3066 | -- exchanged with it in the private part of the current package. | |
3067 | -- The initialization procedure is built for the record type, which | |
3068 | -- is retrievable from the private entity. | |
3069 | ||
3070 | if Is_Incomplete_Or_Private_Type (Rec_Type) then | |
3071 | Rec_Type := Underlying_Type (Rec_Type); | |
3072 | end if; | |
3073 | ||
3074 | -- If there are discriminants, build the discriminant map to replace | |
3075 | -- discriminants by their discriminals in complex bound expressions. | |
3076 | -- These only arise for the corresponding records of protected types. | |
3077 | ||
3078 | if Is_Concurrent_Record_Type (Rec_Type) | |
3079 | and then Has_Discriminants (Rec_Type) | |
3080 | then | |
3081 | declare | |
3082 | Disc : Entity_Id; | |
70482933 RK |
3083 | begin |
3084 | Disc := First_Discriminant (Rec_Type); | |
70482933 RK |
3085 | while Present (Disc) loop |
3086 | Append_Elmt (Disc, Discr_Map); | |
3087 | Append_Elmt (Discriminal (Disc), Discr_Map); | |
3088 | Next_Discriminant (Disc); | |
3089 | end loop; | |
3090 | end; | |
3091 | end if; | |
3092 | ||
3093 | -- Derived types that have no type extension can use the initialization | |
3094 | -- procedure of their parent and do not need a procedure of their own. | |
3095 | -- This is only correct if there are no representation clauses for the | |
3096 | -- type or its parent, and if the parent has in fact been frozen so | |
3097 | -- that its initialization procedure exists. | |
3098 | ||
3099 | if Is_Derived_Type (Rec_Type) | |
3100 | and then not Is_Tagged_Type (Rec_Type) | |
5d09245e | 3101 | and then not Is_Unchecked_Union (Rec_Type) |
70482933 RK |
3102 | and then not Has_New_Non_Standard_Rep (Rec_Type) |
3103 | and then not Parent_Subtype_Renaming_Discrims | |
3104 | and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type)) | |
3105 | then | |
3106 | Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type); | |
3107 | ||
3108 | -- Otherwise if we need an initialization procedure, then build one, | |
3109 | -- mark it as public and inlinable and as having a completion. | |
3110 | ||
5d09245e AC |
3111 | elsif Requires_Init_Proc (Rec_Type) |
3112 | or else Is_Unchecked_Union (Rec_Type) | |
3113 | then | |
f2cbd970 JM |
3114 | Proc_Id := |
3115 | Make_Defining_Identifier (Loc, | |
3116 | Chars => Make_Init_Proc_Name (Rec_Type)); | |
3117 | ||
3118 | -- If No_Default_Initialization restriction is active, then we don't | |
3119 | -- want to build an init_proc, but we need to mark that an init_proc | |
3120 | -- would be needed if this restriction was not active (so that we can | |
3121 | -- detect attempts to call it), so set a dummy init_proc in place. | |
3122 | ||
3123 | if Restriction_Active (No_Default_Initialization) then | |
3124 | Set_Init_Proc (Rec_Type, Proc_Id); | |
3125 | return; | |
3126 | end if; | |
3127 | ||
a05e99a2 | 3128 | Build_Offset_To_Top_Functions; |
70482933 RK |
3129 | Build_Init_Procedure; |
3130 | Set_Is_Public (Proc_Id, Is_Public (Pe)); | |
3131 | ||
3132 | -- The initialization of protected records is not worth inlining. | |
3133 | -- In addition, when compiled for another unit for inlining purposes, | |
3134 | -- it may make reference to entities that have not been elaborated | |
3135 | -- yet. The initialization of controlled records contains a nested | |
3136 | -- clean-up procedure that makes it impractical to inline as well, | |
3137 | -- and leads to undefined symbols if inlined in a different unit. | |
07fc65c4 | 3138 | -- Similar considerations apply to task types. |
70482933 | 3139 | |
07fc65c4 GB |
3140 | if not Is_Concurrent_Type (Rec_Type) |
3141 | and then not Has_Task (Rec_Type) | |
70482933 RK |
3142 | and then not Controlled_Type (Rec_Type) |
3143 | then | |
3144 | Set_Is_Inlined (Proc_Id); | |
3145 | end if; | |
3146 | ||
3147 | Set_Is_Internal (Proc_Id); | |
3148 | Set_Has_Completion (Proc_Id); | |
3149 | ||
3150 | if not Debug_Generated_Code then | |
3151 | Set_Debug_Info_Off (Proc_Id); | |
3152 | end if; | |
47cc8d6b | 3153 | |
55d4e6c0 ES |
3154 | declare |
3155 | Agg : constant Node_Id := | |
3156 | Build_Equivalent_Record_Aggregate (Rec_Type); | |
3157 | ||
3158 | procedure Collect_Itypes (Comp : Node_Id); | |
3159 | -- Generate references to itypes in the aggregate, because | |
3160 | -- the first use of the aggregate may be in a nested scope. | |
3161 | ||
3162 | -------------------- | |
3163 | -- Collect_Itypes -- | |
3164 | -------------------- | |
3165 | ||
3166 | procedure Collect_Itypes (Comp : Node_Id) is | |
3167 | Ref : Node_Id; | |
3168 | Sub_Aggr : Node_Id; | |
f2cbd970 | 3169 | Typ : constant Entity_Id := Etype (Comp); |
55d4e6c0 ES |
3170 | |
3171 | begin | |
f2cbd970 JM |
3172 | if Is_Array_Type (Typ) |
3173 | and then Is_Itype (Typ) | |
55d4e6c0 | 3174 | then |
55d4e6c0 ES |
3175 | Ref := Make_Itype_Reference (Loc); |
3176 | Set_Itype (Ref, Typ); | |
3177 | Append_Freeze_Action (Rec_Type, Ref); | |
3178 | ||
3179 | Ref := Make_Itype_Reference (Loc); | |
3180 | Set_Itype (Ref, Etype (First_Index (Typ))); | |
3181 | Append_Freeze_Action (Rec_Type, Ref); | |
3182 | ||
3183 | Sub_Aggr := First (Expressions (Comp)); | |
3184 | ||
3185 | -- Recurse on nested arrays | |
3186 | ||
3187 | while Present (Sub_Aggr) loop | |
3188 | Collect_Itypes (Sub_Aggr); | |
3189 | Next (Sub_Aggr); | |
3190 | end loop; | |
3191 | end if; | |
3192 | end Collect_Itypes; | |
3193 | ||
3194 | begin | |
3195 | -- If there is a static initialization aggregate for the type, | |
3196 | -- generate itype references for the types of its (sub)components, | |
3197 | -- to prevent out-of-scope errors in the resulting tree. | |
3198 | -- The aggregate may have been rewritten as a Raise node, in which | |
3199 | -- case there are no relevant itypes. | |
3200 | ||
3201 | if Present (Agg) | |
3202 | and then Nkind (Agg) = N_Aggregate | |
3203 | then | |
3204 | Set_Static_Initialization (Proc_Id, Agg); | |
3205 | ||
3206 | declare | |
3207 | Comp : Node_Id; | |
3208 | begin | |
3209 | Comp := First (Component_Associations (Agg)); | |
3210 | while Present (Comp) loop | |
3211 | Collect_Itypes (Expression (Comp)); | |
3212 | Next (Comp); | |
3213 | end loop; | |
3214 | end; | |
3215 | end if; | |
3216 | end; | |
70482933 RK |
3217 | end if; |
3218 | end Build_Record_Init_Proc; | |
3219 | ||
26fd4eae AC |
3220 | ---------------------------- |
3221 | -- Build_Slice_Assignment -- | |
3222 | ---------------------------- | |
3223 | ||
3224 | -- Generates the following subprogram: | |
6e937c1c | 3225 | |
26fd4eae | 3226 | -- procedure Assign |
47cc8d6b ES |
3227 | -- (Source, Target : Array_Type, |
3228 | -- Left_Lo, Left_Hi : Index; | |
3229 | -- Right_Lo, Right_Hi : Index; | |
3230 | -- Rev : Boolean) | |
26fd4eae AC |
3231 | -- is |
3232 | -- Li1 : Index; | |
3233 | -- Ri1 : Index; | |
6e937c1c | 3234 | |
26fd4eae | 3235 | -- begin |
f2cbd970 JM |
3236 | |
3237 | -- if Left_Hi < Left_Lo then | |
3238 | -- return; | |
3239 | -- end if; | |
3240 | ||
26fd4eae AC |
3241 | -- if Rev then |
3242 | -- Li1 := Left_Hi; | |
3243 | -- Ri1 := Right_Hi; | |
3244 | -- else | |
3245 | -- Li1 := Left_Lo; | |
3246 | -- Ri1 := Right_Lo; | |
3247 | -- end if; | |
6e937c1c | 3248 | |
26fd4eae | 3249 | -- loop |
47cc8d6b ES |
3250 | -- Target (Li1) := Source (Ri1); |
3251 | ||
3252 | -- if Rev then | |
f2cbd970 | 3253 | -- exit when Li1 = Left_Lo; |
47cc8d6b ES |
3254 | -- Li1 := Index'pred (Li1); |
3255 | -- Ri1 := Index'pred (Ri1); | |
3256 | -- else | |
f2cbd970 | 3257 | -- exit when Li1 = Left_Hi; |
47cc8d6b ES |
3258 | -- Li1 := Index'succ (Li1); |
3259 | -- Ri1 := Index'succ (Ri1); | |
3260 | -- end if; | |
26fd4eae AC |
3261 | -- end loop; |
3262 | -- end Assign; | |
3263 | ||
3264 | procedure Build_Slice_Assignment (Typ : Entity_Id) is | |
3265 | Loc : constant Source_Ptr := Sloc (Typ); | |
3266 | Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); | |
3267 | ||
3268 | -- Build formal parameters of procedure | |
3269 | ||
3270 | Larray : constant Entity_Id := | |
3271 | Make_Defining_Identifier | |
3272 | (Loc, Chars => New_Internal_Name ('A')); | |
3273 | Rarray : constant Entity_Id := | |
3274 | Make_Defining_Identifier | |
3275 | (Loc, Chars => New_Internal_Name ('R')); | |
3276 | Left_Lo : constant Entity_Id := | |
3277 | Make_Defining_Identifier | |
3278 | (Loc, Chars => New_Internal_Name ('L')); | |
3279 | Left_Hi : constant Entity_Id := | |
3280 | Make_Defining_Identifier | |
3281 | (Loc, Chars => New_Internal_Name ('L')); | |
3282 | Right_Lo : constant Entity_Id := | |
3283 | Make_Defining_Identifier | |
3284 | (Loc, Chars => New_Internal_Name ('R')); | |
3285 | Right_Hi : constant Entity_Id := | |
3286 | Make_Defining_Identifier | |
3287 | (Loc, Chars => New_Internal_Name ('R')); | |
3288 | Rev : constant Entity_Id := | |
3289 | Make_Defining_Identifier | |
3290 | (Loc, Chars => New_Internal_Name ('D')); | |
3291 | Proc_Name : constant Entity_Id := | |
3292 | Make_Defining_Identifier (Loc, | |
3293 | Chars => Make_TSS_Name (Typ, TSS_Slice_Assign)); | |
3294 | ||
6e937c1c AC |
3295 | Lnn : constant Entity_Id := |
3296 | Make_Defining_Identifier (Loc, New_Internal_Name ('L')); | |
3297 | Rnn : constant Entity_Id := | |
3298 | Make_Defining_Identifier (Loc, New_Internal_Name ('R')); | |
3299 | -- Subscripts for left and right sides | |
26fd4eae | 3300 | |
6e937c1c AC |
3301 | Decls : List_Id; |
3302 | Loops : Node_Id; | |
3303 | Stats : List_Id; | |
26fd4eae AC |
3304 | |
3305 | begin | |
6e937c1c | 3306 | -- Build declarations for indices |
26fd4eae AC |
3307 | |
3308 | Decls := New_List; | |
3309 | ||
3310 | Append_To (Decls, | |
3311 | Make_Object_Declaration (Loc, | |
3312 | Defining_Identifier => Lnn, | |
3313 | Object_Definition => | |
3314 | New_Occurrence_Of (Index, Loc))); | |
3315 | ||
3316 | Append_To (Decls, | |
3317 | Make_Object_Declaration (Loc, | |
3318 | Defining_Identifier => Rnn, | |
3319 | Object_Definition => | |
3320 | New_Occurrence_Of (Index, Loc))); | |
3321 | ||
3322 | Stats := New_List; | |
3323 | ||
f2cbd970 JM |
3324 | -- Build test for empty slice case |
3325 | ||
3326 | Append_To (Stats, | |
3327 | Make_If_Statement (Loc, | |
3328 | Condition => | |
3329 | Make_Op_Lt (Loc, | |
3330 | Left_Opnd => New_Occurrence_Of (Left_Hi, Loc), | |
3331 | Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)), | |
3332 | Then_Statements => New_List (Make_Simple_Return_Statement (Loc)))); | |
3333 | ||
6e937c1c | 3334 | -- Build initializations for indices |
26fd4eae AC |
3335 | |
3336 | declare | |
3337 | F_Init : constant List_Id := New_List; | |
3338 | B_Init : constant List_Id := New_List; | |
3339 | ||
3340 | begin | |
3341 | Append_To (F_Init, | |
3342 | Make_Assignment_Statement (Loc, | |
3343 | Name => New_Occurrence_Of (Lnn, Loc), | |
3344 | Expression => New_Occurrence_Of (Left_Lo, Loc))); | |
3345 | ||
3346 | Append_To (F_Init, | |
3347 | Make_Assignment_Statement (Loc, | |
3348 | Name => New_Occurrence_Of (Rnn, Loc), | |
3349 | Expression => New_Occurrence_Of (Right_Lo, Loc))); | |
3350 | ||
3351 | Append_To (B_Init, | |
3352 | Make_Assignment_Statement (Loc, | |
3353 | Name => New_Occurrence_Of (Lnn, Loc), | |
3354 | Expression => New_Occurrence_Of (Left_Hi, Loc))); | |
3355 | ||
3356 | Append_To (B_Init, | |
3357 | Make_Assignment_Statement (Loc, | |
3358 | Name => New_Occurrence_Of (Rnn, Loc), | |
3359 | Expression => New_Occurrence_Of (Right_Hi, Loc))); | |
3360 | ||
3361 | Append_To (Stats, | |
3362 | Make_If_Statement (Loc, | |
3363 | Condition => New_Occurrence_Of (Rev, Loc), | |
3364 | Then_Statements => B_Init, | |
3365 | Else_Statements => F_Init)); | |
3366 | end; | |
3367 | ||
3368 | -- Now construct the assignment statement | |
3369 | ||
3370 | Loops := | |
3371 | Make_Loop_Statement (Loc, | |
3372 | Statements => New_List ( | |
3373 | Make_Assignment_Statement (Loc, | |
3374 | Name => | |
3375 | Make_Indexed_Component (Loc, | |
3376 | Prefix => New_Occurrence_Of (Larray, Loc), | |
3377 | Expressions => New_List (New_Occurrence_Of (Lnn, Loc))), | |
3378 | Expression => | |
3379 | Make_Indexed_Component (Loc, | |
3380 | Prefix => New_Occurrence_Of (Rarray, Loc), | |
3381 | Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))), | |
3382 | End_Label => Empty); | |
3383 | ||
f2cbd970 | 3384 | -- Build the exit condition and increment/decrement statements |
26fd4eae AC |
3385 | |
3386 | declare | |
3387 | F_Ass : constant List_Id := New_List; | |
3388 | B_Ass : constant List_Id := New_List; | |
3389 | ||
3390 | begin | |
3391 | Append_To (F_Ass, | |
3392 | Make_Exit_Statement (Loc, | |
3393 | Condition => | |
f2cbd970 | 3394 | Make_Op_Eq (Loc, |
26fd4eae AC |
3395 | Left_Opnd => New_Occurrence_Of (Lnn, Loc), |
3396 | Right_Opnd => New_Occurrence_Of (Left_Hi, Loc)))); | |
3397 | ||
26fd4eae AC |
3398 | Append_To (F_Ass, |
3399 | Make_Assignment_Statement (Loc, | |
3400 | Name => New_Occurrence_Of (Lnn, Loc), | |
3401 | Expression => | |
3402 | Make_Attribute_Reference (Loc, | |
3403 | Prefix => | |
3404 | New_Occurrence_Of (Index, Loc), | |
3405 | Attribute_Name => Name_Succ, | |
3406 | Expressions => New_List ( | |
3407 | New_Occurrence_Of (Lnn, Loc))))); | |
3408 | ||
3409 | Append_To (F_Ass, | |
3410 | Make_Assignment_Statement (Loc, | |
3411 | Name => New_Occurrence_Of (Rnn, Loc), | |
3412 | Expression => | |
3413 | Make_Attribute_Reference (Loc, | |
3414 | Prefix => | |
3415 | New_Occurrence_Of (Index, Loc), | |
3416 | Attribute_Name => Name_Succ, | |
3417 | Expressions => New_List ( | |
3418 | New_Occurrence_Of (Rnn, Loc))))); | |
3419 | ||
f2cbd970 JM |
3420 | Append_To (B_Ass, |
3421 | Make_Exit_Statement (Loc, | |
3422 | Condition => | |
3423 | Make_Op_Eq (Loc, | |
3424 | Left_Opnd => New_Occurrence_Of (Lnn, Loc), | |
3425 | Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)))); | |
3426 | ||
26fd4eae AC |
3427 | Append_To (B_Ass, |
3428 | Make_Assignment_Statement (Loc, | |
3429 | Name => New_Occurrence_Of (Lnn, Loc), | |
3430 | Expression => | |
3431 | Make_Attribute_Reference (Loc, | |
3432 | Prefix => | |
3433 | New_Occurrence_Of (Index, Loc), | |
3434 | Attribute_Name => Name_Pred, | |
3435 | Expressions => New_List ( | |
3436 | New_Occurrence_Of (Lnn, Loc))))); | |
3437 | ||
3438 | Append_To (B_Ass, | |
3439 | Make_Assignment_Statement (Loc, | |
3440 | Name => New_Occurrence_Of (Rnn, Loc), | |
3441 | Expression => | |
3442 | Make_Attribute_Reference (Loc, | |
3443 | Prefix => | |
3444 | New_Occurrence_Of (Index, Loc), | |
3445 | Attribute_Name => Name_Pred, | |
3446 | Expressions => New_List ( | |
3447 | New_Occurrence_Of (Rnn, Loc))))); | |
3448 | ||
3449 | Append_To (Statements (Loops), | |
3450 | Make_If_Statement (Loc, | |
3451 | Condition => New_Occurrence_Of (Rev, Loc), | |
3452 | Then_Statements => B_Ass, | |
3453 | Else_Statements => F_Ass)); | |
3454 | end; | |
3455 | ||
3456 | Append_To (Stats, Loops); | |
3457 | ||
3458 | declare | |
6e937c1c AC |
3459 | Spec : Node_Id; |
3460 | Formals : List_Id := New_List; | |
26fd4eae AC |
3461 | |
3462 | begin | |
3463 | Formals := New_List ( | |
3464 | Make_Parameter_Specification (Loc, | |
3465 | Defining_Identifier => Larray, | |
3466 | Out_Present => True, | |
3467 | Parameter_Type => | |
3468 | New_Reference_To (Base_Type (Typ), Loc)), | |
3469 | ||
3470 | Make_Parameter_Specification (Loc, | |
3471 | Defining_Identifier => Rarray, | |
3472 | Parameter_Type => | |
3473 | New_Reference_To (Base_Type (Typ), Loc)), | |
3474 | ||
3475 | Make_Parameter_Specification (Loc, | |
3476 | Defining_Identifier => Left_Lo, | |
3477 | Parameter_Type => | |
3478 | New_Reference_To (Index, Loc)), | |
3479 | ||
3480 | Make_Parameter_Specification (Loc, | |
3481 | Defining_Identifier => Left_Hi, | |
3482 | Parameter_Type => | |
3483 | New_Reference_To (Index, Loc)), | |
3484 | ||
3485 | Make_Parameter_Specification (Loc, | |
3486 | Defining_Identifier => Right_Lo, | |
3487 | Parameter_Type => | |
3488 | New_Reference_To (Index, Loc)), | |
3489 | ||
3490 | Make_Parameter_Specification (Loc, | |
3491 | Defining_Identifier => Right_Hi, | |
3492 | Parameter_Type => | |
3493 | New_Reference_To (Index, Loc))); | |
3494 | ||
3495 | Append_To (Formals, | |
3496 | Make_Parameter_Specification (Loc, | |
3497 | Defining_Identifier => Rev, | |
3498 | Parameter_Type => | |
3499 | New_Reference_To (Standard_Boolean, Loc))); | |
3500 | ||
3501 | Spec := | |
3502 | Make_Procedure_Specification (Loc, | |
3503 | Defining_Unit_Name => Proc_Name, | |
3504 | Parameter_Specifications => Formals); | |
3505 | ||
3506 | Discard_Node ( | |
3507 | Make_Subprogram_Body (Loc, | |
3508 | Specification => Spec, | |
3509 | Declarations => Decls, | |
3510 | Handled_Statement_Sequence => | |
3511 | Make_Handled_Sequence_Of_Statements (Loc, | |
3512 | Statements => Stats))); | |
3513 | end; | |
3514 | ||
3515 | Set_TSS (Typ, Proc_Name); | |
3516 | Set_Is_Pure (Proc_Name); | |
3517 | end Build_Slice_Assignment; | |
3518 | ||
70482933 RK |
3519 | ------------------------------------ |
3520 | -- Build_Variant_Record_Equality -- | |
3521 | ------------------------------------ | |
3522 | ||
3523 | -- Generates: | |
6e937c1c | 3524 | |
70482933 RK |
3525 | -- function _Equality (X, Y : T) return Boolean is |
3526 | -- begin | |
3527 | -- -- Compare discriminants | |
3528 | ||
3529 | -- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then | |
3530 | -- return False; | |
3531 | -- end if; | |
3532 | ||
3533 | -- -- Compare components | |
3534 | ||
3535 | -- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then | |
3536 | -- return False; | |
3537 | -- end if; | |
3538 | ||
3539 | -- -- Compare variant part | |
3540 | ||
3541 | -- case X.D1 is | |
3542 | -- when V1 => | |
3543 | -- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then | |
3544 | -- return False; | |
3545 | -- end if; | |
3546 | -- ... | |
3547 | -- when Vn => | |
3548 | -- if False or else X.Cn /= Y.Cn then | |
3549 | -- return False; | |
3550 | -- end if; | |
3551 | -- end case; | |
47cc8d6b | 3552 | |
70482933 RK |
3553 | -- return True; |
3554 | -- end _Equality; | |
3555 | ||
fbf5a39b | 3556 | procedure Build_Variant_Record_Equality (Typ : Entity_Id) is |
47cc8d6b | 3557 | Loc : constant Source_Ptr := Sloc (Typ); |
70482933 | 3558 | |
fbf5a39b AC |
3559 | F : constant Entity_Id := |
3560 | Make_Defining_Identifier (Loc, | |
3561 | Chars => Make_TSS_Name (Typ, TSS_Composite_Equality)); | |
3562 | ||
3563 | X : constant Entity_Id := | |
3564 | Make_Defining_Identifier (Loc, | |
3565 | Chars => Name_X); | |
3566 | ||
3567 | Y : constant Entity_Id := | |
3568 | Make_Defining_Identifier (Loc, | |
3569 | Chars => Name_Y); | |
3570 | ||
47cc8d6b ES |
3571 | Def : constant Node_Id := Parent (Typ); |
3572 | Comps : constant Node_Id := Component_List (Type_Definition (Def)); | |
3573 | Stmts : constant List_Id := New_List; | |
5d09245e | 3574 | Pspecs : constant List_Id := New_List; |
70482933 RK |
3575 | |
3576 | begin | |
5d09245e AC |
3577 | -- Derived Unchecked_Union types no longer inherit the equality function |
3578 | -- of their parent. | |
3579 | ||
70482933 | 3580 | if Is_Derived_Type (Typ) |
5d09245e | 3581 | and then not Is_Unchecked_Union (Typ) |
70482933 RK |
3582 | and then not Has_New_Non_Standard_Rep (Typ) |
3583 | then | |
3584 | declare | |
fbf5a39b AC |
3585 | Parent_Eq : constant Entity_Id := |
3586 | TSS (Root_Type (Typ), TSS_Composite_Equality); | |
70482933 RK |
3587 | |
3588 | begin | |
3589 | if Present (Parent_Eq) then | |
3590 | Copy_TSS (Parent_Eq, Typ); | |
3591 | return; | |
3592 | end if; | |
3593 | end; | |
3594 | end if; | |
3595 | ||
fbf5a39b | 3596 | Discard_Node ( |
70482933 RK |
3597 | Make_Subprogram_Body (Loc, |
3598 | Specification => | |
3599 | Make_Function_Specification (Loc, | |
3600 | Defining_Unit_Name => F, | |
5d09245e | 3601 | Parameter_Specifications => Pspecs, |
10b93b2e | 3602 | Result_Definition => New_Reference_To (Standard_Boolean, Loc)), |
70482933 RK |
3603 | Declarations => New_List, |
3604 | Handled_Statement_Sequence => | |
3605 | Make_Handled_Sequence_Of_Statements (Loc, | |
fbf5a39b | 3606 | Statements => Stmts))); |
70482933 | 3607 | |
5d09245e AC |
3608 | Append_To (Pspecs, |
3609 | Make_Parameter_Specification (Loc, | |
3610 | Defining_Identifier => X, | |
3611 | Parameter_Type => New_Reference_To (Typ, Loc))); | |
3612 | ||
3613 | Append_To (Pspecs, | |
3614 | Make_Parameter_Specification (Loc, | |
3615 | Defining_Identifier => Y, | |
3616 | Parameter_Type => New_Reference_To (Typ, Loc))); | |
3617 | ||
3618 | -- Unchecked_Unions require additional machinery to support equality. | |
3619 | -- Two extra parameters (A and B) are added to the equality function | |
3620 | -- parameter list in order to capture the inferred values of the | |
3621 | -- discriminants in later calls. | |
3622 | ||
3623 | if Is_Unchecked_Union (Typ) then | |
3624 | declare | |
3625 | Discr_Type : constant Node_Id := Etype (First_Discriminant (Typ)); | |
3626 | ||
3627 | A : constant Node_Id := | |
3628 | Make_Defining_Identifier (Loc, | |
3629 | Chars => Name_A); | |
3630 | ||
3631 | B : constant Node_Id := | |
3632 | Make_Defining_Identifier (Loc, | |
3633 | Chars => Name_B); | |
3634 | ||
3635 | begin | |
3636 | -- Add A and B to the parameter list | |
3637 | ||
3638 | Append_To (Pspecs, | |
3639 | Make_Parameter_Specification (Loc, | |
3640 | Defining_Identifier => A, | |
3641 | Parameter_Type => New_Reference_To (Discr_Type, Loc))); | |
3642 | ||
3643 | Append_To (Pspecs, | |
3644 | Make_Parameter_Specification (Loc, | |
3645 | Defining_Identifier => B, | |
3646 | Parameter_Type => New_Reference_To (Discr_Type, Loc))); | |
3647 | ||
3648 | -- Generate the following header code to compare the inferred | |
3649 | -- discriminants: | |
3650 | ||
3651 | -- if a /= b then | |
3652 | -- return False; | |
3653 | -- end if; | |
3654 | ||
3655 | Append_To (Stmts, | |
3656 | Make_If_Statement (Loc, | |
3657 | Condition => | |
3658 | Make_Op_Ne (Loc, | |
3659 | Left_Opnd => New_Reference_To (A, Loc), | |
3660 | Right_Opnd => New_Reference_To (B, Loc)), | |
3661 | Then_Statements => New_List ( | |
04df6250 | 3662 | Make_Simple_Return_Statement (Loc, |
5d09245e AC |
3663 | Expression => New_Occurrence_Of (Standard_False, Loc))))); |
3664 | ||
3665 | -- Generate component-by-component comparison. Note that we must | |
3666 | -- propagate one of the inferred discriminant formals to act as | |
3667 | -- the case statement switch. | |
3668 | ||
3669 | Append_List_To (Stmts, | |
3670 | Make_Eq_Case (Typ, Comps, A)); | |
3671 | ||
3672 | end; | |
3673 | ||
3674 | -- Normal case (not unchecked union) | |
70482933 | 3675 | |
70482933 RK |
3676 | else |
3677 | Append_To (Stmts, | |
3678 | Make_Eq_If (Typ, | |
3679 | Discriminant_Specifications (Def))); | |
5d09245e | 3680 | |
70482933 RK |
3681 | Append_List_To (Stmts, |
3682 | Make_Eq_Case (Typ, Comps)); | |
3683 | end if; | |
3684 | ||
3685 | Append_To (Stmts, | |
04df6250 | 3686 | Make_Simple_Return_Statement (Loc, |
70482933 RK |
3687 | Expression => New_Reference_To (Standard_True, Loc))); |
3688 | ||
3689 | Set_TSS (Typ, F); | |
3690 | Set_Is_Pure (F); | |
3691 | ||
3692 | if not Debug_Generated_Code then | |
3693 | Set_Debug_Info_Off (F); | |
3694 | end if; | |
3695 | end Build_Variant_Record_Equality; | |
3696 | ||
07fc65c4 GB |
3697 | ----------------------------- |
3698 | -- Check_Stream_Attributes -- | |
3699 | ----------------------------- | |
3700 | ||
3701 | procedure Check_Stream_Attributes (Typ : Entity_Id) is | |
fbf5a39b | 3702 | Comp : Entity_Id; |
758c442c GD |
3703 | Par_Read : constant Boolean := |
3704 | Stream_Attribute_Available (Typ, TSS_Stream_Read) | |
3705 | and then not Has_Specified_Stream_Read (Typ); | |
3706 | Par_Write : constant Boolean := | |
3707 | Stream_Attribute_Available (Typ, TSS_Stream_Write) | |
3708 | and then not Has_Specified_Stream_Write (Typ); | |
07fc65c4 | 3709 | |
d2d3604c TQ |
3710 | procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type); |
3711 | -- Check that Comp has a user-specified Nam stream attribute | |
3712 | ||
758c442c GD |
3713 | ---------------- |
3714 | -- Check_Attr -- | |
3715 | ---------------- | |
3716 | ||
d2d3604c TQ |
3717 | procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is |
3718 | begin | |
758c442c | 3719 | if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then |
d2d3604c TQ |
3720 | Error_Msg_Name_1 := Nam; |
3721 | Error_Msg_N | |
3722 | ("|component& in limited extension must have% attribute", Comp); | |
3723 | end if; | |
3724 | end Check_Attr; | |
3725 | ||
758c442c GD |
3726 | -- Start of processing for Check_Stream_Attributes |
3727 | ||
07fc65c4 GB |
3728 | begin |
3729 | if Par_Read or else Par_Write then | |
3730 | Comp := First_Component (Typ); | |
3731 | while Present (Comp) loop | |
3732 | if Comes_From_Source (Comp) | |
d2d3604c | 3733 | and then Original_Record_Component (Comp) = Comp |
07fc65c4 GB |
3734 | and then Is_Limited_Type (Etype (Comp)) |
3735 | then | |
d2d3604c TQ |
3736 | if Par_Read then |
3737 | Check_Attr (Name_Read, TSS_Stream_Read); | |
3738 | end if; | |
3739 | ||
3740 | if Par_Write then | |
3741 | Check_Attr (Name_Write, TSS_Stream_Write); | |
07fc65c4 GB |
3742 | end if; |
3743 | end if; | |
3744 | ||
3745 | Next_Component (Comp); | |
3746 | end loop; | |
3747 | end if; | |
3748 | end Check_Stream_Attributes; | |
3749 | ||
c885d7a1 AC |
3750 | ----------------------------- |
3751 | -- Expand_Record_Extension -- | |
3752 | ----------------------------- | |
70482933 RK |
3753 | |
3754 | -- Add a field _parent at the beginning of the record extension. This is | |
3755 | -- used to implement inheritance. Here are some examples of expansion: | |
3756 | ||
3757 | -- 1. no discriminants | |
3758 | -- type T2 is new T1 with null record; | |
3759 | -- gives | |
3760 | -- type T2 is new T1 with record | |
3761 | -- _Parent : T1; | |
3762 | -- end record; | |
3763 | ||
3764 | -- 2. renamed discriminants | |
3765 | -- type T2 (B, C : Int) is new T1 (A => B) with record | |
3766 | -- _Parent : T1 (A => B); | |
3767 | -- D : Int; | |
3768 | -- end; | |
3769 | ||
3770 | -- 3. inherited discriminants | |
3771 | -- type T2 is new T1 with record -- discriminant A inherited | |
3772 | -- _Parent : T1 (A); | |
3773 | -- D : Int; | |
3774 | -- end; | |
3775 | ||
c885d7a1 | 3776 | procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is |
70482933 RK |
3777 | Indic : constant Node_Id := Subtype_Indication (Def); |
3778 | Loc : constant Source_Ptr := Sloc (Def); | |
3779 | Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); | |
3780 | Par_Subtype : Entity_Id; | |
3781 | Comp_List : Node_Id; | |
3782 | Comp_Decl : Node_Id; | |
3783 | Parent_N : Node_Id; | |
3784 | D : Entity_Id; | |
3785 | List_Constr : constant List_Id := New_List; | |
3786 | ||
3787 | begin | |
c885d7a1 | 3788 | -- Expand_Record_Extension is called directly from the semantics, so |
70482933 RK |
3789 | -- we must check to see whether expansion is active before proceeding |
3790 | ||
3791 | if not Expander_Active then | |
3792 | return; | |
3793 | end if; | |
3794 | ||
3795 | -- This may be a derivation of an untagged private type whose full | |
3796 | -- view is tagged, in which case the Derived_Type_Definition has no | |
3797 | -- extension part. Build an empty one now. | |
3798 | ||
3799 | if No (Rec_Ext_Part) then | |
3800 | Rec_Ext_Part := | |
3801 | Make_Record_Definition (Loc, | |
3802 | End_Label => Empty, | |
3803 | Component_List => Empty, | |
3804 | Null_Present => True); | |
3805 | ||
3806 | Set_Record_Extension_Part (Def, Rec_Ext_Part); | |
3807 | Mark_Rewrite_Insertion (Rec_Ext_Part); | |
3808 | end if; | |
3809 | ||
3810 | Comp_List := Component_List (Rec_Ext_Part); | |
3811 | ||
3812 | Parent_N := Make_Defining_Identifier (Loc, Name_uParent); | |
3813 | ||
3814 | -- If the derived type inherits its discriminants the type of the | |
3815 | -- _parent field must be constrained by the inherited discriminants | |
3816 | ||
3817 | if Has_Discriminants (T) | |
3818 | and then Nkind (Indic) /= N_Subtype_Indication | |
3819 | and then not Is_Constrained (Entity (Indic)) | |
3820 | then | |
3821 | D := First_Discriminant (T); | |
fbf5a39b | 3822 | while Present (D) loop |
70482933 RK |
3823 | Append_To (List_Constr, New_Occurrence_Of (D, Loc)); |
3824 | Next_Discriminant (D); | |
3825 | end loop; | |
3826 | ||
3827 | Par_Subtype := | |
3828 | Process_Subtype ( | |
3829 | Make_Subtype_Indication (Loc, | |
3830 | Subtype_Mark => New_Reference_To (Entity (Indic), Loc), | |
3831 | Constraint => | |
3832 | Make_Index_Or_Discriminant_Constraint (Loc, | |
3833 | Constraints => List_Constr)), | |
3834 | Def); | |
3835 | ||
3836 | -- Otherwise the original subtype_indication is just what is needed | |
3837 | ||
3838 | else | |
3839 | Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); | |
3840 | end if; | |
3841 | ||
3842 | Set_Parent_Subtype (T, Par_Subtype); | |
3843 | ||
3844 | Comp_Decl := | |
3845 | Make_Component_Declaration (Loc, | |
3846 | Defining_Identifier => Parent_N, | |
a397db96 AC |
3847 | Component_Definition => |
3848 | Make_Component_Definition (Loc, | |
3849 | Aliased_Present => False, | |
3850 | Subtype_Indication => New_Reference_To (Par_Subtype, Loc))); | |
70482933 RK |
3851 | |
3852 | if Null_Present (Rec_Ext_Part) then | |
3853 | Set_Component_List (Rec_Ext_Part, | |
3854 | Make_Component_List (Loc, | |
3855 | Component_Items => New_List (Comp_Decl), | |
3856 | Variant_Part => Empty, | |
3857 | Null_Present => False)); | |
3858 | Set_Null_Present (Rec_Ext_Part, False); | |
3859 | ||
3860 | elsif Null_Present (Comp_List) | |
3861 | or else Is_Empty_List (Component_Items (Comp_List)) | |
3862 | then | |
3863 | Set_Component_Items (Comp_List, New_List (Comp_Decl)); | |
3864 | Set_Null_Present (Comp_List, False); | |
3865 | ||
3866 | else | |
3867 | Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); | |
3868 | end if; | |
3869 | ||
3870 | Analyze (Comp_Decl); | |
c885d7a1 | 3871 | end Expand_Record_Extension; |
70482933 RK |
3872 | |
3873 | ------------------------------------ | |
3874 | -- Expand_N_Full_Type_Declaration -- | |
3875 | ------------------------------------ | |
3876 | ||
3877 | procedure Expand_N_Full_Type_Declaration (N : Node_Id) is | |
3878 | Def_Id : constant Entity_Id := Defining_Identifier (N); | |
fbf5a39b | 3879 | B_Id : constant Entity_Id := Base_Type (Def_Id); |
70482933 RK |
3880 | Par_Id : Entity_Id; |
3881 | FN : Node_Id; | |
3882 | ||
ea1941af ES |
3883 | procedure Build_Master (Def_Id : Entity_Id); |
3884 | -- Create the master associated with Def_Id | |
70482933 | 3885 | |
ea1941af ES |
3886 | ------------------ |
3887 | -- Build_Master -- | |
3888 | ------------------ | |
3889 | ||
3890 | procedure Build_Master (Def_Id : Entity_Id) is | |
3891 | begin | |
70482933 | 3892 | -- Anonymous access types are created for the components of the |
a05e99a2 | 3893 | -- record parameter for an entry declaration. No master is created |
70482933 RK |
3894 | -- for such a type. |
3895 | ||
3896 | if Has_Task (Designated_Type (Def_Id)) | |
3897 | and then Comes_From_Source (N) | |
3898 | then | |
3899 | Build_Master_Entity (Def_Id); | |
3900 | Build_Master_Renaming (Parent (Def_Id), Def_Id); | |
3901 | ||
3902 | -- Create a class-wide master because a Master_Id must be generated | |
a05e99a2 JM |
3903 | -- for access-to-limited-class-wide types whose root may be extended |
3904 | -- with task components, and for access-to-limited-interfaces because | |
3905 | -- they can be used to reference tasks implementing such interface. | |
70482933 RK |
3906 | |
3907 | elsif Is_Class_Wide_Type (Designated_Type (Def_Id)) | |
a05e99a2 JM |
3908 | and then (Is_Limited_Type (Designated_Type (Def_Id)) |
3909 | or else | |
3910 | (Is_Interface (Designated_Type (Def_Id)) | |
3911 | and then | |
3912 | Is_Limited_Interface (Designated_Type (Def_Id)))) | |
70482933 RK |
3913 | and then Tasking_Allowed |
3914 | ||
a05e99a2 | 3915 | -- Do not create a class-wide master for types whose convention is |
70482933 RK |
3916 | -- Java since these types cannot embed Ada tasks anyway. Note that |
3917 | -- the following test cannot catch the following case: | |
a05e99a2 | 3918 | |
70482933 RK |
3919 | -- package java.lang.Object is |
3920 | -- type Typ is tagged limited private; | |
3921 | -- type Ref is access all Typ'Class; | |
3922 | -- private | |
3923 | -- type Typ is tagged limited ...; | |
3924 | -- pragma Convention (Typ, Java) | |
3925 | -- end; | |
a05e99a2 | 3926 | |
70482933 RK |
3927 | -- Because the convention appears after we have done the |
3928 | -- processing for type Ref. | |
3929 | ||
3930 | and then Convention (Designated_Type (Def_Id)) /= Convention_Java | |
47cc8d6b | 3931 | and then Convention (Designated_Type (Def_Id)) /= Convention_CIL |
70482933 RK |
3932 | then |
3933 | Build_Class_Wide_Master (Def_Id); | |
ea1941af ES |
3934 | end if; |
3935 | end Build_Master; | |
3936 | ||
3937 | -- Start of processing for Expand_N_Full_Type_Declaration | |
3938 | ||
3939 | begin | |
3940 | if Is_Access_Type (Def_Id) then | |
3941 | Build_Master (Def_Id); | |
70482933 | 3942 | |
ea1941af | 3943 | if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then |
70482933 RK |
3944 | Expand_Access_Protected_Subprogram_Type (N); |
3945 | end if; | |
3946 | ||
ea1941af ES |
3947 | elsif Ada_Version >= Ada_05 |
3948 | and then Is_Array_Type (Def_Id) | |
3949 | and then Is_Access_Type (Component_Type (Def_Id)) | |
3950 | and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type | |
3951 | then | |
3952 | Build_Master (Component_Type (Def_Id)); | |
3953 | ||
70482933 | 3954 | elsif Has_Task (Def_Id) then |
07fc65c4 | 3955 | Expand_Previous_Access_Type (Def_Id); |
ea1941af ES |
3956 | |
3957 | elsif Ada_Version >= Ada_05 | |
3958 | and then | |
3959 | (Is_Record_Type (Def_Id) | |
3960 | or else (Is_Array_Type (Def_Id) | |
3961 | and then Is_Record_Type (Component_Type (Def_Id)))) | |
3962 | then | |
3963 | declare | |
3964 | Comp : Entity_Id; | |
3965 | Typ : Entity_Id; | |
3966 | M_Id : Entity_Id; | |
3967 | ||
3968 | begin | |
3969 | -- Look for the first anonymous access type component | |
3970 | ||
3971 | if Is_Array_Type (Def_Id) then | |
3972 | Comp := First_Entity (Component_Type (Def_Id)); | |
3973 | else | |
3974 | Comp := First_Entity (Def_Id); | |
3975 | end if; | |
3976 | ||
3977 | while Present (Comp) loop | |
3978 | Typ := Etype (Comp); | |
3979 | ||
3980 | exit when Is_Access_Type (Typ) | |
3981 | and then Ekind (Typ) = E_Anonymous_Access_Type; | |
3982 | ||
3983 | Next_Entity (Comp); | |
3984 | end loop; | |
3985 | ||
47cc8d6b | 3986 | -- If found we add a renaming declaration of master_id and we |
ea1941af ES |
3987 | -- associate it to each anonymous access type component. Do |
3988 | -- nothing if the access type already has a master. This will be | |
3989 | -- the case if the array type is the packed array created for a | |
3990 | -- user-defined array type T, where the master_id is created when | |
3991 | -- expanding the declaration for T. | |
3992 | ||
3993 | if Present (Comp) | |
47cc8d6b | 3994 | and then Ekind (Typ) = E_Anonymous_Access_Type |
ea1941af ES |
3995 | and then not Restriction_Active (No_Task_Hierarchy) |
3996 | and then No (Master_Id (Typ)) | |
47cc8d6b ES |
3997 | |
3998 | -- Do not consider run-times with no tasking support | |
3999 | ||
4000 | and then RTE_Available (RE_Current_Master) | |
4001 | and then Has_Task (Non_Limited_Designated_Type (Typ)) | |
ea1941af ES |
4002 | then |
4003 | Build_Master_Entity (Def_Id); | |
4004 | M_Id := Build_Master_Renaming (N, Def_Id); | |
4005 | ||
4006 | if Is_Array_Type (Def_Id) then | |
4007 | Comp := First_Entity (Component_Type (Def_Id)); | |
4008 | else | |
4009 | Comp := First_Entity (Def_Id); | |
4010 | end if; | |
4011 | ||
4012 | while Present (Comp) loop | |
4013 | Typ := Etype (Comp); | |
4014 | ||
4015 | if Is_Access_Type (Typ) | |
4016 | and then Ekind (Typ) = E_Anonymous_Access_Type | |
4017 | then | |
4018 | Set_Master_Id (Typ, M_Id); | |
4019 | end if; | |
4020 | ||
4021 | Next_Entity (Comp); | |
4022 | end loop; | |
4023 | end if; | |
4024 | end; | |
70482933 RK |
4025 | end if; |
4026 | ||
4027 | Par_Id := Etype (B_Id); | |
4028 | ||
ea1941af ES |
4029 | -- The parent type is private then we need to inherit any TSS operations |
4030 | -- from the full view. | |
70482933 RK |
4031 | |
4032 | if Ekind (Par_Id) in Private_Kind | |
4033 | and then Present (Full_View (Par_Id)) | |
4034 | then | |
4035 | Par_Id := Base_Type (Full_View (Par_Id)); | |
4036 | end if; | |
4037 | ||
ea1941af ES |
4038 | if Nkind (Type_Definition (Original_Node (N))) = |
4039 | N_Derived_Type_Definition | |
70482933 RK |
4040 | and then not Is_Tagged_Type (Def_Id) |
4041 | and then Present (Freeze_Node (Par_Id)) | |
4042 | and then Present (TSS_Elist (Freeze_Node (Par_Id))) | |
4043 | then | |
4044 | Ensure_Freeze_Node (B_Id); | |
ea1941af | 4045 | FN := Freeze_Node (B_Id); |
70482933 RK |
4046 | |
4047 | if No (TSS_Elist (FN)) then | |
4048 | Set_TSS_Elist (FN, New_Elmt_List); | |
4049 | end if; | |
4050 | ||
4051 | declare | |
ea1941af ES |
4052 | T_E : constant Elist_Id := TSS_Elist (FN); |
4053 | Elmt : Elmt_Id; | |
70482933 RK |
4054 | |
4055 | begin | |
ea1941af | 4056 | Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id))); |
70482933 RK |
4057 | while Present (Elmt) loop |
4058 | if Chars (Node (Elmt)) /= Name_uInit then | |
4059 | Append_Elmt (Node (Elmt), T_E); | |
4060 | end if; | |
4061 | ||
4062 | Next_Elmt (Elmt); | |
4063 | end loop; | |
4064 | ||
6e937c1c AC |
4065 | -- If the derived type itself is private with a full view, then |
4066 | -- associate the full view with the inherited TSS_Elist as well. | |
70482933 RK |
4067 | |
4068 | if Ekind (B_Id) in Private_Kind | |
4069 | and then Present (Full_View (B_Id)) | |
4070 | then | |
4071 | Ensure_Freeze_Node (Base_Type (Full_View (B_Id))); | |
4072 | Set_TSS_Elist | |
4073 | (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN)); | |
4074 | end if; | |
4075 | end; | |
4076 | end if; | |
4077 | end Expand_N_Full_Type_Declaration; | |
4078 | ||
4079 | --------------------------------- | |
4080 | -- Expand_N_Object_Declaration -- | |
4081 | --------------------------------- | |
4082 | ||
4083 | -- First we do special processing for objects of a tagged type where this | |
4084 | -- is the point at which the type is frozen. The creation of the dispatch | |
4085 | -- table and the initialization procedure have to be deferred to this | |
4086 | -- point, since we reference previously declared primitive subprograms. | |
4087 | ||
4088 | -- For all types, we call an initialization procedure if there is one | |
4089 | ||
4090 | procedure Expand_N_Object_Declaration (N : Node_Id) is | |
47cc8d6b ES |
4091 | Def_Id : constant Entity_Id := Defining_Identifier (N); |
4092 | Expr : constant Node_Id := Expression (N); | |
4093 | Loc : constant Source_Ptr := Sloc (N); | |
4094 | Typ : constant Entity_Id := Etype (Def_Id); | |
5be0911d | 4095 | Base_Typ : constant Entity_Id := Base_Type (Typ); |
47cc8d6b ES |
4096 | Expr_Q : Node_Id; |
4097 | Id_Ref : Node_Id; | |
4098 | New_Ref : Node_Id; | |
4099 | BIP_Call : Boolean := False; | |
70482933 | 4100 | |
93188a0b GD |
4101 | Init_After : Node_Id := N; |
4102 | -- Node after which the init proc call is to be inserted. This is | |
4103 | -- normally N, except for the case of a shared passive variable, in | |
4104 | -- which case the init proc call must be inserted only after the bodies | |
4105 | -- of the shared variable procedures have been seen. | |
4106 | ||
70482933 RK |
4107 | begin |
4108 | -- Don't do anything for deferred constants. All proper actions will | |
91b1417d | 4109 | -- be expanded during the full declaration. |
70482933 | 4110 | |
fbf5a39b | 4111 | if No (Expr) and Constant_Present (N) then |
70482933 RK |
4112 | return; |
4113 | end if; | |
4114 | ||
04df6250 TQ |
4115 | -- Force construction of dispatch tables of library level tagged types |
4116 | ||
4117 | if VM_Target = No_VM | |
4118 | and then Static_Dispatch_Tables | |
4119 | and then Is_Library_Level_Entity (Def_Id) | |
5be0911d JM |
4120 | and then Is_Library_Level_Tagged_Type (Base_Typ) |
4121 | and then (Ekind (Base_Typ) = E_Record_Type | |
4122 | or else Ekind (Base_Typ) = E_Protected_Type | |
4123 | or else Ekind (Base_Typ) = E_Task_Type) | |
4124 | and then not Has_Dispatch_Table (Base_Typ) | |
04df6250 TQ |
4125 | then |
4126 | declare | |
4127 | New_Nodes : List_Id := No_List; | |
4128 | ||
4129 | begin | |
5be0911d JM |
4130 | if Is_Concurrent_Type (Base_Typ) then |
4131 | New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N); | |
04df6250 | 4132 | else |
5be0911d | 4133 | New_Nodes := Make_DT (Base_Typ, N); |
04df6250 TQ |
4134 | end if; |
4135 | ||
4136 | if not Is_Empty_List (New_Nodes) then | |
4137 | Insert_List_Before (N, New_Nodes); | |
4138 | end if; | |
4139 | end; | |
4140 | end if; | |
4141 | ||
70482933 RK |
4142 | -- Make shared memory routines for shared passive variable |
4143 | ||
4144 | if Is_Shared_Passive (Def_Id) then | |
93188a0b | 4145 | Init_After := Make_Shared_Var_Procs (N); |
70482933 RK |
4146 | end if; |
4147 | ||
4148 | -- If tasks being declared, make sure we have an activation chain | |
4149 | -- defined for the tasks (has no effect if we already have one), and | |
4150 | -- also that a Master variable is established and that the appropriate | |
4151 | -- enclosing construct is established as a task master. | |
4152 | ||
4153 | if Has_Task (Typ) then | |
4154 | Build_Activation_Chain_Entity (N); | |
4155 | Build_Master_Entity (Def_Id); | |
4156 | end if; | |
4157 | ||
04df6250 TQ |
4158 | -- Build a list controller for declarations where the type is anonymous |
4159 | -- access and the designated type is controlled. Only declarations from | |
4160 | -- source files receive such controllers in order to provide the same | |
4161 | -- lifespan for any potential coextensions that may be associated with | |
4162 | -- the object. Finalization lists of internal controlled anonymous | |
4163 | -- access objects are already handled in Expand_N_Allocator. | |
47cc8d6b | 4164 | |
04df6250 TQ |
4165 | if Comes_From_Source (N) |
4166 | and then Ekind (Typ) = E_Anonymous_Access_Type | |
47cc8d6b ES |
4167 | and then Is_Controlled (Directly_Designated_Type (Typ)) |
4168 | and then No (Associated_Final_Chain (Typ)) | |
4169 | then | |
4170 | Build_Final_List (N, Typ); | |
4171 | end if; | |
4172 | ||
70482933 RK |
4173 | -- Default initialization required, and no expression present |
4174 | ||
4175 | if No (Expr) then | |
4176 | ||
a05e99a2 | 4177 | -- Expand Initialize call for controlled objects. One may wonder why |
70482933 RK |
4178 | -- the Initialize Call is not done in the regular Init procedure |
4179 | -- attached to the record type. That's because the init procedure is | |
4180 | -- recursively called on each component, including _Parent, thus the | |
4181 | -- Init call for a controlled object would generate not only one | |
4182 | -- Initialize call as it is required but one for each ancestor of | |
4183 | -- its type. This processing is suppressed if No_Initialization set. | |
4184 | ||
4185 | if not Controlled_Type (Typ) | |
4186 | or else No_Initialization (N) | |
4187 | then | |
4188 | null; | |
4189 | ||
4190 | elsif not Abort_Allowed | |
4191 | or else not Comes_From_Source (N) | |
4192 | then | |
93188a0b | 4193 | Insert_Actions_After (Init_After, |
70482933 RK |
4194 | Make_Init_Call ( |
4195 | Ref => New_Occurrence_Of (Def_Id, Loc), | |
4196 | Typ => Base_Type (Typ), | |
4197 | Flist_Ref => Find_Final_List (Def_Id), | |
4198 | With_Attach => Make_Integer_Literal (Loc, 1))); | |
4199 | ||
4200 | -- Abort allowed | |
4201 | ||
4202 | else | |
4203 | -- We need to protect the initialize call | |
4204 | ||
4205 | -- begin | |
4206 | -- Defer_Abort.all; | |
4207 | -- Initialize (...); | |
4208 | -- at end | |
4209 | -- Undefer_Abort.all; | |
4210 | -- end; | |
4211 | ||
4212 | -- ??? this won't protect the initialize call for controlled | |
4213 | -- components which are part of the init proc, so this block | |
4214 | -- should probably also contain the call to _init_proc but this | |
4215 | -- requires some code reorganization... | |
4216 | ||
4217 | declare | |
4218 | L : constant List_Id := | |
ea1941af ES |
4219 | Make_Init_Call |
4220 | (Ref => New_Occurrence_Of (Def_Id, Loc), | |
4221 | Typ => Base_Type (Typ), | |
4222 | Flist_Ref => Find_Final_List (Def_Id), | |
4223 | With_Attach => Make_Integer_Literal (Loc, 1)); | |
70482933 RK |
4224 | |
4225 | Blk : constant Node_Id := | |
ea1941af ES |
4226 | Make_Block_Statement (Loc, |
4227 | Handled_Statement_Sequence => | |
4228 | Make_Handled_Sequence_Of_Statements (Loc, L)); | |
70482933 RK |
4229 | |
4230 | begin | |
4231 | Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer)); | |
4232 | Set_At_End_Proc (Handled_Statement_Sequence (Blk), | |
4233 | New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); | |
93188a0b | 4234 | Insert_Actions_After (Init_After, New_List (Blk)); |
70482933 RK |
4235 | Expand_At_End_Handler |
4236 | (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); | |
4237 | end; | |
4238 | end if; | |
4239 | ||
4240 | -- Call type initialization procedure if there is one. We build the | |
4241 | -- call and put it immediately after the object declaration, so that | |
4242 | -- it will be expanded in the usual manner. Note that this will | |
04df6250 TQ |
4243 | -- result in proper handling of defaulted discriminants. |
4244 | ||
4245 | -- Need call if there is a base init proc | |
70482933 RK |
4246 | |
4247 | if Has_Non_Null_Base_Init_Proc (Typ) | |
04df6250 TQ |
4248 | |
4249 | -- Suppress call if No_Initialization set on declaration | |
4250 | ||
4251 | and then not No_Initialization (N) | |
4252 | ||
4253 | -- Suppress call for special case of value type for VM | |
4254 | ||
4255 | and then not Is_Value_Type (Typ) | |
4256 | ||
4257 | -- Suppress call if Suppress_Init_Proc set on the type. This is | |
4258 | -- needed for the derived type case, where Suppress_Initialization | |
4259 | -- may be set for the derived type, even if there is an init proc | |
4260 | -- defined for the root type. | |
4261 | ||
4262 | and then not Suppress_Init_Proc (Typ) | |
70482933 | 4263 | then |
1ce1f005 GD |
4264 | -- Return without initializing when No_Default_Initialization |
4265 | -- applies. Note that the actual restriction check occurs later, | |
4266 | -- when the object is frozen, because we don't know yet whether | |
4267 | -- the object is imported, which is a case where the check does | |
4268 | -- not apply. | |
f2cbd970 JM |
4269 | |
4270 | if Restriction_Active (No_Default_Initialization) then | |
4271 | return; | |
4272 | end if; | |
4273 | ||
ea1941af ES |
4274 | -- The call to the initialization procedure does NOT freeze the |
4275 | -- object being initialized. This is because the call is not a | |
4276 | -- source level call. This works fine, because the only possible | |
4277 | -- statements depending on freeze status that can appear after the | |
4278 | -- _Init call are rep clauses which can safely appear after actual | |
4279 | -- references to the object. | |
70482933 RK |
4280 | |
4281 | Id_Ref := New_Reference_To (Def_Id, Loc); | |
4282 | Set_Must_Not_Freeze (Id_Ref); | |
4283 | Set_Assignment_OK (Id_Ref); | |
4284 | ||
47cc8d6b ES |
4285 | declare |
4286 | Init_Expr : constant Node_Id := | |
4287 | Static_Initialization (Base_Init_Proc (Typ)); | |
4288 | begin | |
4289 | if Present (Init_Expr) then | |
4290 | Set_Expression | |
4291 | (N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope)); | |
4292 | return; | |
4293 | else | |
4294 | Initialization_Warning (Id_Ref); | |
4295 | ||
93188a0b | 4296 | Insert_Actions_After (Init_After, |
47cc8d6b ES |
4297 | Build_Initialization_Call (Loc, Id_Ref, Typ)); |
4298 | end if; | |
4299 | end; | |
70482933 RK |
4300 | |
4301 | -- If simple initialization is required, then set an appropriate | |
4302 | -- simple initialization expression in place. This special | |
47cc8d6b ES |
4303 | -- initialization is required even though No_Init_Flag is present, |
4304 | -- but is not needed if there was an explicit initialization. | |
70482933 | 4305 | |
758c442c | 4306 | -- An internally generated temporary needs no initialization because |
ea1941af ES |
4307 | -- it will be assigned subsequently. In particular, there is no point |
4308 | -- in applying Initialize_Scalars to such a temporary. | |
758c442c GD |
4309 | |
4310 | elsif Needs_Simple_Initialization (Typ) | |
47cc8d6b ES |
4311 | and then not Is_Internal (Def_Id) |
4312 | and then not Has_Init_Expression (N) | |
758c442c | 4313 | then |
70482933 | 4314 | Set_No_Initialization (N, False); |
f2cbd970 | 4315 | Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id))); |
70482933 RK |
4316 | Analyze_And_Resolve (Expression (N), Typ); |
4317 | end if; | |
4318 | ||
758c442c GD |
4319 | -- Generate attribute for Persistent_BSS if needed |
4320 | ||
a05e99a2 JM |
4321 | if Persistent_BSS_Mode |
4322 | and then Comes_From_Source (N) | |
4323 | and then Is_Potentially_Persistent_Type (Typ) | |
47cc8d6b | 4324 | and then not Has_Init_Expression (N) |
a05e99a2 JM |
4325 | and then Is_Library_Level_Entity (Def_Id) |
4326 | then | |
4327 | declare | |
4328 | Prag : Node_Id; | |
4329 | begin | |
758c442c GD |
4330 | Prag := |
4331 | Make_Linker_Section_Pragma | |
4332 | (Def_Id, Sloc (N), ".persistent.bss"); | |
4333 | Insert_After (N, Prag); | |
4334 | Analyze (Prag); | |
a05e99a2 JM |
4335 | end; |
4336 | end if; | |
4337 | ||
4338 | -- If access type, then we know it is null if not initialized | |
4339 | ||
4340 | if Is_Access_Type (Typ) then | |
4341 | Set_Is_Known_Null (Def_Id); | |
4342 | end if; | |
758c442c | 4343 | |
70482933 RK |
4344 | -- Explicit initialization present |
4345 | ||
4346 | else | |
4347 | -- Obtain actual expression from qualified expression | |
4348 | ||
4349 | if Nkind (Expr) = N_Qualified_Expression then | |
4350 | Expr_Q := Expression (Expr); | |
4351 | else | |
4352 | Expr_Q := Expr; | |
4353 | end if; | |
4354 | ||
a05e99a2 JM |
4355 | -- When we have the appropriate type of aggregate in the expression |
4356 | -- (it has been determined during analysis of the aggregate by | |
4357 | -- setting the delay flag), let's perform in place assignment and | |
4358 | -- thus avoid creating a temporary. | |
70482933 RK |
4359 | |
4360 | if Is_Delayed_Aggregate (Expr_Q) then | |
4361 | Convert_Aggr_In_Object_Decl (N); | |
4362 | ||
4363 | else | |
3476f949 JM |
4364 | -- Ada 2005 (AI-318-02): If the initialization expression is a |
4365 | -- call to a build-in-place function, then access to the declared | |
4366 | -- object must be passed to the function. Currently we limit such | |
4367 | -- functions to those with constrained limited result subtypes, | |
47cc8d6b | 4368 | -- but eventually we plan to expand the allowed forms of functions |
3476f949 JM |
4369 | -- that are treated as build-in-place. |
4370 | ||
4371 | if Ada_Version >= Ada_05 | |
4372 | and then Is_Build_In_Place_Function_Call (Expr_Q) | |
4373 | then | |
4374 | Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q); | |
47cc8d6b | 4375 | BIP_Call := True; |
3476f949 JM |
4376 | end if; |
4377 | ||
a05e99a2 JM |
4378 | -- In most cases, we must check that the initial value meets any |
4379 | -- constraint imposed by the declared type. However, there is one | |
4380 | -- very important exception to this rule. If the entity has an | |
4381 | -- unconstrained nominal subtype, then it acquired its constraints | |
4382 | -- from the expression in the first place, and not only does this | |
4383 | -- mean that the constraint check is not needed, but an attempt to | |
4384 | -- perform the constraint check can cause order order of | |
4385 | -- elaboration problems. | |
70482933 RK |
4386 | |
4387 | if not Is_Constr_Subt_For_U_Nominal (Typ) then | |
4388 | ||
4389 | -- If this is an allocator for an aggregate that has been | |
4390 | -- allocated in place, delay checks until assignments are | |
4391 | -- made, because the discriminants are not initialized. | |
4392 | ||
4393 | if Nkind (Expr) = N_Allocator | |
4394 | and then No_Initialization (Expr) | |
4395 | then | |
4396 | null; | |
4397 | else | |
4398 | Apply_Constraint_Check (Expr, Typ); | |
4399 | end if; | |
4400 | end if; | |
4401 | ||
ea1941af | 4402 | -- Ada 2005 (AI-251): Rewrite the expression that initializes a |
4ce9a2d8 | 4403 | -- class-wide object to ensure that we copy the full object, |
d70d147e GD |
4404 | -- unless we are targetting a VM where interfaces are handled by |
4405 | -- VM itself. Note that if the root type of Typ is an ancestor | |
4406 | -- of Expr's type, both types share the same dispatch table and | |
4407 | -- there is no need to displace the pointer. | |
ea1941af ES |
4408 | |
4409 | -- Replace | |
d70d147e | 4410 | -- CW : I'Class := Obj; |
ea1941af | 4411 | -- by |
d70d147e GD |
4412 | -- Temp : I'Class := I'Class (Base_Address (Obj'Address)); |
4413 | -- CW : I'Class renames Displace (Temp, I'Tag); | |
ea1941af ES |
4414 | |
4415 | if Is_Interface (Typ) | |
d70d147e GD |
4416 | and then Is_Class_Wide_Type (Typ) |
4417 | and then | |
4418 | (Is_Class_Wide_Type (Etype (Expr)) | |
4419 | or else | |
ce2b6ba5 | 4420 | not Is_Ancestor (Root_Type (Typ), Etype (Expr))) |
ea1941af | 4421 | and then Comes_From_Source (Def_Id) |
4ce9a2d8 | 4422 | and then VM_Target = No_VM |
ea1941af ES |
4423 | then |
4424 | declare | |
4425 | Decl_1 : Node_Id; | |
4426 | Decl_2 : Node_Id; | |
70482933 | 4427 | |
ea1941af ES |
4428 | begin |
4429 | Decl_1 := | |
4430 | Make_Object_Declaration (Loc, | |
4431 | Defining_Identifier => | |
4432 | Make_Defining_Identifier (Loc, | |
4433 | New_Internal_Name ('D')), | |
3476f949 | 4434 | |
ea1941af ES |
4435 | Object_Definition => |
4436 | Make_Attribute_Reference (Loc, | |
47cc8d6b ES |
4437 | Prefix => |
4438 | New_Occurrence_Of | |
4439 | (Root_Type (Etype (Def_Id)), Loc), | |
ea1941af | 4440 | Attribute_Name => Name_Class), |
3476f949 | 4441 | |
ea1941af ES |
4442 | Expression => |
4443 | Unchecked_Convert_To | |
4444 | (Class_Wide_Type (Root_Type (Etype (Def_Id))), | |
4445 | Make_Explicit_Dereference (Loc, | |
4446 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), | |
4447 | Make_Function_Call (Loc, | |
4448 | Name => | |
4449 | New_Reference_To (RTE (RE_Base_Address), | |
4450 | Loc), | |
4451 | Parameter_Associations => New_List ( | |
4452 | Make_Attribute_Reference (Loc, | |
4453 | Prefix => Relocate_Node (Expr), | |
4454 | Attribute_Name => Name_Address))))))); | |
3476f949 | 4455 | |
ea1941af ES |
4456 | Insert_Action (N, Decl_1); |
4457 | ||
4458 | Decl_2 := | |
4459 | Make_Object_Renaming_Declaration (Loc, | |
4460 | Defining_Identifier => | |
4461 | Make_Defining_Identifier (Loc, | |
4462 | New_Internal_Name ('D')), | |
4463 | ||
4464 | Subtype_Mark => | |
4465 | Make_Attribute_Reference (Loc, | |
4466 | Prefix => | |
47cc8d6b ES |
4467 | New_Occurrence_Of |
4468 | (Root_Type (Etype (Def_Id)), Loc), | |
ea1941af ES |
4469 | Attribute_Name => Name_Class), |
4470 | ||
4471 | Name => | |
4472 | Unchecked_Convert_To ( | |
4473 | Class_Wide_Type (Root_Type (Etype (Def_Id))), | |
4474 | Make_Explicit_Dereference (Loc, | |
4475 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), | |
4476 | Make_Function_Call (Loc, | |
4477 | Name => | |
4478 | New_Reference_To (RTE (RE_Displace), Loc), | |
4479 | ||
4480 | Parameter_Associations => New_List ( | |
4481 | Make_Attribute_Reference (Loc, | |
4482 | Prefix => | |
4483 | New_Reference_To | |
4484 | (Defining_Identifier (Decl_1), Loc), | |
4485 | Attribute_Name => Name_Address), | |
4486 | ||
4487 | Unchecked_Convert_To (RTE (RE_Tag), | |
4488 | New_Reference_To | |
4489 | (Node | |
4490 | (First_Elmt | |
4491 | (Access_Disp_Table | |
4492 | (Root_Type (Typ)))), | |
4493 | Loc)))))))); | |
4494 | ||
4495 | Rewrite (N, Decl_2); | |
4496 | Analyze (N); | |
4497 | ||
4498 | -- Replace internal identifier of Decl_2 by the identifier | |
4499 | -- found in the sources. We also have to exchange entities | |
4500 | -- containing their defining identifiers to ensure the | |
4501 | -- correct replacement of the object declaration by this | |
4502 | -- object renaming declaration (because such definings | |
4503 | -- identifier have been previously added by Enter_Name to | |
47cc8d6b ES |
4504 | -- the current scope). We must preserve the homonym chain |
4505 | -- of the source entity as well. | |
ea1941af ES |
4506 | |
4507 | Set_Chars (Defining_Identifier (N), Chars (Def_Id)); | |
47cc8d6b | 4508 | Set_Homonym (Defining_Identifier (N), Homonym (Def_Id)); |
ea1941af ES |
4509 | Exchange_Entities (Defining_Identifier (N), Def_Id); |
4510 | ||
4511 | return; | |
4512 | end; | |
4513 | end if; | |
4514 | ||
c42e6724 HK |
4515 | -- If the type is controlled and not inherently limited, then |
4516 | -- the target is adjusted after the copy and attached to the | |
4517 | -- finalization list. However, no adjustment is done in the case | |
4518 | -- where the object was initialized by a call to a function whose | |
4519 | -- result is built in place, since no copy occurred. (Eventually | |
4520 | -- we plan to support in-place function results for some cases | |
4521 | -- of nonlimited types. ???) | |
70482933 | 4522 | |
47cc8d6b | 4523 | if Controlled_Type (Typ) |
c42e6724 | 4524 | and then not Is_Inherently_Limited_Type (Typ) |
47cc8d6b ES |
4525 | and then not BIP_Call |
4526 | then | |
93188a0b | 4527 | Insert_Actions_After (Init_After, |
47cc8d6b ES |
4528 | Make_Adjust_Call ( |
4529 | Ref => New_Reference_To (Def_Id, Loc), | |
4530 | Typ => Base_Type (Typ), | |
4531 | Flist_Ref => Find_Final_List (Def_Id), | |
4532 | With_Attach => Make_Integer_Literal (Loc, 1))); | |
70482933 RK |
4533 | end if; |
4534 | ||
a9d8907c JM |
4535 | -- For tagged types, when an init value is given, the tag has to |
4536 | -- be re-initialized separately in order to avoid the propagation | |
4537 | -- of a wrong tag coming from a view conversion unless the type | |
a05e99a2 | 4538 | -- is class wide (in this case the tag comes from the init value). |
47cc8d6b | 4539 | -- Suppress the tag assignment when VM_Target because VM tags are |
a05e99a2 JM |
4540 | -- represented implicitly in objects. Ditto for types that are |
4541 | -- CPP_CLASS, and for initializations that are aggregates, because | |
4542 | -- they have to have the right tag. | |
70482933 RK |
4543 | |
4544 | if Is_Tagged_Type (Typ) | |
4545 | and then not Is_Class_Wide_Type (Typ) | |
4546 | and then not Is_CPP_Class (Typ) | |
47cc8d6b | 4547 | and then VM_Target = No_VM |
a9d8907c | 4548 | and then Nkind (Expr) /= N_Aggregate |
70482933 | 4549 | then |
a05e99a2 JM |
4550 | -- The re-assignment of the tag has to be done even if the |
4551 | -- object is a constant. | |
70482933 RK |
4552 | |
4553 | New_Ref := | |
4554 | Make_Selected_Component (Loc, | |
4555 | Prefix => New_Reference_To (Def_Id, Loc), | |
4556 | Selector_Name => | |
a9d8907c | 4557 | New_Reference_To (First_Tag_Component (Typ), Loc)); |
70482933 RK |
4558 | |
4559 | Set_Assignment_OK (New_Ref); | |
4560 | ||
93188a0b | 4561 | Insert_After (Init_After, |
70482933 RK |
4562 | Make_Assignment_Statement (Loc, |
4563 | Name => New_Ref, | |
4564 | Expression => | |
4565 | Unchecked_Convert_To (RTE (RE_Tag), | |
4566 | New_Reference_To | |
a9d8907c JM |
4567 | (Node |
4568 | (First_Elmt | |
4569 | (Access_Disp_Table (Base_Type (Typ)))), | |
4570 | Loc)))); | |
70482933 RK |
4571 | |
4572 | -- For discrete types, set the Is_Known_Valid flag if the | |
4573 | -- initializing value is known to be valid. | |
4574 | ||
a05e99a2 | 4575 | elsif Is_Discrete_Type (Typ) and then Expr_Known_Valid (Expr) then |
70482933 | 4576 | Set_Is_Known_Valid (Def_Id); |
fbf5a39b | 4577 | |
2820d220 | 4578 | elsif Is_Access_Type (Typ) then |
fbf5a39b | 4579 | |
2820d220 | 4580 | -- For access types set the Is_Known_Non_Null flag if the |
a9d8907c JM |
4581 | -- initializing value is known to be non-null. We can also set |
4582 | -- Can_Never_Be_Null if this is a constant. | |
2820d220 AC |
4583 | |
4584 | if Known_Non_Null (Expr) then | |
a05e99a2 | 4585 | Set_Is_Known_Non_Null (Def_Id, True); |
2820d220 AC |
4586 | |
4587 | if Constant_Present (N) then | |
4588 | Set_Can_Never_Be_Null (Def_Id); | |
4589 | end if; | |
fbf5a39b | 4590 | end if; |
70482933 RK |
4591 | end if; |
4592 | ||
4ce9a2d8 HK |
4593 | -- If validity checking on copies, validate initial expression. |
4594 | -- But skip this if declaration is for a generic type, since it | |
4595 | -- makes no sense to validate generic types. Not clear if this | |
4596 | -- can happen for legal programs, but it definitely can arise | |
4597 | -- from previous instantiation errors. | |
70482933 RK |
4598 | |
4599 | if Validity_Checks_On | |
4ce9a2d8 HK |
4600 | and then Validity_Check_Copies |
4601 | and then not Is_Generic_Type (Etype (Def_Id)) | |
70482933 RK |
4602 | then |
4603 | Ensure_Valid (Expr); | |
4604 | Set_Is_Known_Valid (Def_Id); | |
4605 | end if; | |
4606 | end if; | |
fbf5a39b | 4607 | |
a05e99a2 JM |
4608 | -- Cases where the back end cannot handle the initialization directly |
4609 | -- In such cases, we expand an assignment that will be appropriately | |
4610 | -- handled by Expand_N_Assignment_Statement. | |
fbf5a39b | 4611 | |
a05e99a2 JM |
4612 | -- The exclusion of the unconstrained case is wrong, but for now it |
4613 | -- is too much trouble ??? | |
fbf5a39b | 4614 | |
a9d8907c JM |
4615 | if (Is_Possibly_Unaligned_Slice (Expr) |
4616 | or else (Is_Possibly_Unaligned_Object (Expr) | |
4617 | and then not Represented_As_Scalar (Etype (Expr)))) | |
4618 | ||
a05e99a2 JM |
4619 | -- The exclusion of the unconstrained case is wrong, but for now |
4620 | -- it is too much trouble ??? | |
a9d8907c JM |
4621 | |
4622 | and then not (Is_Array_Type (Etype (Expr)) | |
4623 | and then not Is_Constrained (Etype (Expr))) | |
4624 | then | |
fbf5a39b AC |
4625 | declare |
4626 | Stat : constant Node_Id := | |
4627 | Make_Assignment_Statement (Loc, | |
a9d8907c | 4628 | Name => New_Reference_To (Def_Id, Loc), |
fbf5a39b | 4629 | Expression => Relocate_Node (Expr)); |
fbf5a39b AC |
4630 | begin |
4631 | Set_Expression (N, Empty); | |
4632 | Set_No_Initialization (N); | |
4633 | Set_Assignment_OK (Name (Stat)); | |
a9d8907c | 4634 | Set_No_Ctrl_Actions (Stat); |
93188a0b | 4635 | Insert_After_And_Analyze (Init_After, Stat); |
fbf5a39b AC |
4636 | end; |
4637 | end if; | |
70482933 RK |
4638 | end if; |
4639 | ||
fbf5a39b AC |
4640 | exception |
4641 | when RE_Not_Available => | |
4642 | return; | |
70482933 RK |
4643 | end Expand_N_Object_Declaration; |
4644 | ||
4645 | --------------------------------- | |
4646 | -- Expand_N_Subtype_Indication -- | |
4647 | --------------------------------- | |
4648 | ||
a9d8907c JM |
4649 | -- Add a check on the range of the subtype. The static case is partially |
4650 | -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need | |
4651 | -- to check here for the static case in order to avoid generating | |
3476f949 | 4652 | -- extraneous expanded code. Also deal with validity checking. |
70482933 RK |
4653 | |
4654 | procedure Expand_N_Subtype_Indication (N : Node_Id) is | |
fbf5a39b AC |
4655 | Ran : constant Node_Id := Range_Expression (Constraint (N)); |
4656 | Typ : constant Entity_Id := Entity (Subtype_Mark (N)); | |
70482933 RK |
4657 | |
4658 | begin | |
3476f949 JM |
4659 | if Nkind (Constraint (N)) = N_Range_Constraint then |
4660 | Validity_Check_Range (Range_Expression (Constraint (N))); | |
4661 | end if; | |
4662 | ||
4ce9a2d8 | 4663 | if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then |
70482933 RK |
4664 | Apply_Range_Check (Ran, Typ); |
4665 | end if; | |
4666 | end Expand_N_Subtype_Indication; | |
4667 | ||
4668 | --------------------------- | |
4669 | -- Expand_N_Variant_Part -- | |
4670 | --------------------------- | |
4671 | ||
a9d8907c JM |
4672 | -- If the last variant does not contain the Others choice, replace it with |
4673 | -- an N_Others_Choice node since Gigi always wants an Others. Note that we | |
4674 | -- do not bother to call Analyze on the modified variant part, since it's | |
ea1941af ES |
4675 | -- only effect would be to compute the Others_Discrete_Choices node |
4676 | -- laboriously, and of course we already know the list of choices that | |
4677 | -- corresponds to the others choice (it's the list we are replacing!) | |
70482933 RK |
4678 | |
4679 | procedure Expand_N_Variant_Part (N : Node_Id) is | |
4680 | Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N)); | |
4681 | Others_Node : Node_Id; | |
70482933 RK |
4682 | begin |
4683 | if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then | |
4684 | Others_Node := Make_Others_Choice (Sloc (Last_Var)); | |
4685 | Set_Others_Discrete_Choices | |
4686 | (Others_Node, Discrete_Choices (Last_Var)); | |
4687 | Set_Discrete_Choices (Last_Var, New_List (Others_Node)); | |
4688 | end if; | |
4689 | end Expand_N_Variant_Part; | |
4690 | ||
4691 | --------------------------------- | |
4692 | -- Expand_Previous_Access_Type -- | |
4693 | --------------------------------- | |
4694 | ||
07fc65c4 | 4695 | procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is |
70482933 RK |
4696 | T : Entity_Id := First_Entity (Current_Scope); |
4697 | ||
4698 | begin | |
4699 | -- Find all access types declared in the current scope, whose | |
4ce9a2d8 HK |
4700 | -- designated type is Def_Id. If it does not have a Master_Id, |
4701 | -- create one now. | |
70482933 RK |
4702 | |
4703 | while Present (T) loop | |
4704 | if Is_Access_Type (T) | |
4705 | and then Designated_Type (T) = Def_Id | |
4ce9a2d8 | 4706 | and then No (Master_Id (T)) |
70482933 RK |
4707 | then |
4708 | Build_Master_Entity (Def_Id); | |
4709 | Build_Master_Renaming (Parent (Def_Id), T); | |
4710 | end if; | |
4711 | ||
4712 | Next_Entity (T); | |
4713 | end loop; | |
4714 | end Expand_Previous_Access_Type; | |
4715 | ||
4716 | ------------------------------ | |
4717 | -- Expand_Record_Controller -- | |
4718 | ------------------------------ | |
4719 | ||
4720 | procedure Expand_Record_Controller (T : Entity_Id) is | |
4721 | Def : Node_Id := Type_Definition (Parent (T)); | |
4722 | Comp_List : Node_Id; | |
4723 | Comp_Decl : Node_Id; | |
4724 | Loc : Source_Ptr; | |
4725 | First_Comp : Node_Id; | |
4726 | Controller_Type : Entity_Id; | |
4727 | Ent : Entity_Id; | |
4728 | ||
4729 | begin | |
4730 | if Nkind (Def) = N_Derived_Type_Definition then | |
4731 | Def := Record_Extension_Part (Def); | |
4732 | end if; | |
4733 | ||
4734 | if Null_Present (Def) then | |
4735 | Set_Component_List (Def, | |
4736 | Make_Component_List (Sloc (Def), | |
4737 | Component_Items => Empty_List, | |
4738 | Variant_Part => Empty, | |
4739 | Null_Present => True)); | |
4740 | end if; | |
4741 | ||
4742 | Comp_List := Component_List (Def); | |
4743 | ||
4744 | if Null_Present (Comp_List) | |
4745 | or else Is_Empty_List (Component_Items (Comp_List)) | |
4746 | then | |
4747 | Loc := Sloc (Comp_List); | |
4748 | else | |
4749 | Loc := Sloc (First (Component_Items (Comp_List))); | |
4750 | end if; | |
4751 | ||
3476f949 | 4752 | if Is_Inherently_Limited_Type (T) then |
70482933 RK |
4753 | Controller_Type := RTE (RE_Limited_Record_Controller); |
4754 | else | |
4755 | Controller_Type := RTE (RE_Record_Controller); | |
4756 | end if; | |
4757 | ||
4758 | Ent := Make_Defining_Identifier (Loc, Name_uController); | |
4759 | ||
4760 | Comp_Decl := | |
4761 | Make_Component_Declaration (Loc, | |
4762 | Defining_Identifier => Ent, | |
a397db96 AC |
4763 | Component_Definition => |
4764 | Make_Component_Definition (Loc, | |
4765 | Aliased_Present => False, | |
4766 | Subtype_Indication => New_Reference_To (Controller_Type, Loc))); | |
70482933 RK |
4767 | |
4768 | if Null_Present (Comp_List) | |
4769 | or else Is_Empty_List (Component_Items (Comp_List)) | |
4770 | then | |
4771 | Set_Component_Items (Comp_List, New_List (Comp_Decl)); | |
4772 | Set_Null_Present (Comp_List, False); | |
4773 | ||
4774 | else | |
a9d8907c | 4775 | -- The controller cannot be placed before the _Parent field since |
ea1941af ES |
4776 | -- gigi lays out field in order and _parent must be first to preserve |
4777 | -- the polymorphism of tagged types. | |
70482933 RK |
4778 | |
4779 | First_Comp := First (Component_Items (Comp_List)); | |
4780 | ||
3476f949 | 4781 | if not Is_Tagged_Type (T) then |
70482933 | 4782 | Insert_Before (First_Comp, Comp_Decl); |
3476f949 | 4783 | |
47cc8d6b ES |
4784 | -- if T is a tagged type, place controller declaration after parent |
4785 | -- field and after eventual tags of interface types. | |
3476f949 | 4786 | |
70482933 | 4787 | else |
3476f949 JM |
4788 | while Present (First_Comp) |
4789 | and then | |
4790 | (Chars (Defining_Identifier (First_Comp)) = Name_uParent | |
47cc8d6b ES |
4791 | or else Is_Tag (Defining_Identifier (First_Comp)) |
4792 | ||
4793 | -- Ada 2005 (AI-251): The following condition covers secondary | |
8fc789c8 | 4794 | -- tags but also the adjacent component containing the offset |
47cc8d6b | 4795 | -- to the base of the object (component generated if the parent |
04df6250 TQ |
4796 | -- has discriminants --- see Add_Interface_Tag_Components). |
4797 | -- This is required to avoid the addition of the controller | |
4798 | -- between the secondary tag and its adjacent component. | |
47cc8d6b ES |
4799 | |
4800 | or else Present | |
4ce9a2d8 | 4801 | (Related_Type |
47cc8d6b | 4802 | (Defining_Identifier (First_Comp)))) |
3476f949 JM |
4803 | loop |
4804 | Next (First_Comp); | |
4805 | end loop; | |
4806 | ||
4807 | -- An empty tagged extension might consist only of the parent | |
4808 | -- component. Otherwise insert the controller before the first | |
4809 | -- component that is neither parent nor tag. | |
4810 | ||
4811 | if Present (First_Comp) then | |
4812 | Insert_Before (First_Comp, Comp_Decl); | |
4813 | else | |
4814 | Append (Comp_Decl, Component_Items (Comp_List)); | |
4815 | end if; | |
70482933 RK |
4816 | end if; |
4817 | end if; | |
4818 | ||
47cc8d6b | 4819 | Push_Scope (T); |
70482933 RK |
4820 | Analyze (Comp_Decl); |
4821 | Set_Ekind (Ent, E_Component); | |
4822 | Init_Component_Location (Ent); | |
4823 | ||
a9d8907c JM |
4824 | -- Move the _controller entity ahead in the list of internal entities |
4825 | -- of the enclosing record so that it is selected instead of a | |
4826 | -- potentially inherited one. | |
70482933 RK |
4827 | |
4828 | declare | |
fbf5a39b | 4829 | E : constant Entity_Id := Last_Entity (T); |
70482933 RK |
4830 | Comp : Entity_Id; |
4831 | ||
4832 | begin | |
4833 | pragma Assert (Chars (E) = Name_uController); | |
4834 | ||
4835 | Set_Next_Entity (E, First_Entity (T)); | |
4836 | Set_First_Entity (T, E); | |
4837 | ||
4838 | Comp := Next_Entity (E); | |
4839 | while Next_Entity (Comp) /= E loop | |
4840 | Next_Entity (Comp); | |
4841 | end loop; | |
4842 | ||
4843 | Set_Next_Entity (Comp, Empty); | |
4844 | Set_Last_Entity (T, Comp); | |
4845 | end; | |
4846 | ||
4847 | End_Scope; | |
fbf5a39b AC |
4848 | |
4849 | exception | |
4850 | when RE_Not_Available => | |
4851 | return; | |
70482933 RK |
4852 | end Expand_Record_Controller; |
4853 | ||
4854 | ------------------------ | |
4855 | -- Expand_Tagged_Root -- | |
4856 | ------------------------ | |
4857 | ||
4858 | procedure Expand_Tagged_Root (T : Entity_Id) is | |
4859 | Def : constant Node_Id := Type_Definition (Parent (T)); | |
4860 | Comp_List : Node_Id; | |
4861 | Comp_Decl : Node_Id; | |
4862 | Sloc_N : Source_Ptr; | |
4863 | ||
4864 | begin | |
4865 | if Null_Present (Def) then | |
4866 | Set_Component_List (Def, | |
4867 | Make_Component_List (Sloc (Def), | |
4868 | Component_Items => Empty_List, | |
4869 | Variant_Part => Empty, | |
4870 | Null_Present => True)); | |
4871 | end if; | |
4872 | ||
4873 | Comp_List := Component_List (Def); | |
4874 | ||
4875 | if Null_Present (Comp_List) | |
4876 | or else Is_Empty_List (Component_Items (Comp_List)) | |
4877 | then | |
4878 | Sloc_N := Sloc (Comp_List); | |
4879 | else | |
4880 | Sloc_N := Sloc (First (Component_Items (Comp_List))); | |
4881 | end if; | |
4882 | ||
4883 | Comp_Decl := | |
4884 | Make_Component_Declaration (Sloc_N, | |
a9d8907c | 4885 | Defining_Identifier => First_Tag_Component (T), |
a397db96 AC |
4886 | Component_Definition => |
4887 | Make_Component_Definition (Sloc_N, | |
4888 | Aliased_Present => False, | |
4889 | Subtype_Indication => New_Reference_To (RTE (RE_Tag), Sloc_N))); | |
70482933 RK |
4890 | |
4891 | if Null_Present (Comp_List) | |
4892 | or else Is_Empty_List (Component_Items (Comp_List)) | |
4893 | then | |
4894 | Set_Component_Items (Comp_List, New_List (Comp_Decl)); | |
4895 | Set_Null_Present (Comp_List, False); | |
4896 | ||
4897 | else | |
4898 | Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); | |
4899 | end if; | |
4900 | ||
4901 | -- We don't Analyze the whole expansion because the tag component has | |
a9d8907c JM |
4902 | -- already been analyzed previously. Here we just insure that the tree |
4903 | -- is coherent with the semantic decoration | |
70482933 | 4904 | |
a397db96 | 4905 | Find_Type (Subtype_Indication (Component_Definition (Comp_Decl))); |
fbf5a39b AC |
4906 | |
4907 | exception | |
4908 | when RE_Not_Available => | |
4909 | return; | |
70482933 RK |
4910 | end Expand_Tagged_Root; |
4911 | ||
3476f949 JM |
4912 | ---------------------- |
4913 | -- Clean_Task_Names -- | |
4914 | ---------------------- | |
4915 | ||
4916 | procedure Clean_Task_Names | |
4917 | (Typ : Entity_Id; | |
4918 | Proc_Id : Entity_Id) | |
4919 | is | |
4920 | begin | |
4921 | if Has_Task (Typ) | |
4922 | and then not Restriction_Active (No_Implicit_Heap_Allocations) | |
4923 | and then not Global_Discard_Names | |
47cc8d6b | 4924 | and then VM_Target = No_VM |
3476f949 JM |
4925 | then |
4926 | Set_Uses_Sec_Stack (Proc_Id); | |
4927 | end if; | |
4928 | end Clean_Task_Names; | |
4929 | ||
70482933 RK |
4930 | ----------------------- |
4931 | -- Freeze_Array_Type -- | |
4932 | ----------------------- | |
4933 | ||
4934 | procedure Freeze_Array_Type (N : Node_Id) is | |
04df6250 TQ |
4935 | Typ : constant Entity_Id := Entity (N); |
4936 | Comp_Typ : constant Entity_Id := Component_Type (Typ); | |
4937 | Base : constant Entity_Id := Base_Type (Typ); | |
70482933 RK |
4938 | |
4939 | begin | |
70482933 RK |
4940 | if not Is_Bit_Packed_Array (Typ) then |
4941 | ||
a9d8907c JM |
4942 | -- If the component contains tasks, so does the array type. This may |
4943 | -- not be indicated in the array type because the component may have | |
4944 | -- been a private type at the point of definition. Same if component | |
4945 | -- type is controlled. | |
70482933 | 4946 | |
04df6250 | 4947 | Set_Has_Task (Base, Has_Task (Comp_Typ)); |
70482933 | 4948 | Set_Has_Controlled_Component (Base, |
04df6250 TQ |
4949 | Has_Controlled_Component (Comp_Typ) |
4950 | or else Is_Controlled (Comp_Typ)); | |
70482933 RK |
4951 | |
4952 | if No (Init_Proc (Base)) then | |
4953 | ||
a9d8907c JM |
4954 | -- If this is an anonymous array created for a declaration with |
4955 | -- an initial value, its init_proc will never be called. The | |
47cc8d6b ES |
4956 | -- initial value itself may have been expanded into assignments, |
4957 | -- in which case the object declaration is carries the | |
70482933 RK |
4958 | -- No_Initialization flag. |
4959 | ||
4960 | if Is_Itype (Base) | |
4961 | and then Nkind (Associated_Node_For_Itype (Base)) = | |
4962 | N_Object_Declaration | |
4963 | and then (Present (Expression (Associated_Node_For_Itype (Base))) | |
4964 | or else | |
4965 | No_Initialization (Associated_Node_For_Itype (Base))) | |
4966 | then | |
4967 | null; | |
4968 | ||
82c80734 RD |
4969 | -- We do not need an init proc for string or wide [wide] string, |
4970 | -- since the only time these need initialization in normalize or | |
70482933 RK |
4971 | -- initialize scalars mode, and these types are treated specially |
4972 | -- and do not need initialization procedures. | |
4973 | ||
ecad994d AC |
4974 | elsif Root_Type (Base) = Standard_String |
4975 | or else Root_Type (Base) = Standard_Wide_String | |
82c80734 | 4976 | or else Root_Type (Base) = Standard_Wide_Wide_String |
70482933 RK |
4977 | then |
4978 | null; | |
4979 | ||
4980 | -- Otherwise we have to build an init proc for the subtype | |
4981 | ||
4982 | else | |
4983 | Build_Array_Init_Proc (Base, N); | |
4984 | end if; | |
4985 | end if; | |
4986 | ||
04df6250 TQ |
4987 | if Typ = Base then |
4988 | if Has_Controlled_Component (Base) then | |
4989 | Build_Controlling_Procs (Base); | |
26fd4eae | 4990 | |
04df6250 TQ |
4991 | if not Is_Limited_Type (Comp_Typ) |
4992 | and then Number_Dimensions (Typ) = 1 | |
4993 | then | |
4994 | Build_Slice_Assignment (Typ); | |
4995 | end if; | |
4996 | ||
4997 | elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type | |
4998 | and then Controlled_Type (Directly_Designated_Type (Comp_Typ)) | |
26fd4eae | 4999 | then |
04df6250 | 5000 | Set_Associated_Final_Chain (Comp_Typ, Add_Final_Chain (Typ)); |
26fd4eae | 5001 | end if; |
70482933 | 5002 | end if; |
fbf5a39b | 5003 | |
04df6250 TQ |
5004 | -- For packed case, default initialization, except if the component type |
5005 | -- is itself a packed structure with an initialization procedure, or | |
ae7adb1b ES |
5006 | -- initialize/normalize scalars active, and we have a base type, or the |
5007 | -- type is public, because in that case a client might specify | |
5008 | -- Normalize_Scalars and there better be a public Init_Proc for it. | |
fbf5a39b | 5009 | |
04df6250 TQ |
5010 | elsif (Present (Init_Proc (Component_Type (Base))) |
5011 | and then No (Base_Init_Proc (Base))) | |
5012 | or else (Init_Or_Norm_Scalars and then Base = Typ) | |
ae7adb1b | 5013 | or else Is_Public (Typ) |
fbf5a39b AC |
5014 | then |
5015 | Build_Array_Init_Proc (Base, N); | |
70482933 RK |
5016 | end if; |
5017 | end Freeze_Array_Type; | |
5018 | ||
5019 | ----------------------------- | |
5020 | -- Freeze_Enumeration_Type -- | |
5021 | ----------------------------- | |
5022 | ||
5023 | procedure Freeze_Enumeration_Type (N : Node_Id) is | |
fbf5a39b AC |
5024 | Typ : constant Entity_Id := Entity (N); |
5025 | Loc : constant Source_Ptr := Sloc (Typ); | |
5026 | Ent : Entity_Id; | |
5027 | Lst : List_Id; | |
5028 | Num : Nat; | |
5029 | Arr : Entity_Id; | |
5030 | Fent : Entity_Id; | |
5031 | Ityp : Entity_Id; | |
5032 | Is_Contiguous : Boolean; | |
5033 | Pos_Expr : Node_Id; | |
5034 | Last_Repval : Uint; | |
5035 | ||
70482933 | 5036 | Func : Entity_Id; |
fbf5a39b | 5037 | pragma Warnings (Off, Func); |
70482933 RK |
5038 | |
5039 | begin | |
04df6250 | 5040 | -- Various optimizations possible if given representation is contiguous |
70482933 | 5041 | |
fbf5a39b | 5042 | Is_Contiguous := True; |
04df6250 | 5043 | |
70482933 | 5044 | Ent := First_Literal (Typ); |
fbf5a39b | 5045 | Last_Repval := Enumeration_Rep (Ent); |
fbf5a39b | 5046 | |
04df6250 | 5047 | Next_Literal (Ent); |
70482933 | 5048 | while Present (Ent) loop |
fbf5a39b AC |
5049 | if Enumeration_Rep (Ent) - Last_Repval /= 1 then |
5050 | Is_Contiguous := False; | |
5051 | exit; | |
5052 | else | |
5053 | Last_Repval := Enumeration_Rep (Ent); | |
5054 | end if; | |
5055 | ||
70482933 RK |
5056 | Next_Literal (Ent); |
5057 | end loop; | |
5058 | ||
fbf5a39b AC |
5059 | if Is_Contiguous then |
5060 | Set_Has_Contiguous_Rep (Typ); | |
5061 | Ent := First_Literal (Typ); | |
5062 | Num := 1; | |
5063 | Lst := New_List (New_Reference_To (Ent, Sloc (Ent))); | |
5064 | ||
5065 | else | |
5066 | -- Build list of literal references | |
5067 | ||
5068 | Lst := New_List; | |
5069 | Num := 0; | |
5070 | ||
5071 | Ent := First_Literal (Typ); | |
5072 | while Present (Ent) loop | |
5073 | Append_To (Lst, New_Reference_To (Ent, Sloc (Ent))); | |
5074 | Num := Num + 1; | |
5075 | Next_Literal (Ent); | |
5076 | end loop; | |
5077 | end if; | |
5078 | ||
a5b62485 | 5079 | -- Now build an array declaration |
70482933 RK |
5080 | |
5081 | -- typA : array (Natural range 0 .. num - 1) of ctype := | |
fbf5a39b | 5082 | -- (v, v, v, v, v, ....) |
70482933 | 5083 | |
a9d8907c JM |
5084 | -- where ctype is the corresponding integer type. If the representation |
5085 | -- is contiguous, we only keep the first literal, which provides the | |
5086 | -- offset for Pos_To_Rep computations. | |
70482933 RK |
5087 | |
5088 | Arr := | |
5089 | Make_Defining_Identifier (Loc, | |
5090 | Chars => New_External_Name (Chars (Typ), 'A')); | |
5091 | ||
5092 | Append_Freeze_Action (Typ, | |
5093 | Make_Object_Declaration (Loc, | |
5094 | Defining_Identifier => Arr, | |
5095 | Constant_Present => True, | |
5096 | ||
5097 | Object_Definition => | |
5098 | Make_Constrained_Array_Definition (Loc, | |
5099 | Discrete_Subtype_Definitions => New_List ( | |
5100 | Make_Subtype_Indication (Loc, | |
5101 | Subtype_Mark => New_Reference_To (Standard_Natural, Loc), | |
5102 | Constraint => | |
5103 | Make_Range_Constraint (Loc, | |
5104 | Range_Expression => | |
5105 | Make_Range (Loc, | |
5106 | Low_Bound => | |
5107 | Make_Integer_Literal (Loc, 0), | |
5108 | High_Bound => | |
5109 | Make_Integer_Literal (Loc, Num - 1))))), | |
5110 | ||
a397db96 AC |
5111 | Component_Definition => |
5112 | Make_Component_Definition (Loc, | |
5113 | Aliased_Present => False, | |
5114 | Subtype_Indication => New_Reference_To (Typ, Loc))), | |
70482933 RK |
5115 | |
5116 | Expression => | |
5117 | Make_Aggregate (Loc, | |
5118 | Expressions => Lst))); | |
5119 | ||
5120 | Set_Enum_Pos_To_Rep (Typ, Arr); | |
5121 | ||
5122 | -- Now we build the function that converts representation values to | |
5123 | -- position values. This function has the form: | |
5124 | ||
5125 | -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is | |
5126 | -- begin | |
5127 | -- case ityp!(A) is | |
5128 | -- when enum-lit'Enum_Rep => return posval; | |
5129 | -- when enum-lit'Enum_Rep => return posval; | |
5130 | -- ... | |
5131 | -- when others => | |
fbf5a39b | 5132 | -- [raise Constraint_Error when F "invalid data"] |
70482933 RK |
5133 | -- return -1; |
5134 | -- end case; | |
5135 | -- end; | |
5136 | ||
5137 | -- Note: the F parameter determines whether the others case (no valid | |
fbf5a39b AC |
5138 | -- representation) raises Constraint_Error or returns a unique value |
5139 | -- of minus one. The latter case is used, e.g. in 'Valid code. | |
70482933 | 5140 | |
a9d8907c JM |
5141 | -- Note: the reason we use Enum_Rep values in the case here is to avoid |
5142 | -- the code generator making inappropriate assumptions about the range | |
5143 | -- of the values in the case where the value is invalid. ityp is a | |
5144 | -- signed or unsigned integer type of appropriate width. | |
70482933 | 5145 | |
fbf5a39b AC |
5146 | -- Note: if exceptions are not supported, then we suppress the raise |
5147 | -- and return -1 unconditionally (this is an erroneous program in any | |
a9d8907c JM |
5148 | -- case and there is no obligation to raise Constraint_Error here!) We |
5149 | -- also do this if pragma Restrictions (No_Exceptions) is active. | |
70482933 | 5150 | |
47cc8d6b ES |
5151 | -- Is this right??? What about No_Exception_Propagation??? |
5152 | ||
fbf5a39b | 5153 | -- Representations are signed |
70482933 | 5154 | |
fbf5a39b | 5155 | if Enumeration_Rep (First_Literal (Typ)) < 0 then |
70482933 | 5156 | |
fbf5a39b | 5157 | -- The underlying type is signed. Reset the Is_Unsigned_Type |
a9d8907c | 5158 | -- explicitly, because it might have been inherited from |
fbf5a39b | 5159 | -- parent type. |
70482933 | 5160 | |
fbf5a39b | 5161 | Set_Is_Unsigned_Type (Typ, False); |
70482933 | 5162 | |
70482933 RK |
5163 | if Esize (Typ) <= Standard_Integer_Size then |
5164 | Ityp := Standard_Integer; | |
5165 | else | |
5166 | Ityp := Universal_Integer; | |
5167 | end if; | |
5168 | ||
5169 | -- Representations are unsigned | |
5170 | ||
5171 | else | |
5172 | if Esize (Typ) <= Standard_Integer_Size then | |
5173 | Ityp := RTE (RE_Unsigned); | |
5174 | else | |
5175 | Ityp := RTE (RE_Long_Long_Unsigned); | |
5176 | end if; | |
5177 | end if; | |
5178 | ||
a9d8907c JM |
5179 | -- The body of the function is a case statement. First collect case |
5180 | -- alternatives, or optimize the contiguous case. | |
fbf5a39b AC |
5181 | |
5182 | Lst := New_List; | |
5183 | ||
5184 | -- If representation is contiguous, Pos is computed by subtracting | |
5185 | -- the representation of the first literal. | |
5186 | ||
5187 | if Is_Contiguous then | |
5188 | Ent := First_Literal (Typ); | |
5189 | ||
5190 | if Enumeration_Rep (Ent) = Last_Repval then | |
5191 | ||
a5b62485 | 5192 | -- Another special case: for a single literal, Pos is zero |
fbf5a39b AC |
5193 | |
5194 | Pos_Expr := Make_Integer_Literal (Loc, Uint_0); | |
5195 | ||
5196 | else | |
5197 | Pos_Expr := | |
5198 | Convert_To (Standard_Integer, | |
5199 | Make_Op_Subtract (Loc, | |
5200 | Left_Opnd => | |
5201 | Unchecked_Convert_To (Ityp, | |
5202 | Make_Identifier (Loc, Name_uA)), | |
5203 | Right_Opnd => | |
5204 | Make_Integer_Literal (Loc, | |
5205 | Intval => | |
5206 | Enumeration_Rep (First_Literal (Typ))))); | |
5207 | end if; | |
5208 | ||
5209 | Append_To (Lst, | |
5210 | Make_Case_Statement_Alternative (Loc, | |
5211 | Discrete_Choices => New_List ( | |
5212 | Make_Range (Sloc (Enumeration_Rep_Expr (Ent)), | |
5213 | Low_Bound => | |
5214 | Make_Integer_Literal (Loc, | |
5215 | Intval => Enumeration_Rep (Ent)), | |
5216 | High_Bound => | |
5217 | Make_Integer_Literal (Loc, Intval => Last_Repval))), | |
5218 | ||
5219 | Statements => New_List ( | |
04df6250 | 5220 | Make_Simple_Return_Statement (Loc, |
fbf5a39b AC |
5221 | Expression => Pos_Expr)))); |
5222 | ||
5223 | else | |
5224 | Ent := First_Literal (Typ); | |
fbf5a39b AC |
5225 | while Present (Ent) loop |
5226 | Append_To (Lst, | |
5227 | Make_Case_Statement_Alternative (Loc, | |
5228 | Discrete_Choices => New_List ( | |
5229 | Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)), | |
5230 | Intval => Enumeration_Rep (Ent))), | |
5231 | ||
5232 | Statements => New_List ( | |
04df6250 | 5233 | Make_Simple_Return_Statement (Loc, |
fbf5a39b AC |
5234 | Expression => |
5235 | Make_Integer_Literal (Loc, | |
5236 | Intval => Enumeration_Pos (Ent)))))); | |
5237 | ||
5238 | Next_Literal (Ent); | |
5239 | end loop; | |
5240 | end if; | |
5241 | ||
70482933 RK |
5242 | -- In normal mode, add the others clause with the test |
5243 | ||
47cc8d6b | 5244 | if not No_Exception_Handlers_Set then |
70482933 RK |
5245 | Append_To (Lst, |
5246 | Make_Case_Statement_Alternative (Loc, | |
5247 | Discrete_Choices => New_List (Make_Others_Choice (Loc)), | |
5248 | Statements => New_List ( | |
fbf5a39b | 5249 | Make_Raise_Constraint_Error (Loc, |
07fc65c4 | 5250 | Condition => Make_Identifier (Loc, Name_uF), |
fbf5a39b | 5251 | Reason => CE_Invalid_Data), |
04df6250 | 5252 | Make_Simple_Return_Statement (Loc, |
70482933 RK |
5253 | Expression => |
5254 | Make_Integer_Literal (Loc, -1))))); | |
5255 | ||
47cc8d6b ES |
5256 | -- If either of the restrictions No_Exceptions_Handlers/Propagation is |
5257 | -- active then return -1 (we cannot usefully raise Constraint_Error in | |
fbf5a39b | 5258 | -- this case). See description above for further details. |
70482933 RK |
5259 | |
5260 | else | |
5261 | Append_To (Lst, | |
5262 | Make_Case_Statement_Alternative (Loc, | |
5263 | Discrete_Choices => New_List (Make_Others_Choice (Loc)), | |
5264 | Statements => New_List ( | |
04df6250 | 5265 | Make_Simple_Return_Statement (Loc, |
70482933 RK |
5266 | Expression => |
5267 | Make_Integer_Literal (Loc, -1))))); | |
5268 | end if; | |
5269 | ||
5270 | -- Now we can build the function body | |
5271 | ||
5272 | Fent := | |
fbf5a39b | 5273 | Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos)); |
70482933 RK |
5274 | |
5275 | Func := | |
5276 | Make_Subprogram_Body (Loc, | |
5277 | Specification => | |
5278 | Make_Function_Specification (Loc, | |
5279 | Defining_Unit_Name => Fent, | |
5280 | Parameter_Specifications => New_List ( | |
5281 | Make_Parameter_Specification (Loc, | |
5282 | Defining_Identifier => | |
5283 | Make_Defining_Identifier (Loc, Name_uA), | |
5284 | Parameter_Type => New_Reference_To (Typ, Loc)), | |
5285 | Make_Parameter_Specification (Loc, | |
5286 | Defining_Identifier => | |
5287 | Make_Defining_Identifier (Loc, Name_uF), | |
5288 | Parameter_Type => New_Reference_To (Standard_Boolean, Loc))), | |
5289 | ||
10b93b2e | 5290 | Result_Definition => New_Reference_To (Standard_Integer, Loc)), |
70482933 RK |
5291 | |
5292 | Declarations => Empty_List, | |
5293 | ||
5294 | Handled_Statement_Sequence => | |
5295 | Make_Handled_Sequence_Of_Statements (Loc, | |
5296 | Statements => New_List ( | |
5297 | Make_Case_Statement (Loc, | |
5298 | Expression => | |
5299 | Unchecked_Convert_To (Ityp, | |
5300 | Make_Identifier (Loc, Name_uA)), | |
5301 | Alternatives => Lst)))); | |
5302 | ||
5303 | Set_TSS (Typ, Fent); | |
5304 | Set_Is_Pure (Fent); | |
5305 | ||
5306 | if not Debug_Generated_Code then | |
5307 | Set_Debug_Info_Off (Fent); | |
5308 | end if; | |
fbf5a39b AC |
5309 | |
5310 | exception | |
5311 | when RE_Not_Available => | |
5312 | return; | |
70482933 RK |
5313 | end Freeze_Enumeration_Type; |
5314 | ||
5315 | ------------------------ | |
5316 | -- Freeze_Record_Type -- | |
5317 | ------------------------ | |
5318 | ||
5319 | procedure Freeze_Record_Type (N : Node_Id) is | |
ce2b6ba5 JM |
5320 | |
5321 | procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id); | |
5322 | -- Add to the list of primitives of Tagged_Types the internal entities | |
5323 | -- associated with interface primitives that are located in secondary | |
5324 | -- dispatch tables. | |
5325 | ||
5326 | ------------------------------------- | |
5327 | -- Add_Internal_Interface_Entities -- | |
5328 | ------------------------------------- | |
5329 | ||
5330 | procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is | |
5331 | Elmt : Elmt_Id; | |
5332 | Iface : Entity_Id; | |
5333 | Iface_Elmt : Elmt_Id; | |
5334 | Iface_Prim : Entity_Id; | |
5335 | Ifaces_List : Elist_Id; | |
5336 | New_Subp : Entity_Id := Empty; | |
5337 | Prim : Entity_Id; | |
5338 | ||
5339 | begin | |
5340 | pragma Assert (Ada_Version >= Ada_05 | |
5341 | and then Is_Record_Type (Tagged_Type) | |
5342 | and then Is_Tagged_Type (Tagged_Type) | |
5343 | and then Has_Interfaces (Tagged_Type) | |
5344 | and then not Is_Interface (Tagged_Type)); | |
5345 | ||
5346 | Collect_Interfaces (Tagged_Type, Ifaces_List); | |
5347 | ||
5348 | Iface_Elmt := First_Elmt (Ifaces_List); | |
5349 | while Present (Iface_Elmt) loop | |
5350 | Iface := Node (Iface_Elmt); | |
5351 | ||
5352 | -- Exclude from this processing interfaces that are parents | |
5353 | -- of Tagged_Type because their primitives are located in the | |
5354 | -- primary dispatch table (and hence no auxiliary internal | |
5355 | -- entities are required to handle secondary dispatch tables | |
5356 | -- in such case). | |
5357 | ||
5358 | if not Is_Ancestor (Iface, Tagged_Type) then | |
5359 | Elmt := First_Elmt (Primitive_Operations (Iface)); | |
5360 | while Present (Elmt) loop | |
5361 | Iface_Prim := Node (Elmt); | |
5362 | ||
5363 | if not Is_Predefined_Dispatching_Operation (Iface_Prim) then | |
5364 | Prim := | |
5365 | Find_Primitive_Covering_Interface | |
5366 | (Tagged_Type => Tagged_Type, | |
5367 | Iface_Prim => Iface_Prim); | |
5368 | ||
5369 | pragma Assert (Present (Prim)); | |
5370 | ||
5371 | Derive_Subprogram | |
5372 | (New_Subp => New_Subp, | |
5373 | Parent_Subp => Iface_Prim, | |
5374 | Derived_Type => Tagged_Type, | |
5375 | Parent_Type => Iface); | |
5376 | ||
5377 | -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp | |
5378 | -- associated with interface types. These entities are | |
5379 | -- only registered in the list of primitives of its | |
5380 | -- corresponding tagged type because they are only used | |
5381 | -- to fill the contents of the secondary dispatch tables. | |
5382 | -- Therefore they are removed from the homonym chains. | |
5383 | ||
5384 | Set_Is_Hidden (New_Subp); | |
5385 | Set_Is_Internal (New_Subp); | |
5386 | Set_Alias (New_Subp, Prim); | |
5387 | Set_Is_Abstract_Subprogram (New_Subp, | |
5388 | Is_Abstract_Subprogram (Prim)); | |
5389 | Set_Interface_Alias (New_Subp, Iface_Prim); | |
5390 | ||
5391 | -- Internal entities associated with interface types are | |
5392 | -- only registered in the list of primitives of the | |
5393 | -- tagged type. They are only used to fill the contents | |
5394 | -- of the secondary dispatch tables. Therefore they are | |
5395 | -- not needed in the homonym chains. | |
5396 | ||
5397 | Remove_Homonym (New_Subp); | |
5398 | ||
5399 | -- Hidden entities associated with interfaces must have | |
5400 | -- set the Has_Delay_Freeze attribute to ensure that, in | |
5401 | -- case of locally defined tagged types (or compiling | |
5402 | -- with static dispatch tables generation disabled) the | |
5403 | -- corresponding entry of the secondary dispatch table is | |
5404 | -- filled when such entity is frozen. | |
5405 | ||
5406 | Set_Has_Delayed_Freeze (New_Subp); | |
5407 | end if; | |
5408 | ||
5409 | Next_Elmt (Elmt); | |
5410 | end loop; | |
5411 | end if; | |
5412 | ||
5413 | Next_Elmt (Iface_Elmt); | |
5414 | end loop; | |
5415 | end Add_Internal_Interface_Entities; | |
5416 | ||
5417 | -- Local variables | |
5418 | ||
04df6250 TQ |
5419 | Def_Id : constant Node_Id := Entity (N); |
5420 | Type_Decl : constant Node_Id := Parent (Def_Id); | |
5421 | Comp : Entity_Id; | |
5422 | Comp_Typ : Entity_Id; | |
5423 | Has_Static_DT : Boolean := False; | |
5424 | Predef_List : List_Id; | |
5425 | ||
5426 | Flist : Entity_Id := Empty; | |
5427 | -- Finalization list allocated for the case of a type with anonymous | |
5428 | -- access components whose designated type is potentially controlled. | |
5429 | ||
5430 | Renamed_Eq : Node_Id := Empty; | |
4ce9a2d8 HK |
5431 | -- Defining unit name for the predefined equality function in the case |
5432 | -- where the type has a primitive operation that is a renaming of | |
5433 | -- predefined equality (but only if there is also an overriding | |
5434 | -- user-defined equality function). Used to pass this entity from | |
5435 | -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies. | |
70482933 | 5436 | |
3476f949 JM |
5437 | Wrapper_Decl_List : List_Id := No_List; |
5438 | Wrapper_Body_List : List_Id := No_List; | |
5439 | Null_Proc_Decl_List : List_Id := No_List; | |
a05e99a2 | 5440 | |
ce2b6ba5 JM |
5441 | -- Start of processing for Freeze_Record_Type |
5442 | ||
70482933 RK |
5443 | begin |
5444 | -- Build discriminant checking functions if not a derived type (for | |
04df6250 TQ |
5445 | -- derived types that are not tagged types, always use the discriminant |
5446 | -- checking functions of the parent type). However, for untagged types | |
5447 | -- the derivation may have taken place before the parent was frozen, so | |
5448 | -- we copy explicitly the discriminant checking functions from the | |
5449 | -- parent into the components of the derived type. | |
70482933 RK |
5450 | |
5451 | if not Is_Derived_Type (Def_Id) | |
5452 | or else Has_New_Non_Standard_Rep (Def_Id) | |
5453 | or else Is_Tagged_Type (Def_Id) | |
5454 | then | |
5455 | Build_Discr_Checking_Funcs (Type_Decl); | |
5456 | ||
5457 | elsif Is_Derived_Type (Def_Id) | |
5458 | and then not Is_Tagged_Type (Def_Id) | |
5d09245e AC |
5459 | |
5460 | -- If we have a derived Unchecked_Union, we do not inherit the | |
5461 | -- discriminant checking functions from the parent type since the | |
5462 | -- discriminants are non existent. | |
5463 | ||
5464 | and then not Is_Unchecked_Union (Def_Id) | |
70482933 RK |
5465 | and then Has_Discriminants (Def_Id) |
5466 | then | |
5467 | declare | |
5468 | Old_Comp : Entity_Id; | |
5469 | ||
5470 | begin | |
5471 | Old_Comp := | |
5472 | First_Component (Base_Type (Underlying_Type (Etype (Def_Id)))); | |
5473 | Comp := First_Component (Def_Id); | |
70482933 RK |
5474 | while Present (Comp) loop |
5475 | if Ekind (Comp) = E_Component | |
5476 | and then Chars (Comp) = Chars (Old_Comp) | |
5477 | then | |
5478 | Set_Discriminant_Checking_Func (Comp, | |
d70d147e | 5479 | Discriminant_Checking_Func (Old_Comp)); |
70482933 RK |
5480 | end if; |
5481 | ||
5482 | Next_Component (Old_Comp); | |
5483 | Next_Component (Comp); | |
5484 | end loop; | |
5485 | end; | |
5486 | end if; | |
5487 | ||
07fc65c4 GB |
5488 | if Is_Derived_Type (Def_Id) |
5489 | and then Is_Limited_Type (Def_Id) | |
5490 | and then Is_Tagged_Type (Def_Id) | |
5491 | then | |
5492 | Check_Stream_Attributes (Def_Id); | |
5493 | end if; | |
5494 | ||
70482933 RK |
5495 | -- Update task and controlled component flags, because some of the |
5496 | -- component types may have been private at the point of the record | |
5497 | -- declaration. | |
5498 | ||
5499 | Comp := First_Component (Def_Id); | |
5500 | ||
5501 | while Present (Comp) loop | |
04df6250 TQ |
5502 | Comp_Typ := Etype (Comp); |
5503 | ||
5504 | if Has_Task (Comp_Typ) then | |
70482933 RK |
5505 | Set_Has_Task (Def_Id); |
5506 | ||
04df6250 | 5507 | elsif Has_Controlled_Component (Comp_Typ) |
70482933 | 5508 | or else (Chars (Comp) /= Name_uParent |
04df6250 | 5509 | and then Is_Controlled (Comp_Typ)) |
70482933 RK |
5510 | then |
5511 | Set_Has_Controlled_Component (Def_Id); | |
04df6250 TQ |
5512 | |
5513 | elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type | |
5514 | and then Controlled_Type (Directly_Designated_Type (Comp_Typ)) | |
5515 | then | |
5516 | if No (Flist) then | |
5517 | Flist := Add_Final_Chain (Def_Id); | |
5518 | end if; | |
5519 | ||
5520 | Set_Associated_Final_Chain (Comp_Typ, Flist); | |
70482933 RK |
5521 | end if; |
5522 | ||
5523 | Next_Component (Comp); | |
5524 | end loop; | |
5525 | ||
47cc8d6b ES |
5526 | -- Creation of the Dispatch Table. Note that a Dispatch Table is built |
5527 | -- for regular tagged types as well as for Ada types deriving from a C++ | |
5528 | -- Class, but not for tagged types directly corresponding to C++ classes | |
5529 | -- In the later case we assume that it is created in the C++ side and we | |
5530 | -- just use it. | |
70482933 RK |
5531 | |
5532 | if Is_Tagged_Type (Def_Id) then | |
04df6250 TQ |
5533 | Has_Static_DT := |
5534 | Static_Dispatch_Tables | |
5535 | and then Is_Library_Level_Tagged_Type (Def_Id); | |
758c442c | 5536 | |
04df6250 | 5537 | -- Add the _Tag component |
a05e99a2 | 5538 | |
04df6250 TQ |
5539 | if Underlying_Type (Etype (Def_Id)) = Def_Id then |
5540 | Expand_Tagged_Root (Def_Id); | |
5541 | end if; | |
a05e99a2 | 5542 | |
04df6250 | 5543 | if Is_CPP_Class (Def_Id) then |
70482933 RK |
5544 | Set_All_DT_Position (Def_Id); |
5545 | Set_Default_Constructor (Def_Id); | |
5546 | ||
04df6250 | 5547 | -- Create the tag entities with a minimum decoration |
47cc8d6b ES |
5548 | |
5549 | if VM_Target = No_VM then | |
04df6250 | 5550 | Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); |
47cc8d6b ES |
5551 | end if; |
5552 | ||
70482933 | 5553 | else |
04df6250 | 5554 | if not Has_Static_DT then |
70482933 | 5555 | |
47cc8d6b ES |
5556 | -- Usually inherited primitives are not delayed but the first |
5557 | -- Ada extension of a CPP_Class is an exception since the | |
5558 | -- address of the inherited subprogram has to be inserted in | |
5559 | -- the new Ada Dispatch Table and this is a freezing action. | |
e6f69614 | 5560 | |
47cc8d6b ES |
5561 | -- Similarly, if this is an inherited operation whose parent is |
5562 | -- not frozen yet, it is not in the DT of the parent, and we | |
5563 | -- generate an explicit freeze node for the inherited operation | |
5564 | -- so that it is properly inserted in the DT of the current | |
5565 | -- type. | |
5566 | ||
5567 | declare | |
5568 | Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id)); | |
5569 | Subp : Entity_Id; | |
5570 | ||
5571 | begin | |
5572 | while Present (Elmt) loop | |
5573 | Subp := Node (Elmt); | |
5574 | ||
5575 | if Present (Alias (Subp)) then | |
5576 | if Is_CPP_Class (Etype (Def_Id)) then | |
5577 | Set_Has_Delayed_Freeze (Subp); | |
5578 | ||
5579 | elsif Has_Delayed_Freeze (Alias (Subp)) | |
5580 | and then not Is_Frozen (Alias (Subp)) | |
5581 | then | |
5582 | Set_Is_Frozen (Subp, False); | |
5583 | Set_Has_Delayed_Freeze (Subp); | |
5584 | end if; | |
70482933 RK |
5585 | end if; |
5586 | ||
47cc8d6b ES |
5587 | Next_Elmt (Elmt); |
5588 | end loop; | |
5589 | end; | |
5590 | end if; | |
70482933 | 5591 | |
a9d8907c JM |
5592 | -- Unfreeze momentarily the type to add the predefined primitives |
5593 | -- operations. The reason we unfreeze is so that these predefined | |
5594 | -- operations will indeed end up as primitive operations (which | |
5595 | -- must be before the freeze point). | |
70482933 RK |
5596 | |
5597 | Set_Is_Frozen (Def_Id, False); | |
ea1941af | 5598 | |
f2cbd970 JM |
5599 | -- Do not add the spec of predefined primitives in case of |
5600 | -- CPP tagged type derivations that have convention CPP. | |
5601 | ||
5602 | if Is_CPP_Class (Root_Type (Def_Id)) | |
5603 | and then Convention (Def_Id) = Convention_CPP | |
5604 | then | |
5605 | null; | |
5606 | ||
ea1941af ES |
5607 | -- Do not add the spec of the predefined primitives if we are |
5608 | -- compiling under restriction No_Dispatching_Calls | |
5609 | ||
f2cbd970 | 5610 | elsif not Restriction_Active (No_Dispatching_Calls) then |
ea1941af ES |
5611 | Make_Predefined_Primitive_Specs |
5612 | (Def_Id, Predef_List, Renamed_Eq); | |
5613 | Insert_List_Before_And_Analyze (N, Predef_List); | |
5614 | end if; | |
10b93b2e | 5615 | |
a05e99a2 JM |
5616 | -- Ada 2005 (AI-391): For a nonabstract null extension, create |
5617 | -- wrapper functions for each nonoverridden inherited function | |
5618 | -- with a controlling result of the type. The wrapper for such | |
5619 | -- a function returns an extension aggregate that invokes the | |
5620 | -- the parent function. | |
5621 | ||
5622 | if Ada_Version >= Ada_05 | |
ea1941af | 5623 | and then not Is_Abstract_Type (Def_Id) |
a05e99a2 JM |
5624 | and then Is_Null_Extension (Def_Id) |
5625 | then | |
5626 | Make_Controlling_Function_Wrappers | |
5627 | (Def_Id, Wrapper_Decl_List, Wrapper_Body_List); | |
5628 | Insert_List_Before_And_Analyze (N, Wrapper_Decl_List); | |
5629 | end if; | |
5630 | ||
3476f949 JM |
5631 | -- Ada 2005 (AI-251): For a nonabstract type extension, build |
5632 | -- null procedure declarations for each set of homographic null | |
5633 | -- procedures that are inherited from interface types but not | |
5634 | -- overridden. This is done to ensure that the dispatch table | |
5635 | -- entry associated with such null primitives are properly filled. | |
5636 | ||
5637 | if Ada_Version >= Ada_05 | |
5638 | and then Etype (Def_Id) /= Def_Id | |
ea1941af | 5639 | and then not Is_Abstract_Type (Def_Id) |
3476f949 JM |
5640 | then |
5641 | Make_Null_Procedure_Specs (Def_Id, Null_Proc_Decl_List); | |
5642 | Insert_Actions (N, Null_Proc_Decl_List); | |
5643 | end if; | |
5644 | ||
ce2b6ba5 JM |
5645 | -- Ada 2005 (AI-251): Add internal entities associated with |
5646 | -- secondary dispatch tables to the list of primitives of tagged | |
5647 | -- types that are not interfaces | |
5648 | ||
5649 | if Ada_Version >= Ada_05 | |
5650 | and then not Is_Interface (Def_Id) | |
5651 | and then Has_Interfaces (Def_Id) | |
5652 | then | |
5653 | Add_Internal_Interface_Entities (Def_Id); | |
5654 | end if; | |
5655 | ||
47cc8d6b | 5656 | Set_Is_Frozen (Def_Id); |
70482933 RK |
5657 | Set_All_DT_Position (Def_Id); |
5658 | ||
5659 | -- Add the controlled component before the freezing actions | |
a9d8907c | 5660 | -- referenced in those actions. |
70482933 RK |
5661 | |
5662 | if Has_New_Controlled_Component (Def_Id) then | |
5663 | Expand_Record_Controller (Def_Id); | |
5664 | end if; | |
5665 | ||
04df6250 TQ |
5666 | -- Create and decorate the tags. Suppress their creation when |
5667 | -- VM_Target because the dispatching mechanism is handled | |
5668 | -- internally by the VMs. | |
f4d379b8 | 5669 | |
47cc8d6b | 5670 | if VM_Target = No_VM then |
04df6250 TQ |
5671 | Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); |
5672 | ||
5673 | -- Generate dispatch table of locally defined tagged type. | |
5674 | -- Dispatch tables of library level tagged types are built | |
5675 | -- later (see Analyze_Declarations). | |
5676 | ||
5677 | if VM_Target = No_VM | |
5678 | and then not Has_Static_DT | |
5679 | then | |
5680 | Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); | |
5681 | end if; | |
70482933 RK |
5682 | end if; |
5683 | ||
a9d8907c JM |
5684 | -- Make sure that the primitives Initialize, Adjust and Finalize |
5685 | -- are Frozen before other TSS subprograms. We don't want them | |
5686 | -- Frozen inside. | |
70482933 RK |
5687 | |
5688 | if Is_Controlled (Def_Id) then | |
5689 | if not Is_Limited_Type (Def_Id) then | |
5690 | Append_Freeze_Actions (Def_Id, | |
5691 | Freeze_Entity | |
5692 | (Find_Prim_Op (Def_Id, Name_Adjust), Sloc (Def_Id))); | |
5693 | end if; | |
5694 | ||
5695 | Append_Freeze_Actions (Def_Id, | |
5696 | Freeze_Entity | |
5697 | (Find_Prim_Op (Def_Id, Name_Initialize), Sloc (Def_Id))); | |
5698 | ||
5699 | Append_Freeze_Actions (Def_Id, | |
5700 | Freeze_Entity | |
5701 | (Find_Prim_Op (Def_Id, Name_Finalize), Sloc (Def_Id))); | |
5702 | end if; | |
5703 | ||
ea1941af ES |
5704 | -- Freeze rest of primitive operations. There is no need to handle |
5705 | -- the predefined primitives if we are compiling under restriction | |
5706 | -- No_Dispatching_Calls | |
70482933 | 5707 | |
ea1941af ES |
5708 | if not Restriction_Active (No_Dispatching_Calls) then |
5709 | Append_Freeze_Actions | |
5710 | (Def_Id, Predefined_Primitive_Freeze (Def_Id)); | |
5711 | end if; | |
70482933 RK |
5712 | end if; |
5713 | ||
a9d8907c JM |
5714 | -- In the non-tagged case, an equality function is provided only for |
5715 | -- variant records (that are not unchecked unions). | |
70482933 RK |
5716 | |
5717 | elsif Has_Discriminants (Def_Id) | |
5718 | and then not Is_Limited_Type (Def_Id) | |
5719 | then | |
5720 | declare | |
5721 | Comps : constant Node_Id := | |
5722 | Component_List (Type_Definition (Type_Decl)); | |
5723 | ||
5724 | begin | |
5725 | if Present (Comps) | |
5726 | and then Present (Variant_Part (Comps)) | |
70482933 RK |
5727 | then |
5728 | Build_Variant_Record_Equality (Def_Id); | |
5729 | end if; | |
5730 | end; | |
5731 | end if; | |
5732 | ||
5733 | -- Before building the record initialization procedure, if we are | |
a9d8907c JM |
5734 | -- dealing with a concurrent record value type, then we must go through |
5735 | -- the discriminants, exchanging discriminals between the concurrent | |
5736 | -- type and the concurrent record value type. See the section "Handling | |
5737 | -- of Discriminants" in the Einfo spec for details. | |
70482933 RK |
5738 | |
5739 | if Is_Concurrent_Record_Type (Def_Id) | |
5740 | and then Has_Discriminants (Def_Id) | |
5741 | then | |
5742 | declare | |
5743 | Ctyp : constant Entity_Id := | |
5744 | Corresponding_Concurrent_Type (Def_Id); | |
5745 | Conc_Discr : Entity_Id; | |
5746 | Rec_Discr : Entity_Id; | |
5747 | Temp : Entity_Id; | |
5748 | ||
5749 | begin | |
5750 | Conc_Discr := First_Discriminant (Ctyp); | |
5751 | Rec_Discr := First_Discriminant (Def_Id); | |
5752 | ||
5753 | while Present (Conc_Discr) loop | |
5754 | Temp := Discriminal (Conc_Discr); | |
5755 | Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); | |
5756 | Set_Discriminal (Rec_Discr, Temp); | |
5757 | ||
5758 | Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); | |
5759 | Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); | |
5760 | ||
5761 | Next_Discriminant (Conc_Discr); | |
5762 | Next_Discriminant (Rec_Discr); | |
5763 | end loop; | |
5764 | end; | |
5765 | end if; | |
5766 | ||
5767 | if Has_Controlled_Component (Def_Id) then | |
5768 | if No (Controller_Component (Def_Id)) then | |
5769 | Expand_Record_Controller (Def_Id); | |
5770 | end if; | |
5771 | ||
5772 | Build_Controlling_Procs (Def_Id); | |
5773 | end if; | |
5774 | ||
5775 | Adjust_Discriminants (Def_Id); | |
47cc8d6b ES |
5776 | |
5777 | if VM_Target = No_VM or else not Is_Interface (Def_Id) then | |
5778 | ||
5779 | -- Do not need init for interfaces on e.g. CIL since they're | |
5780 | -- abstract. Helps operation of peverify (the PE Verify tool). | |
5781 | ||
5782 | Build_Record_Init_Proc (Type_Decl, Def_Id); | |
5783 | end if; | |
70482933 | 5784 | |
4ce9a2d8 HK |
5785 | -- For tagged type that are not interfaces, build bodies of primitive |
5786 | -- operations. Note that we do this after building the record | |
5787 | -- initialization procedure, since the primitive operations may need | |
5788 | -- the initialization routine. There is no need to add predefined | |
5789 | -- primitives of interfaces because all their predefined primitives | |
5790 | -- are abstract. | |
70482933 | 5791 | |
4ce9a2d8 HK |
5792 | if Is_Tagged_Type (Def_Id) |
5793 | and then not Is_Interface (Def_Id) | |
5794 | then | |
f2cbd970 JM |
5795 | -- Do not add the body of predefined primitives in case of |
5796 | -- CPP tagged type derivations that have convention CPP. | |
5797 | ||
5798 | if Is_CPP_Class (Root_Type (Def_Id)) | |
5799 | and then Convention (Def_Id) = Convention_CPP | |
5800 | then | |
5801 | null; | |
ea1941af ES |
5802 | |
5803 | -- Do not add the body of the predefined primitives if we are | |
d70d147e GD |
5804 | -- compiling under restriction No_Dispatching_Calls or if we are |
5805 | -- compiling a CPP tagged type. | |
ea1941af | 5806 | |
f2cbd970 | 5807 | elsif not Restriction_Active (No_Dispatching_Calls) then |
ea1941af ES |
5808 | Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); |
5809 | Append_Freeze_Actions (Def_Id, Predef_List); | |
5810 | end if; | |
70482933 | 5811 | |
a05e99a2 JM |
5812 | -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden |
5813 | -- inherited functions, then add their bodies to the freeze actions. | |
5814 | ||
5815 | if Present (Wrapper_Body_List) then | |
5816 | Append_Freeze_Actions (Def_Id, Wrapper_Body_List); | |
5817 | end if; | |
10b93b2e | 5818 | end if; |
70482933 RK |
5819 | end Freeze_Record_Type; |
5820 | ||
07fc65c4 GB |
5821 | ------------------------------ |
5822 | -- Freeze_Stream_Operations -- | |
5823 | ------------------------------ | |
5824 | ||
5825 | procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is | |
fbf5a39b AC |
5826 | Names : constant array (1 .. 4) of TSS_Name_Type := |
5827 | (TSS_Stream_Input, | |
5828 | TSS_Stream_Output, | |
5829 | TSS_Stream_Read, | |
5830 | TSS_Stream_Write); | |
07fc65c4 GB |
5831 | Stream_Op : Entity_Id; |
5832 | ||
5833 | begin | |
5834 | -- Primitive operations of tagged types are frozen when the dispatch | |
5835 | -- table is constructed. | |
5836 | ||
5837 | if not Comes_From_Source (Typ) | |
5838 | or else Is_Tagged_Type (Typ) | |
5839 | then | |
5840 | return; | |
5841 | end if; | |
5842 | ||
5843 | for J in Names'Range loop | |
5844 | Stream_Op := TSS (Typ, Names (J)); | |
5845 | ||
5846 | if Present (Stream_Op) | |
5847 | and then Is_Subprogram (Stream_Op) | |
5848 | and then Nkind (Unit_Declaration_Node (Stream_Op)) = | |
5849 | N_Subprogram_Declaration | |
5850 | and then not Is_Frozen (Stream_Op) | |
5851 | then | |
5852 | Append_Freeze_Actions | |
5853 | (Typ, Freeze_Entity (Stream_Op, Sloc (N))); | |
5854 | end if; | |
5855 | end loop; | |
5856 | end Freeze_Stream_Operations; | |
5857 | ||
70482933 RK |
5858 | ----------------- |
5859 | -- Freeze_Type -- | |
5860 | ----------------- | |
5861 | ||
a9d8907c JM |
5862 | -- Full type declarations are expanded at the point at which the type is |
5863 | -- frozen. The formal N is the Freeze_Node for the type. Any statements or | |
5864 | -- declarations generated by the freezing (e.g. the procedure generated | |
758c442c | 5865 | -- for initialization) are chained in the Actions field list of the freeze |
70482933 RK |
5866 | -- node using Append_Freeze_Actions. |
5867 | ||
a9d8907c | 5868 | function Freeze_Type (N : Node_Id) return Boolean is |
fbf5a39b AC |
5869 | Def_Id : constant Entity_Id := Entity (N); |
5870 | RACW_Seen : Boolean := False; | |
a9d8907c | 5871 | Result : Boolean := False; |
70482933 RK |
5872 | |
5873 | begin | |
5874 | -- Process associated access types needing special processing | |
5875 | ||
5876 | if Present (Access_Types_To_Process (N)) then | |
5877 | declare | |
5878 | E : Elmt_Id := First_Elmt (Access_Types_To_Process (N)); | |
5879 | begin | |
5880 | while Present (E) loop | |
5881 | ||
70482933 | 5882 | if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then |
3476f949 | 5883 | Validate_RACW_Primitives (Node (E)); |
fbf5a39b | 5884 | RACW_Seen := True; |
70482933 RK |
5885 | end if; |
5886 | ||
5887 | E := Next_Elmt (E); | |
5888 | end loop; | |
5889 | end; | |
fbf5a39b AC |
5890 | |
5891 | if RACW_Seen then | |
5892 | ||
a5b62485 | 5893 | -- If there are RACWs designating this type, make stubs now |
fbf5a39b AC |
5894 | |
5895 | Remote_Types_Tagged_Full_View_Encountered (Def_Id); | |
5896 | end if; | |
70482933 RK |
5897 | end if; |
5898 | ||
5899 | -- Freeze processing for record types | |
5900 | ||
5901 | if Is_Record_Type (Def_Id) then | |
5902 | if Ekind (Def_Id) = E_Record_Type then | |
5903 | Freeze_Record_Type (N); | |
5904 | ||
a9d8907c JM |
5905 | -- The subtype may have been declared before the type was frozen. If |
5906 | -- the type has controlled components it is necessary to create the | |
5907 | -- entity for the controller explicitly because it did not exist at | |
5908 | -- the point of the subtype declaration. Only the entity is needed, | |
5909 | -- the back-end will obtain the layout from the type. This is only | |
5910 | -- necessary if this is constrained subtype whose component list is | |
5911 | -- not shared with the base type. | |
70482933 RK |
5912 | |
5913 | elsif Ekind (Def_Id) = E_Record_Subtype | |
5914 | and then Has_Discriminants (Def_Id) | |
5915 | and then Last_Entity (Def_Id) /= Last_Entity (Base_Type (Def_Id)) | |
5916 | and then Present (Controller_Component (Def_Id)) | |
5917 | then | |
5918 | declare | |
fbf5a39b | 5919 | Old_C : constant Entity_Id := Controller_Component (Def_Id); |
70482933 RK |
5920 | New_C : Entity_Id; |
5921 | ||
5922 | begin | |
5923 | if Scope (Old_C) = Base_Type (Def_Id) then | |
5924 | ||
a5b62485 | 5925 | -- The entity is the one in the parent. Create new one |
70482933 RK |
5926 | |
5927 | New_C := New_Copy (Old_C); | |
5928 | Set_Parent (New_C, Parent (Old_C)); | |
47cc8d6b | 5929 | Push_Scope (Def_Id); |
70482933 RK |
5930 | Enter_Name (New_C); |
5931 | End_Scope; | |
5932 | end if; | |
5933 | end; | |
fbf5a39b | 5934 | |
a9d8907c JM |
5935 | if Is_Itype (Def_Id) |
5936 | and then Is_Record_Type (Underlying_Type (Scope (Def_Id))) | |
5937 | then | |
5938 | -- The freeze node is only used to introduce the controller, | |
5939 | -- the back-end has no use for it for a discriminated | |
3476f949 | 5940 | -- component. |
a9d8907c JM |
5941 | |
5942 | Set_Freeze_Node (Def_Id, Empty); | |
5943 | Set_Has_Delayed_Freeze (Def_Id, False); | |
5944 | Result := True; | |
5945 | end if; | |
5946 | ||
5947 | -- Similar process if the controller of the subtype is not present | |
5948 | -- but the parent has it. This can happen with constrained | |
fbf5a39b AC |
5949 | -- record components where the subtype is an itype. |
5950 | ||
5951 | elsif Ekind (Def_Id) = E_Record_Subtype | |
5952 | and then Is_Itype (Def_Id) | |
5953 | and then No (Controller_Component (Def_Id)) | |
5954 | and then Present (Controller_Component (Etype (Def_Id))) | |
5955 | then | |
5956 | declare | |
5957 | Old_C : constant Entity_Id := | |
5958 | Controller_Component (Etype (Def_Id)); | |
5959 | New_C : constant Entity_Id := New_Copy (Old_C); | |
5960 | ||
5961 | begin | |
5962 | Set_Next_Entity (New_C, First_Entity (Def_Id)); | |
5963 | Set_First_Entity (Def_Id, New_C); | |
5964 | ||
5965 | -- The freeze node is only used to introduce the controller, | |
5966 | -- the back-end has no use for it for a discriminated | |
5967 | -- component. | |
5968 | ||
5969 | Set_Freeze_Node (Def_Id, Empty); | |
5970 | Set_Has_Delayed_Freeze (Def_Id, False); | |
a9d8907c | 5971 | Result := True; |
fbf5a39b | 5972 | end; |
70482933 RK |
5973 | end if; |
5974 | ||
5975 | -- Freeze processing for array types | |
5976 | ||
5977 | elsif Is_Array_Type (Def_Id) then | |
5978 | Freeze_Array_Type (N); | |
5979 | ||
5980 | -- Freeze processing for access types | |
5981 | ||
5982 | -- For pool-specific access types, find out the pool object used for | |
5983 | -- this type, needs actual expansion of it in some cases. Here are the | |
5984 | -- different cases : | |
5985 | ||
5986 | -- 1. Rep Clause "for Def_Id'Storage_Size use 0;" | |
5987 | -- ---> don't use any storage pool | |
5988 | ||
5989 | -- 2. Rep Clause : for Def_Id'Storage_Size use Expr. | |
5990 | -- Expand: | |
5991 | -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment); | |
5992 | ||
5993 | -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" | |
5994 | -- ---> Storage Pool is the specified one | |
5995 | ||
5996 | -- See GNAT Pool packages in the Run-Time for more details | |
5997 | ||
5998 | elsif Ekind (Def_Id) = E_Access_Type | |
5999 | or else Ekind (Def_Id) = E_General_Access_Type | |
6000 | then | |
6001 | declare | |
6002 | Loc : constant Source_Ptr := Sloc (N); | |
f2cbd970 | 6003 | Desig_Type : constant Entity_Id := Designated_Type (Def_Id); |
70482933 | 6004 | Pool_Object : Entity_Id; |
70482933 RK |
6005 | |
6006 | Freeze_Action_Typ : Entity_Id; | |
6007 | ||
6008 | begin | |
70482933 RK |
6009 | -- Case 1 |
6010 | ||
6011 | -- Rep Clause "for Def_Id'Storage_Size use 0;" | |
6012 | -- ---> don't use any storage pool | |
6013 | ||
f2cbd970 | 6014 | if No_Pool_Assigned (Def_Id) then |
70482933 RK |
6015 | null; |
6016 | ||
6017 | -- Case 2 | |
6018 | ||
6019 | -- Rep Clause : for Def_Id'Storage_Size use Expr. | |
6020 | -- ---> Expand: | |
6021 | -- Def_Id__Pool : Stack_Bounded_Pool | |
6022 | -- (Expr, DT'Size, DT'Alignment); | |
6023 | ||
6024 | elsif Has_Storage_Size_Clause (Def_Id) then | |
6025 | declare | |
6026 | DT_Size : Node_Id; | |
6027 | DT_Align : Node_Id; | |
6028 | ||
6029 | begin | |
a9d8907c JM |
6030 | -- For unconstrained composite types we give a size of zero |
6031 | -- so that the pool knows that it needs a special algorithm | |
6032 | -- for variable size object allocation. | |
70482933 RK |
6033 | |
6034 | if Is_Composite_Type (Desig_Type) | |
6035 | and then not Is_Constrained (Desig_Type) | |
6036 | then | |
6037 | DT_Size := | |
6038 | Make_Integer_Literal (Loc, 0); | |
6039 | ||
6040 | DT_Align := | |
6041 | Make_Integer_Literal (Loc, Maximum_Alignment); | |
6042 | ||
6043 | else | |
6044 | DT_Size := | |
6045 | Make_Attribute_Reference (Loc, | |
6046 | Prefix => New_Reference_To (Desig_Type, Loc), | |
6047 | Attribute_Name => Name_Max_Size_In_Storage_Elements); | |
6048 | ||
6049 | DT_Align := | |
6050 | Make_Attribute_Reference (Loc, | |
6051 | Prefix => New_Reference_To (Desig_Type, Loc), | |
6052 | Attribute_Name => Name_Alignment); | |
6053 | end if; | |
6054 | ||
6055 | Pool_Object := | |
6056 | Make_Defining_Identifier (Loc, | |
6057 | Chars => New_External_Name (Chars (Def_Id), 'P')); | |
6058 | ||
a9d8907c | 6059 | -- We put the code associated with the pools in the entity |
47cc8d6b | 6060 | -- that has the later freeze node, usually the access type |
a9d8907c JM |
6061 | -- but it can also be the designated_type; because the pool |
6062 | -- code requires both those types to be frozen | |
70482933 RK |
6063 | |
6064 | if Is_Frozen (Desig_Type) | |
a05e99a2 | 6065 | and then (No (Freeze_Node (Desig_Type)) |
70482933 RK |
6066 | or else Analyzed (Freeze_Node (Desig_Type))) |
6067 | then | |
6068 | Freeze_Action_Typ := Def_Id; | |
6069 | ||
6070 | -- A Taft amendment type cannot get the freeze actions | |
6071 | -- since the full view is not there. | |
6072 | ||
6073 | elsif Is_Incomplete_Or_Private_Type (Desig_Type) | |
6074 | and then No (Full_View (Desig_Type)) | |
6075 | then | |
6076 | Freeze_Action_Typ := Def_Id; | |
6077 | ||
6078 | else | |
6079 | Freeze_Action_Typ := Desig_Type; | |
6080 | end if; | |
6081 | ||
6082 | Append_Freeze_Action (Freeze_Action_Typ, | |
6083 | Make_Object_Declaration (Loc, | |
6084 | Defining_Identifier => Pool_Object, | |
6085 | Object_Definition => | |
6086 | Make_Subtype_Indication (Loc, | |
6087 | Subtype_Mark => | |
6088 | New_Reference_To | |
6089 | (RTE (RE_Stack_Bounded_Pool), Loc), | |
6090 | ||
6091 | Constraint => | |
6092 | Make_Index_Or_Discriminant_Constraint (Loc, | |
6093 | Constraints => New_List ( | |
6094 | ||
6095 | -- First discriminant is the Pool Size | |
6096 | ||
6097 | New_Reference_To ( | |
6098 | Storage_Size_Variable (Def_Id), Loc), | |
6099 | ||
6100 | -- Second discriminant is the element size | |
6101 | ||
6102 | DT_Size, | |
6103 | ||
6104 | -- Third discriminant is the alignment | |
6105 | ||
6106 | DT_Align))))); | |
70482933 RK |
6107 | end; |
6108 | ||
6109 | Set_Associated_Storage_Pool (Def_Id, Pool_Object); | |
6110 | ||
6111 | -- Case 3 | |
6112 | ||
6113 | -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" | |
6114 | -- ---> Storage Pool is the specified one | |
6115 | ||
6116 | elsif Present (Associated_Storage_Pool (Def_Id)) then | |
6117 | ||
6118 | -- Nothing to do the associated storage pool has been attached | |
6119 | -- when analyzing the rep. clause | |
6120 | ||
6121 | null; | |
70482933 RK |
6122 | end if; |
6123 | ||
a9d8907c JM |
6124 | -- For access-to-controlled types (including class-wide types and |
6125 | -- Taft-amendment types which potentially have controlled | |
6126 | -- components), expand the list controller object that will store | |
6127 | -- the dynamically allocated objects. Do not do this | |
70482933 RK |
6128 | -- transformation for expander-generated access types, but do it |
6129 | -- for types that are the full view of types derived from other | |
6130 | -- private types. Also suppress the list controller in the case | |
6131 | -- of a designated type with convention Java, since this is used | |
a9d8907c JM |
6132 | -- when binding to Java API specs, where there's no equivalent of |
6133 | -- a finalization list and we don't want to pull in the | |
70482933 RK |
6134 | -- finalization support if not needed. |
6135 | ||
6136 | if not Comes_From_Source (Def_Id) | |
6137 | and then not Has_Private_Declaration (Def_Id) | |
6138 | then | |
6139 | null; | |
6140 | ||
6141 | elsif (Controlled_Type (Desig_Type) | |
47cc8d6b ES |
6142 | and then Convention (Desig_Type) /= Convention_Java |
6143 | and then Convention (Desig_Type) /= Convention_CIL) | |
fbf5a39b AC |
6144 | or else |
6145 | (Is_Incomplete_Or_Private_Type (Desig_Type) | |
6146 | and then No (Full_View (Desig_Type)) | |
70482933 | 6147 | |
6e937c1c AC |
6148 | -- An exception is made for types defined in the run-time |
6149 | -- because Ada.Tags.Tag itself is such a type and cannot | |
6150 | -- afford this unnecessary overhead that would generates a | |
6151 | -- loop in the expansion scheme... | |
70482933 | 6152 | |
6e937c1c | 6153 | and then not In_Runtime (Def_Id) |
fbf5a39b | 6154 | |
6e937c1c AC |
6155 | -- Another exception is if Restrictions (No_Finalization) |
6156 | -- is active, since then we know nothing is controlled. | |
fbf5a39b | 6157 | |
6e937c1c | 6158 | and then not Restriction_Active (No_Finalization)) |
70482933 RK |
6159 | |
6160 | -- If the designated type is not frozen yet, its controlled | |
6161 | -- status must be retrieved explicitly. | |
6162 | ||
6163 | or else (Is_Array_Type (Desig_Type) | |
6164 | and then not Is_Frozen (Desig_Type) | |
6165 | and then Controlled_Type (Component_Type (Desig_Type))) | |
47cc8d6b ES |
6166 | |
6167 | -- The designated type has controlled anonymous access | |
6168 | -- discriminants. | |
6169 | ||
6170 | or else Has_Controlled_Coextensions (Desig_Type) | |
70482933 | 6171 | then |
04df6250 | 6172 | Set_Associated_Final_Chain (Def_Id, Add_Final_Chain (Def_Id)); |
70482933 RK |
6173 | end if; |
6174 | end; | |
6175 | ||
6176 | -- Freeze processing for enumeration types | |
6177 | ||
6178 | elsif Ekind (Def_Id) = E_Enumeration_Type then | |
6179 | ||
6180 | -- We only have something to do if we have a non-standard | |
6181 | -- representation (i.e. at least one literal whose pos value | |
6182 | -- is not the same as its representation) | |
6183 | ||
6184 | if Has_Non_Standard_Rep (Def_Id) then | |
6185 | Freeze_Enumeration_Type (N); | |
6186 | end if; | |
6187 | ||
fbf5a39b | 6188 | -- Private types that are completed by a derivation from a private |
70482933 RK |
6189 | -- type have an internally generated full view, that needs to be |
6190 | -- frozen. This must be done explicitly because the two views share | |
6191 | -- the freeze node, and the underlying full view is not visible when | |
6192 | -- the freeze node is analyzed. | |
6193 | ||
6194 | elsif Is_Private_Type (Def_Id) | |
6195 | and then Is_Derived_Type (Def_Id) | |
6196 | and then Present (Full_View (Def_Id)) | |
6197 | and then Is_Itype (Full_View (Def_Id)) | |
6198 | and then Has_Private_Declaration (Full_View (Def_Id)) | |
6199 | and then Freeze_Node (Full_View (Def_Id)) = N | |
6200 | then | |
6201 | Set_Entity (N, Full_View (Def_Id)); | |
a9d8907c | 6202 | Result := Freeze_Type (N); |
70482933 RK |
6203 | Set_Entity (N, Def_Id); |
6204 | ||
a9d8907c JM |
6205 | -- All other types require no expander action. There are such cases |
6206 | -- (e.g. task types and protected types). In such cases, the freeze | |
6207 | -- nodes are there for use by Gigi. | |
70482933 RK |
6208 | |
6209 | end if; | |
07fc65c4 GB |
6210 | |
6211 | Freeze_Stream_Operations (N, Def_Id); | |
a9d8907c | 6212 | return Result; |
fbf5a39b AC |
6213 | |
6214 | exception | |
6215 | when RE_Not_Available => | |
a9d8907c | 6216 | return False; |
70482933 RK |
6217 | end Freeze_Type; |
6218 | ||
6219 | ------------------------- | |
6220 | -- Get_Simple_Init_Val -- | |
6221 | ------------------------- | |
6222 | ||
6223 | function Get_Simple_Init_Val | |
82c80734 | 6224 | (T : Entity_Id; |
f2cbd970 | 6225 | N : Node_Id; |
82c80734 | 6226 | Size : Uint := No_Uint) return Node_Id |
70482933 | 6227 | is |
f2cbd970 | 6228 | Loc : constant Source_Ptr := Sloc (N); |
70482933 | 6229 | Val : Node_Id; |
70482933 RK |
6230 | Result : Node_Id; |
6231 | Val_RE : RE_Id; | |
6232 | ||
82c80734 RD |
6233 | Size_To_Use : Uint; |
6234 | -- This is the size to be used for computation of the appropriate | |
6235 | -- initial value for the Normalize_Scalars and Initialize_Scalars case. | |
6236 | ||
f2cbd970 JM |
6237 | IV_Attribute : constant Boolean := |
6238 | Nkind (N) = N_Attribute_Reference | |
6239 | and then Attribute_Name (N) = Name_Invalid_Value; | |
6240 | ||
82c80734 RD |
6241 | Lo_Bound : Uint; |
6242 | Hi_Bound : Uint; | |
6243 | -- These are the values computed by the procedure Check_Subtype_Bounds | |
6244 | ||
6245 | procedure Check_Subtype_Bounds; | |
a9d8907c JM |
6246 | -- This procedure examines the subtype T, and its ancestor subtypes and |
6247 | -- derived types to determine the best known information about the | |
6248 | -- bounds of the subtype. After the call Lo_Bound is set either to | |
6249 | -- No_Uint if no information can be determined, or to a value which | |
82c80734 RD |
6250 | -- represents a known low bound, i.e. a valid value of the subtype can |
6251 | -- not be less than this value. Hi_Bound is similarly set to a known | |
6252 | -- high bound (valid value cannot be greater than this). | |
6253 | ||
6254 | -------------------------- | |
6255 | -- Check_Subtype_Bounds -- | |
6256 | -------------------------- | |
6257 | ||
6258 | procedure Check_Subtype_Bounds is | |
6259 | ST1 : Entity_Id; | |
6260 | ST2 : Entity_Id; | |
6261 | Lo : Node_Id; | |
6262 | Hi : Node_Id; | |
6263 | Loval : Uint; | |
6264 | Hival : Uint; | |
6265 | ||
6266 | begin | |
6267 | Lo_Bound := No_Uint; | |
6268 | Hi_Bound := No_Uint; | |
6269 | ||
6270 | -- Loop to climb ancestor subtypes and derived types | |
6271 | ||
6272 | ST1 := T; | |
6273 | loop | |
6274 | if not Is_Discrete_Type (ST1) then | |
6275 | return; | |
6276 | end if; | |
6277 | ||
6278 | Lo := Type_Low_Bound (ST1); | |
6279 | Hi := Type_High_Bound (ST1); | |
6280 | ||
6281 | if Compile_Time_Known_Value (Lo) then | |
6282 | Loval := Expr_Value (Lo); | |
6283 | ||
6284 | if Lo_Bound = No_Uint or else Lo_Bound < Loval then | |
6285 | Lo_Bound := Loval; | |
6286 | end if; | |
6287 | end if; | |
6288 | ||
6289 | if Compile_Time_Known_Value (Hi) then | |
6290 | Hival := Expr_Value (Hi); | |
6291 | ||
6292 | if Hi_Bound = No_Uint or else Hi_Bound > Hival then | |
6293 | Hi_Bound := Hival; | |
6294 | end if; | |
6295 | end if; | |
6296 | ||
6297 | ST2 := Ancestor_Subtype (ST1); | |
6298 | ||
6299 | if No (ST2) then | |
6300 | ST2 := Etype (ST1); | |
6301 | end if; | |
6302 | ||
6303 | exit when ST1 = ST2; | |
6304 | ST1 := ST2; | |
6305 | end loop; | |
6306 | end Check_Subtype_Bounds; | |
6307 | ||
6308 | -- Start of processing for Get_Simple_Init_Val | |
6309 | ||
70482933 | 6310 | begin |
07fc65c4 GB |
6311 | -- For a private type, we should always have an underlying type |
6312 | -- (because this was already checked in Needs_Simple_Initialization). | |
a9d8907c JM |
6313 | -- What we do is to get the value for the underlying type and then do |
6314 | -- an Unchecked_Convert to the private type. | |
07fc65c4 GB |
6315 | |
6316 | if Is_Private_Type (T) then | |
f2cbd970 | 6317 | Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size); |
07fc65c4 | 6318 | |
a9d8907c JM |
6319 | -- A special case, if the underlying value is null, then qualify it |
6320 | -- with the underlying type, so that the null is properly typed | |
6321 | -- Similarly, if it is an aggregate it must be qualified, because an | |
6322 | -- unchecked conversion does not provide a context for it. | |
07fc65c4 | 6323 | |
4ce9a2d8 | 6324 | if Nkind_In (Val, N_Null, N_Aggregate) then |
07fc65c4 GB |
6325 | Val := |
6326 | Make_Qualified_Expression (Loc, | |
6327 | Subtype_Mark => | |
6328 | New_Occurrence_Of (Underlying_Type (T), Loc), | |
6329 | Expression => Val); | |
6330 | end if; | |
6331 | ||
fbf5a39b AC |
6332 | Result := Unchecked_Convert_To (T, Val); |
6333 | ||
6334 | -- Don't truncate result (important for Initialize/Normalize_Scalars) | |
6335 | ||
6336 | if Nkind (Result) = N_Unchecked_Type_Conversion | |
6337 | and then Is_Scalar_Type (Underlying_Type (T)) | |
6338 | then | |
6339 | Set_No_Truncation (Result); | |
6340 | end if; | |
6341 | ||
6342 | return Result; | |
07fc65c4 | 6343 | |
f2cbd970 JM |
6344 | -- For scalars, we must have normalize/initialize scalars case, or |
6345 | -- if the node N is an 'Invalid_Value attribute node. | |
70482933 | 6346 | |
07fc65c4 | 6347 | elsif Is_Scalar_Type (T) then |
f2cbd970 | 6348 | pragma Assert (Init_Or_Norm_Scalars or IV_Attribute); |
70482933 | 6349 | |
a9d8907c JM |
6350 | -- Compute size of object. If it is given by the caller, we can use |
6351 | -- it directly, otherwise we use Esize (T) as an estimate. As far as | |
6352 | -- we know this covers all cases correctly. | |
82c80734 RD |
6353 | |
6354 | if Size = No_Uint or else Size <= Uint_0 then | |
6355 | Size_To_Use := UI_Max (Uint_1, Esize (T)); | |
6356 | else | |
6357 | Size_To_Use := Size; | |
6358 | end if; | |
6359 | ||
6360 | -- Maximum size to use is 64 bits, since we will create values | |
6361 | -- of type Unsigned_64 and the range must fit this type. | |
6362 | ||
6363 | if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then | |
6364 | Size_To_Use := Uint_64; | |
6365 | end if; | |
6366 | ||
6367 | -- Check known bounds of subtype | |
6368 | ||
6369 | Check_Subtype_Bounds; | |
6370 | ||
70482933 RK |
6371 | -- Processing for Normalize_Scalars case |
6372 | ||
f2cbd970 | 6373 | if Normalize_Scalars and then not IV_Attribute then |
70482933 | 6374 | |
82c80734 RD |
6375 | -- If zero is invalid, it is a convenient value to use that is |
6376 | -- for sure an appropriate invalid value in all situations. | |
6377 | ||
6378 | if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then | |
6379 | Val := Make_Integer_Literal (Loc, 0); | |
6380 | ||
6381 | -- Cases where all one bits is the appropriate invalid value | |
6382 | ||
6383 | -- For modular types, all 1 bits is either invalid or valid. If | |
6384 | -- it is valid, then there is nothing that can be done since there | |
6385 | -- are no invalid values (we ruled out zero already). | |
6386 | ||
6387 | -- For signed integer types that have no negative values, either | |
6388 | -- there is room for negative values, or there is not. If there | |
47cc8d6b | 6389 | -- is, then all 1 bits may be interpreted as minus one, which is |
82c80734 RD |
6390 | -- certainly invalid. Alternatively it is treated as the largest |
6391 | -- positive value, in which case the observation for modular types | |
6392 | -- still applies. | |
6393 | ||
6394 | -- For float types, all 1-bits is a NaN (not a number), which is | |
6395 | -- certainly an appropriately invalid value. | |
70482933 | 6396 | |
82c80734 RD |
6397 | elsif Is_Unsigned_Type (T) |
6398 | or else Is_Floating_Point_Type (T) | |
6399 | or else Is_Enumeration_Type (T) | |
6400 | then | |
6401 | Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1); | |
6402 | ||
6403 | -- Resolve as Unsigned_64, because the largest number we | |
6404 | -- can generate is out of range of universal integer. | |
6405 | ||
6406 | Analyze_And_Resolve (Val, RTE (RE_Unsigned_64)); | |
70482933 | 6407 | |
82c80734 | 6408 | -- Case of signed types |
70482933 RK |
6409 | |
6410 | else | |
82c80734 RD |
6411 | declare |
6412 | Signed_Size : constant Uint := | |
6413 | UI_Min (Uint_63, Size_To_Use - 1); | |
6414 | ||
6415 | begin | |
6416 | -- Normally we like to use the most negative number. The | |
a9d8907c JM |
6417 | -- one exception is when this number is in the known |
6418 | -- subtype range and the largest positive number is not in | |
6419 | -- the known subtype range. | |
82c80734 RD |
6420 | |
6421 | -- For this exceptional case, use largest positive value | |
70482933 | 6422 | |
82c80734 RD |
6423 | if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint |
6424 | and then Lo_Bound <= (-(2 ** Signed_Size)) | |
6425 | and then Hi_Bound < 2 ** Signed_Size | |
6426 | then | |
6427 | Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1); | |
6428 | ||
6429 | -- Normal case of largest negative value | |
6430 | ||
6431 | else | |
6432 | Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size)); | |
6433 | end if; | |
6434 | end; | |
70482933 RK |
6435 | end if; |
6436 | ||
f2cbd970 | 6437 | -- Here for Initialize_Scalars case (or Invalid_Value attribute used) |
70482933 RK |
6438 | |
6439 | else | |
82c80734 RD |
6440 | -- For float types, use float values from System.Scalar_Values |
6441 | ||
70482933 RK |
6442 | if Is_Floating_Point_Type (T) then |
6443 | if Root_Type (T) = Standard_Short_Float then | |
6444 | Val_RE := RE_IS_Isf; | |
6445 | elsif Root_Type (T) = Standard_Float then | |
6446 | Val_RE := RE_IS_Ifl; | |
fbf5a39b | 6447 | elsif Root_Type (T) = Standard_Long_Float then |
70482933 | 6448 | Val_RE := RE_IS_Ilf; |
70482933 RK |
6449 | else pragma Assert (Root_Type (T) = Standard_Long_Long_Float); |
6450 | Val_RE := RE_IS_Ill; | |
6451 | end if; | |
6452 | ||
82c80734 RD |
6453 | -- If zero is invalid, use zero values from System.Scalar_Values |
6454 | ||
6455 | elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then | |
6456 | if Size_To_Use <= 8 then | |
6457 | Val_RE := RE_IS_Iz1; | |
6458 | elsif Size_To_Use <= 16 then | |
6459 | Val_RE := RE_IS_Iz2; | |
6460 | elsif Size_To_Use <= 32 then | |
6461 | Val_RE := RE_IS_Iz4; | |
6462 | else | |
6463 | Val_RE := RE_IS_Iz8; | |
6464 | end if; | |
6465 | ||
6466 | -- For unsigned, use unsigned values from System.Scalar_Values | |
6467 | ||
6468 | elsif Is_Unsigned_Type (T) then | |
6469 | if Size_To_Use <= 8 then | |
70482933 | 6470 | Val_RE := RE_IS_Iu1; |
82c80734 | 6471 | elsif Size_To_Use <= 16 then |
70482933 | 6472 | Val_RE := RE_IS_Iu2; |
82c80734 | 6473 | elsif Size_To_Use <= 32 then |
70482933 | 6474 | Val_RE := RE_IS_Iu4; |
82c80734 | 6475 | else |
70482933 RK |
6476 | Val_RE := RE_IS_Iu8; |
6477 | end if; | |
6478 | ||
82c80734 RD |
6479 | -- For signed, use signed values from System.Scalar_Values |
6480 | ||
6481 | else | |
6482 | if Size_To_Use <= 8 then | |
70482933 | 6483 | Val_RE := RE_IS_Is1; |
82c80734 | 6484 | elsif Size_To_Use <= 16 then |
70482933 | 6485 | Val_RE := RE_IS_Is2; |
82c80734 | 6486 | elsif Size_To_Use <= 32 then |
70482933 | 6487 | Val_RE := RE_IS_Is4; |
82c80734 | 6488 | else |
70482933 RK |
6489 | Val_RE := RE_IS_Is8; |
6490 | end if; | |
6491 | end if; | |
6492 | ||
6493 | Val := New_Occurrence_Of (RTE (Val_RE), Loc); | |
6494 | end if; | |
6495 | ||
82c80734 RD |
6496 | -- The final expression is obtained by doing an unchecked conversion |
6497 | -- of this result to the base type of the required subtype. We use | |
6498 | -- the base type to avoid the unchecked conversion from chopping | |
6499 | -- bits, and then we set Kill_Range_Check to preserve the "bad" | |
6500 | -- value. | |
70482933 RK |
6501 | |
6502 | Result := Unchecked_Convert_To (Base_Type (T), Val); | |
6503 | ||
fbf5a39b AC |
6504 | -- Ensure result is not truncated, since we want the "bad" bits |
6505 | -- and also kill range check on result. | |
6506 | ||
70482933 | 6507 | if Nkind (Result) = N_Unchecked_Type_Conversion then |
fbf5a39b | 6508 | Set_No_Truncation (Result); |
70482933 RK |
6509 | Set_Kill_Range_Check (Result, True); |
6510 | end if; | |
6511 | ||
6512 | return Result; | |
6513 | ||
82c80734 | 6514 | -- String or Wide_[Wide]_String (must have Initialize_Scalars set) |
70482933 RK |
6515 | |
6516 | elsif Root_Type (T) = Standard_String | |
6517 | or else | |
6518 | Root_Type (T) = Standard_Wide_String | |
82c80734 RD |
6519 | or else |
6520 | Root_Type (T) = Standard_Wide_Wide_String | |
70482933 RK |
6521 | then |
6522 | pragma Assert (Init_Or_Norm_Scalars); | |
6523 | ||
70482933 | 6524 | return |
c84700e7 ES |
6525 | Make_Aggregate (Loc, |
6526 | Component_Associations => New_List ( | |
6527 | Make_Component_Association (Loc, | |
6528 | Choices => New_List ( | |
6529 | Make_Others_Choice (Loc)), | |
6530 | Expression => | |
82c80734 | 6531 | Get_Simple_Init_Val |
f2cbd970 | 6532 | (Component_Type (T), N, Esize (Root_Type (T)))))); |
70482933 RK |
6533 | |
6534 | -- Access type is initialized to null | |
6535 | ||
6536 | elsif Is_Access_Type (T) then | |
6537 | return | |
6538 | Make_Null (Loc); | |
6539 | ||
07fc65c4 GB |
6540 | -- No other possibilities should arise, since we should only be |
6541 | -- calling Get_Simple_Init_Val if Needs_Simple_Initialization | |
6542 | -- returned True, indicating one of the above cases held. | |
70482933 RK |
6543 | |
6544 | else | |
07fc65c4 | 6545 | raise Program_Error; |
70482933 | 6546 | end if; |
fbf5a39b AC |
6547 | |
6548 | exception | |
6549 | when RE_Not_Available => | |
6550 | return Empty; | |
70482933 RK |
6551 | end Get_Simple_Init_Val; |
6552 | ||
6553 | ------------------------------ | |
6554 | -- Has_New_Non_Standard_Rep -- | |
6555 | ------------------------------ | |
6556 | ||
6557 | function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is | |
6558 | begin | |
6559 | if not Is_Derived_Type (T) then | |
6560 | return Has_Non_Standard_Rep (T) | |
6561 | or else Has_Non_Standard_Rep (Root_Type (T)); | |
6562 | ||
6563 | -- If Has_Non_Standard_Rep is not set on the derived type, the | |
6564 | -- representation is fully inherited. | |
6565 | ||
6566 | elsif not Has_Non_Standard_Rep (T) then | |
6567 | return False; | |
6568 | ||
6569 | else | |
6570 | return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T)); | |
6571 | ||
6572 | -- May need a more precise check here: the First_Rep_Item may | |
6573 | -- be a stream attribute, which does not affect the representation | |
6574 | -- of the type ??? | |
6575 | end if; | |
6576 | end Has_New_Non_Standard_Rep; | |
6577 | ||
6578 | ---------------- | |
6579 | -- In_Runtime -- | |
6580 | ---------------- | |
6581 | ||
6582 | function In_Runtime (E : Entity_Id) return Boolean is | |
47cc8d6b | 6583 | S1 : Entity_Id; |
70482933 RK |
6584 | |
6585 | begin | |
47cc8d6b | 6586 | S1 := Scope (E); |
70482933 RK |
6587 | while Scope (S1) /= Standard_Standard loop |
6588 | S1 := Scope (S1); | |
6589 | end loop; | |
6590 | ||
6591 | return Chars (S1) = Name_System or else Chars (S1) = Name_Ada; | |
6592 | end In_Runtime; | |
6593 | ||
47cc8d6b ES |
6594 | ---------------------------- |
6595 | -- Initialization_Warning -- | |
6596 | ---------------------------- | |
6597 | ||
6598 | procedure Initialization_Warning (E : Entity_Id) is | |
6599 | Warning_Needed : Boolean; | |
6600 | ||
6601 | begin | |
6602 | Warning_Needed := False; | |
6603 | ||
6604 | if Ekind (Current_Scope) = E_Package | |
6605 | and then Static_Elaboration_Desired (Current_Scope) | |
6606 | then | |
6607 | if Is_Type (E) then | |
6608 | if Is_Record_Type (E) then | |
6609 | if Has_Discriminants (E) | |
6610 | or else Is_Limited_Type (E) | |
6611 | or else Has_Non_Standard_Rep (E) | |
6612 | then | |
6613 | Warning_Needed := True; | |
6614 | ||
6615 | else | |
8fc789c8 | 6616 | -- Verify that at least one component has an initialization |
47cc8d6b ES |
6617 | -- expression. No need for a warning on a type if all its |
6618 | -- components have no initialization. | |
6619 | ||
6620 | declare | |
6621 | Comp : Entity_Id; | |
6622 | ||
6623 | begin | |
6624 | Comp := First_Component (E); | |
6625 | while Present (Comp) loop | |
6626 | if Ekind (Comp) = E_Discriminant | |
6627 | or else | |
6628 | (Nkind (Parent (Comp)) = N_Component_Declaration | |
6629 | and then Present (Expression (Parent (Comp)))) | |
6630 | then | |
6631 | Warning_Needed := True; | |
6632 | exit; | |
6633 | end if; | |
6634 | ||
6635 | Next_Component (Comp); | |
6636 | end loop; | |
6637 | end; | |
6638 | end if; | |
6639 | ||
6640 | if Warning_Needed then | |
6641 | Error_Msg_N | |
6642 | ("Objects of the type cannot be initialized " & | |
6643 | "statically by default?", | |
6644 | Parent (E)); | |
6645 | end if; | |
6646 | end if; | |
6647 | ||
6648 | else | |
6649 | Error_Msg_N ("Object cannot be initialized statically?", E); | |
6650 | end if; | |
6651 | end if; | |
6652 | end Initialization_Warning; | |
6653 | ||
70482933 RK |
6654 | ------------------ |
6655 | -- Init_Formals -- | |
6656 | ------------------ | |
6657 | ||
6658 | function Init_Formals (Typ : Entity_Id) return List_Id is | |
6659 | Loc : constant Source_Ptr := Sloc (Typ); | |
6660 | Formals : List_Id; | |
6661 | ||
6662 | begin | |
6663 | -- First parameter is always _Init : in out typ. Note that we need | |
6664 | -- this to be in/out because in the case of the task record value, | |
6665 | -- there are default record fields (_Priority, _Size, -Task_Info) | |
6666 | -- that may be referenced in the generated initialization routine. | |
6667 | ||
6668 | Formals := New_List ( | |
6669 | Make_Parameter_Specification (Loc, | |
6670 | Defining_Identifier => | |
6671 | Make_Defining_Identifier (Loc, Name_uInit), | |
6672 | In_Present => True, | |
6673 | Out_Present => True, | |
6674 | Parameter_Type => New_Reference_To (Typ, Loc))); | |
6675 | ||
6676 | -- For task record value, or type that contains tasks, add two more | |
6677 | -- formals, _Master : Master_Id and _Chain : in out Activation_Chain | |
6678 | -- We also add these parameters for the task record type case. | |
6679 | ||
6680 | if Has_Task (Typ) | |
6681 | or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ)) | |
6682 | then | |
6683 | Append_To (Formals, | |
6684 | Make_Parameter_Specification (Loc, | |
6685 | Defining_Identifier => | |
6686 | Make_Defining_Identifier (Loc, Name_uMaster), | |
6687 | Parameter_Type => New_Reference_To (RTE (RE_Master_Id), Loc))); | |
6688 | ||
6689 | Append_To (Formals, | |
6690 | Make_Parameter_Specification (Loc, | |
6691 | Defining_Identifier => | |
6692 | Make_Defining_Identifier (Loc, Name_uChain), | |
6693 | In_Present => True, | |
6694 | Out_Present => True, | |
6695 | Parameter_Type => | |
6696 | New_Reference_To (RTE (RE_Activation_Chain), Loc))); | |
6697 | ||
6698 | Append_To (Formals, | |
6699 | Make_Parameter_Specification (Loc, | |
6700 | Defining_Identifier => | |
fbf5a39b | 6701 | Make_Defining_Identifier (Loc, Name_uTask_Name), |
70482933 RK |
6702 | In_Present => True, |
6703 | Parameter_Type => | |
fbf5a39b | 6704 | New_Reference_To (Standard_String, Loc))); |
70482933 RK |
6705 | end if; |
6706 | ||
6707 | return Formals; | |
fbf5a39b AC |
6708 | |
6709 | exception | |
6710 | when RE_Not_Available => | |
6711 | return Empty_List; | |
70482933 RK |
6712 | end Init_Formals; |
6713 | ||
3476f949 JM |
6714 | ------------------------- |
6715 | -- Init_Secondary_Tags -- | |
6716 | ------------------------- | |
6717 | ||
6718 | procedure Init_Secondary_Tags | |
04df6250 TQ |
6719 | (Typ : Entity_Id; |
6720 | Target : Node_Id; | |
6721 | Stmts_List : List_Id; | |
6722 | Fixed_Comps : Boolean := True; | |
6723 | Variable_Comps : Boolean := True) | |
3476f949 | 6724 | is |
04df6250 | 6725 | Loc : constant Source_Ptr := Sloc (Target); |
ea1941af | 6726 | |
04df6250 TQ |
6727 | procedure Inherit_CPP_Tag |
6728 | (Typ : Entity_Id; | |
6729 | Iface : Entity_Id; | |
6730 | Tag_Comp : Entity_Id; | |
6731 | Iface_Tag : Node_Id); | |
6732 | -- Inherit the C++ tag of the secondary dispatch table of Typ associated | |
6733 | -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. | |
ea1941af ES |
6734 | |
6735 | procedure Initialize_Tag | |
6736 | (Typ : Entity_Id; | |
6737 | Iface : Entity_Id; | |
04df6250 | 6738 | Tag_Comp : Entity_Id; |
ea1941af ES |
6739 | Iface_Tag : Node_Id); |
6740 | -- Initialize the tag of the secondary dispatch table of Typ associated | |
6741 | -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. | |
04df6250 TQ |
6742 | -- Compiling under the CPP full ABI compatibility mode, if the ancestor |
6743 | -- of Typ CPP tagged type we generate code to inherit the contents of | |
6744 | -- the dispatch table directly from the ancestor. | |
3476f949 | 6745 | |
04df6250 TQ |
6746 | --------------------- |
6747 | -- Inherit_CPP_Tag -- | |
6748 | --------------------- | |
6749 | ||
6750 | procedure Inherit_CPP_Tag | |
6751 | (Typ : Entity_Id; | |
6752 | Iface : Entity_Id; | |
6753 | Tag_Comp : Entity_Id; | |
6754 | Iface_Tag : Node_Id) | |
6755 | is | |
6756 | begin | |
6757 | pragma Assert (Is_CPP_Class (Etype (Typ))); | |
6758 | ||
6759 | Append_To (Stmts_List, | |
6760 | Build_Inherit_Prims (Loc, | |
6761 | Typ => Iface, | |
6762 | Old_Tag_Node => | |
6763 | Make_Selected_Component (Loc, | |
6764 | Prefix => New_Copy_Tree (Target), | |
6765 | Selector_Name => New_Reference_To (Tag_Comp, Loc)), | |
6766 | New_Tag_Node => | |
6767 | New_Reference_To (Iface_Tag, Loc), | |
6768 | Num_Prims => | |
6769 | UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface))))); | |
6770 | end Inherit_CPP_Tag; | |
3476f949 | 6771 | |
ea1941af ES |
6772 | -------------------- |
6773 | -- Initialize_Tag -- | |
6774 | -------------------- | |
6775 | ||
6776 | procedure Initialize_Tag | |
6777 | (Typ : Entity_Id; | |
6778 | Iface : Entity_Id; | |
04df6250 | 6779 | Tag_Comp : Entity_Id; |
ea1941af ES |
6780 | Iface_Tag : Node_Id) |
6781 | is | |
04df6250 TQ |
6782 | Comp_Typ : Entity_Id; |
6783 | Offset_To_Top_Comp : Entity_Id := Empty; | |
ea1941af ES |
6784 | |
6785 | begin | |
04df6250 TQ |
6786 | -- Initialize the pointer to the secondary DT associated with the |
6787 | -- interface. | |
ea1941af | 6788 | |
ce2b6ba5 | 6789 | if not Is_Ancestor (Iface, Typ) then |
ea1941af | 6790 | Append_To (Stmts_List, |
04df6250 TQ |
6791 | Make_Assignment_Statement (Loc, |
6792 | Name => | |
ea1941af | 6793 | Make_Selected_Component (Loc, |
04df6250 | 6794 | Prefix => New_Copy_Tree (Target), |
ea1941af | 6795 | Selector_Name => New_Reference_To (Tag_Comp, Loc)), |
04df6250 TQ |
6796 | Expression => |
6797 | New_Reference_To (Iface_Tag, Loc))); | |
ea1941af ES |
6798 | end if; |
6799 | ||
04df6250 | 6800 | Comp_Typ := Scope (Tag_Comp); |
ea1941af | 6801 | |
04df6250 TQ |
6802 | -- Initialize the entries of the table of interfaces. We generate a |
6803 | -- different call when the parent of the type has variable size | |
6804 | -- components. | |
ea1941af | 6805 | |
04df6250 TQ |
6806 | if Comp_Typ /= Etype (Comp_Typ) |
6807 | and then Is_Variable_Size_Record (Etype (Comp_Typ)) | |
6808 | and then Chars (Tag_Comp) /= Name_uTag | |
6809 | then | |
6810 | pragma Assert | |
6811 | (Present (DT_Offset_To_Top_Func (Tag_Comp))); | |
ea1941af | 6812 | |
f2cbd970 JM |
6813 | -- Issue error if Set_Dynamic_Offset_To_Top is not available in a |
6814 | -- configurable run-time environment. | |
6815 | ||
6816 | if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then | |
6817 | Error_Msg_CRT | |
6818 | ("variable size record with interface types", Typ); | |
6819 | return; | |
6820 | end if; | |
6821 | ||
04df6250 | 6822 | -- Generate: |
f2cbd970 | 6823 | -- Set_Dynamic_Offset_To_Top |
04df6250 TQ |
6824 | -- (This => Init, |
6825 | -- Interface_T => Iface'Tag, | |
04df6250 TQ |
6826 | -- Offset_Value => n, |
6827 | -- Offset_Func => Fn'Address) | |
ea1941af | 6828 | |
04df6250 TQ |
6829 | Append_To (Stmts_List, |
6830 | Make_Procedure_Call_Statement (Loc, | |
f2cbd970 JM |
6831 | Name => New_Reference_To |
6832 | (RTE (RE_Set_Dynamic_Offset_To_Top), Loc), | |
04df6250 TQ |
6833 | Parameter_Associations => New_List ( |
6834 | Make_Attribute_Reference (Loc, | |
6835 | Prefix => New_Copy_Tree (Target), | |
6836 | Attribute_Name => Name_Address), | |
ea1941af | 6837 | |
04df6250 TQ |
6838 | Unchecked_Convert_To (RTE (RE_Tag), |
6839 | New_Reference_To | |
6840 | (Node (First_Elmt (Access_Disp_Table (Iface))), | |
6841 | Loc)), | |
ea1941af | 6842 | |
04df6250 TQ |
6843 | Unchecked_Convert_To |
6844 | (RTE (RE_Storage_Offset), | |
ea1941af ES |
6845 | Make_Attribute_Reference (Loc, |
6846 | Prefix => | |
6847 | Make_Selected_Component (Loc, | |
6848 | Prefix => New_Copy_Tree (Target), | |
6849 | Selector_Name => | |
04df6250 TQ |
6850 | New_Reference_To (Tag_Comp, Loc)), |
6851 | Attribute_Name => Name_Position)), | |
ea1941af | 6852 | |
04df6250 TQ |
6853 | Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr), |
6854 | Make_Attribute_Reference (Loc, | |
6855 | Prefix => New_Reference_To | |
6856 | (DT_Offset_To_Top_Func (Tag_Comp), Loc), | |
6857 | Attribute_Name => Name_Address))))); | |
3476f949 | 6858 | |
04df6250 TQ |
6859 | -- In this case the next component stores the value of the |
6860 | -- offset to the top. | |
ea1941af | 6861 | |
04df6250 TQ |
6862 | Offset_To_Top_Comp := Next_Entity (Tag_Comp); |
6863 | pragma Assert (Present (Offset_To_Top_Comp)); | |
ea1941af | 6864 | |
04df6250 TQ |
6865 | Append_To (Stmts_List, |
6866 | Make_Assignment_Statement (Loc, | |
6867 | Name => | |
6868 | Make_Selected_Component (Loc, | |
6869 | Prefix => New_Copy_Tree (Target), | |
6870 | Selector_Name => New_Reference_To | |
6871 | (Offset_To_Top_Comp, Loc)), | |
6872 | Expression => | |
6873 | Make_Attribute_Reference (Loc, | |
6874 | Prefix => | |
6875 | Make_Selected_Component (Loc, | |
6876 | Prefix => New_Copy_Tree (Target), | |
6877 | Selector_Name => | |
6878 | New_Reference_To (Tag_Comp, Loc)), | |
6879 | Attribute_Name => Name_Position))); | |
3476f949 | 6880 | |
04df6250 | 6881 | -- Normal case: No discriminants in the parent type |
3476f949 | 6882 | |
04df6250 | 6883 | else |
f2cbd970 | 6884 | -- Don't need to set any value if this interface shares |
d70d147e | 6885 | -- the primary dispatch table. |
f2cbd970 | 6886 | |
ce2b6ba5 | 6887 | if not Is_Ancestor (Iface, Typ) then |
f2cbd970 JM |
6888 | Append_To (Stmts_List, |
6889 | Build_Set_Static_Offset_To_Top (Loc, | |
d70d147e | 6890 | Iface_Tag => New_Reference_To (Iface_Tag, Loc), |
f2cbd970 JM |
6891 | Offset_Value => |
6892 | Unchecked_Convert_To (RTE (RE_Storage_Offset), | |
6893 | Make_Attribute_Reference (Loc, | |
6894 | Prefix => | |
6895 | Make_Selected_Component (Loc, | |
d70d147e GD |
6896 | Prefix => New_Copy_Tree (Target), |
6897 | Selector_Name => | |
f2cbd970 JM |
6898 | New_Reference_To (Tag_Comp, Loc)), |
6899 | Attribute_Name => Name_Position)))); | |
6900 | end if; | |
6901 | ||
3476f949 | 6902 | -- Generate: |
f2cbd970 | 6903 | -- Register_Interface_Offset |
3476f949 JM |
6904 | -- (This => Init, |
6905 | -- Interface_T => Iface'Tag, | |
6906 | -- Is_Constant => True, | |
04df6250 TQ |
6907 | -- Offset_Value => n, |
6908 | -- Offset_Func => null); | |
3476f949 | 6909 | |
f2cbd970 JM |
6910 | if RTE_Available (RE_Register_Interface_Offset) then |
6911 | Append_To (Stmts_List, | |
6912 | Make_Procedure_Call_Statement (Loc, | |
6913 | Name => New_Reference_To | |
6914 | (RTE (RE_Register_Interface_Offset), Loc), | |
6915 | Parameter_Associations => New_List ( | |
6916 | Make_Attribute_Reference (Loc, | |
d70d147e | 6917 | Prefix => New_Copy_Tree (Target), |
f2cbd970 | 6918 | Attribute_Name => Name_Address), |
04df6250 | 6919 | |
f2cbd970 JM |
6920 | Unchecked_Convert_To (RTE (RE_Tag), |
6921 | New_Reference_To | |
d70d147e | 6922 | (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)), |
04df6250 | 6923 | |
f2cbd970 | 6924 | New_Occurrence_Of (Standard_True, Loc), |
3476f949 | 6925 | |
f2cbd970 JM |
6926 | Unchecked_Convert_To |
6927 | (RTE (RE_Storage_Offset), | |
6928 | Make_Attribute_Reference (Loc, | |
6929 | Prefix => | |
6930 | Make_Selected_Component (Loc, | |
d70d147e | 6931 | Prefix => New_Copy_Tree (Target), |
f2cbd970 JM |
6932 | Selector_Name => |
6933 | New_Reference_To (Tag_Comp, Loc)), | |
6934 | Attribute_Name => Name_Position)), | |
3476f949 | 6935 | |
f2cbd970 JM |
6936 | Make_Null (Loc)))); |
6937 | end if; | |
04df6250 TQ |
6938 | end if; |
6939 | end Initialize_Tag; | |
3476f949 | 6940 | |
04df6250 | 6941 | -- Local variables |
3476f949 | 6942 | |
04df6250 TQ |
6943 | Full_Typ : Entity_Id; |
6944 | Ifaces_List : Elist_Id; | |
6945 | Ifaces_Comp_List : Elist_Id; | |
6946 | Ifaces_Tag_List : Elist_Id; | |
6947 | Iface_Elmt : Elmt_Id; | |
6948 | Iface_Comp_Elmt : Elmt_Id; | |
6949 | Iface_Tag_Elmt : Elmt_Id; | |
6950 | Tag_Comp : Node_Id; | |
6951 | In_Variable_Pos : Boolean; | |
3476f949 JM |
6952 | |
6953 | -- Start of processing for Init_Secondary_Tags | |
6954 | ||
6955 | begin | |
3476f949 JM |
6956 | -- Handle private types |
6957 | ||
6958 | if Present (Full_View (Typ)) then | |
6959 | Full_Typ := Full_View (Typ); | |
6960 | else | |
6961 | Full_Typ := Typ; | |
6962 | end if; | |
6963 | ||
04df6250 TQ |
6964 | Collect_Interfaces_Info |
6965 | (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List); | |
ea1941af | 6966 | |
04df6250 TQ |
6967 | Iface_Elmt := First_Elmt (Ifaces_List); |
6968 | Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); | |
6969 | Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List); | |
6970 | while Present (Iface_Elmt) loop | |
6971 | Tag_Comp := Node (Iface_Comp_Elmt); | |
6972 | ||
6973 | -- If we are compiling under the CPP full ABI compatibility mode and | |
6974 | -- the ancestor is a CPP_Pragma tagged type then we generate code to | |
6975 | -- inherit the contents of the dispatch table directly from the | |
6976 | -- ancestor. | |
6977 | ||
6978 | if Is_CPP_Class (Etype (Full_Typ)) then | |
6979 | Inherit_CPP_Tag (Full_Typ, | |
6980 | Iface => Node (Iface_Elmt), | |
6981 | Tag_Comp => Tag_Comp, | |
6982 | Iface_Tag => Node (Iface_Tag_Elmt)); | |
6983 | ||
d70d147e | 6984 | -- Otherwise generate code to initialize the tag |
04df6250 TQ |
6985 | |
6986 | else | |
6987 | -- Check if the parent of the record type has variable size | |
6988 | -- components. | |
6989 | ||
6990 | In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp)) | |
6991 | and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp))); | |
6992 | ||
6993 | if (In_Variable_Pos and then Variable_Comps) | |
6994 | or else (not In_Variable_Pos and then Fixed_Comps) | |
6995 | then | |
6996 | Initialize_Tag (Full_Typ, | |
6997 | Iface => Node (Iface_Elmt), | |
6998 | Tag_Comp => Tag_Comp, | |
6999 | Iface_Tag => Node (Iface_Tag_Elmt)); | |
7000 | end if; | |
7001 | end if; | |
7002 | ||
7003 | Next_Elmt (Iface_Elmt); | |
7004 | Next_Elmt (Iface_Comp_Elmt); | |
7005 | Next_Elmt (Iface_Tag_Elmt); | |
7006 | end loop; | |
3476f949 JM |
7007 | end Init_Secondary_Tags; |
7008 | ||
04df6250 TQ |
7009 | ----------------------------- |
7010 | -- Is_Variable_Size_Record -- | |
7011 | ----------------------------- | |
7012 | ||
7013 | function Is_Variable_Size_Record (E : Entity_Id) return Boolean is | |
7014 | Comp : Entity_Id; | |
7015 | Comp_Typ : Entity_Id; | |
7016 | Idx : Node_Id; | |
7017 | ||
f2cbd970 JM |
7018 | function Is_Constant_Bound (Exp : Node_Id) return Boolean; |
7019 | -- To simplify handling of array components. Determines whether the | |
7020 | -- given bound is constant (a constant or enumeration literal, or an | |
7021 | -- integer literal) as opposed to per-object, through an expression | |
7022 | -- or a discriminant. | |
7023 | ||
7024 | ----------------------- | |
7025 | -- Is_Constant_Bound -- | |
7026 | ----------------------- | |
7027 | ||
7028 | function Is_Constant_Bound (Exp : Node_Id) return Boolean is | |
7029 | begin | |
7030 | if Nkind (Exp) = N_Integer_Literal then | |
7031 | return True; | |
7032 | else | |
7033 | return | |
7034 | Is_Entity_Name (Exp) | |
7035 | and then Present (Entity (Exp)) | |
7036 | and then | |
7037 | (Ekind (Entity (Exp)) = E_Constant | |
7038 | or else Ekind (Entity (Exp)) = E_Enumeration_Literal); | |
7039 | end if; | |
7040 | end Is_Constant_Bound; | |
7041 | ||
7042 | -- Start of processing for Is_Variable_Sized_Record | |
7043 | ||
04df6250 TQ |
7044 | begin |
7045 | pragma Assert (Is_Record_Type (E)); | |
7046 | ||
7047 | Comp := First_Entity (E); | |
7048 | while Present (Comp) loop | |
7049 | Comp_Typ := Etype (Comp); | |
7050 | ||
7051 | if Is_Record_Type (Comp_Typ) then | |
7052 | ||
7053 | -- Recursive call if the record type has discriminants | |
7054 | ||
7055 | if Has_Discriminants (Comp_Typ) | |
7056 | and then Is_Variable_Size_Record (Comp_Typ) | |
7057 | then | |
7058 | return True; | |
7059 | end if; | |
7060 | ||
7061 | elsif Is_Array_Type (Comp_Typ) then | |
7062 | ||
7063 | -- Check if some index is initialized with a non-constant value | |
7064 | ||
7065 | Idx := First_Index (Comp_Typ); | |
7066 | while Present (Idx) loop | |
7067 | if Nkind (Idx) = N_Range then | |
f2cbd970 JM |
7068 | if not Is_Constant_Bound (Low_Bound (Idx)) |
7069 | or else | |
7070 | not Is_Constant_Bound (High_Bound (Idx)) | |
04df6250 TQ |
7071 | then |
7072 | return True; | |
7073 | end if; | |
7074 | end if; | |
7075 | ||
7076 | Idx := Next_Index (Idx); | |
7077 | end loop; | |
7078 | end if; | |
7079 | ||
7080 | Next_Entity (Comp); | |
7081 | end loop; | |
7082 | ||
7083 | return False; | |
7084 | end Is_Variable_Size_Record; | |
7085 | ||
3476f949 JM |
7086 | ---------------------------------------- |
7087 | -- Make_Controlling_Function_Wrappers -- | |
7088 | ---------------------------------------- | |
a05e99a2 JM |
7089 | |
7090 | procedure Make_Controlling_Function_Wrappers | |
7091 | (Tag_Typ : Entity_Id; | |
7092 | Decl_List : out List_Id; | |
7093 | Body_List : out List_Id) | |
7094 | is | |
7095 | Loc : constant Source_Ptr := Sloc (Tag_Typ); | |
7096 | Prim_Elmt : Elmt_Id; | |
7097 | Subp : Entity_Id; | |
7098 | Actual_List : List_Id; | |
7099 | Formal_List : List_Id; | |
7100 | Formal : Entity_Id; | |
7101 | Par_Formal : Entity_Id; | |
7102 | Formal_Node : Node_Id; | |
a05e99a2 | 7103 | Func_Body : Node_Id; |
55d4e6c0 ES |
7104 | Func_Decl : Node_Id; |
7105 | Func_Spec : Node_Id; | |
a05e99a2 JM |
7106 | Return_Stmt : Node_Id; |
7107 | ||
7108 | begin | |
7109 | Decl_List := New_List; | |
7110 | Body_List := New_List; | |
7111 | ||
7112 | Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); | |
7113 | ||
7114 | while Present (Prim_Elmt) loop | |
7115 | Subp := Node (Prim_Elmt); | |
7116 | ||
7117 | -- If a primitive function with a controlling result of the type has | |
7118 | -- not been overridden by the user, then we must create a wrapper | |
7119 | -- function here that effectively overrides it and invokes the | |
3476f949 JM |
7120 | -- (non-abstract) parent function. This can only occur for a null |
7121 | -- extension. Note that functions with anonymous controlling access | |
7122 | -- results don't qualify and must be overridden. We also exclude | |
7123 | -- Input attributes, since each type will have its own version of | |
7124 | -- Input constructed by the expander. The test for Comes_From_Source | |
7125 | -- is needed to distinguish inherited operations from renamings | |
7126 | -- (which also have Alias set). | |
04df6250 | 7127 | |
47cc8d6b ES |
7128 | -- The function may be abstract, or require_Overriding may be set |
7129 | -- for it, because tests for null extensions may already have reset | |
04df6250 TQ |
7130 | -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not |
7131 | -- set, functions that need wrappers are recognized by having an | |
7132 | -- alias that returns the parent type. | |
7133 | ||
7134 | if Comes_From_Source (Subp) | |
7135 | or else No (Alias (Subp)) | |
7136 | or else Ekind (Subp) /= E_Function | |
7137 | or else not Has_Controlling_Result (Subp) | |
7138 | or else Is_Access_Type (Etype (Subp)) | |
7139 | or else Is_Abstract_Subprogram (Alias (Subp)) | |
7140 | or else Is_TSS (Subp, TSS_Stream_Input) | |
7141 | then | |
7142 | goto Next_Prim; | |
7143 | ||
7144 | elsif Is_Abstract_Subprogram (Subp) | |
7145 | or else Requires_Overriding (Subp) | |
7146 | or else | |
7147 | (Is_Null_Extension (Etype (Subp)) | |
7148 | and then Etype (Alias (Subp)) /= Etype (Subp)) | |
a05e99a2 JM |
7149 | then |
7150 | Formal_List := No_List; | |
7151 | Formal := First_Formal (Subp); | |
7152 | ||
7153 | if Present (Formal) then | |
7154 | Formal_List := New_List; | |
7155 | ||
7156 | while Present (Formal) loop | |
7157 | Append | |
7158 | (Make_Parameter_Specification | |
7159 | (Loc, | |
7160 | Defining_Identifier => | |
7161 | Make_Defining_Identifier (Sloc (Formal), | |
7162 | Chars => Chars (Formal)), | |
7163 | In_Present => In_Present (Parent (Formal)), | |
7164 | Out_Present => Out_Present (Parent (Formal)), | |
04df6250 TQ |
7165 | Null_Exclusion_Present => |
7166 | Null_Exclusion_Present (Parent (Formal)), | |
a05e99a2 JM |
7167 | Parameter_Type => |
7168 | New_Reference_To (Etype (Formal), Loc), | |
7169 | Expression => | |
7170 | New_Copy_Tree (Expression (Parent (Formal)))), | |
7171 | Formal_List); | |
7172 | ||
7173 | Next_Formal (Formal); | |
7174 | end loop; | |
7175 | end if; | |
7176 | ||
7177 | Func_Spec := | |
7178 | Make_Function_Specification (Loc, | |
04df6250 TQ |
7179 | Defining_Unit_Name => |
7180 | Make_Defining_Identifier (Loc, | |
7181 | Chars => Chars (Subp)), | |
7182 | Parameter_Specifications => Formal_List, | |
7183 | Result_Definition => | |
a05e99a2 JM |
7184 | New_Reference_To (Etype (Subp), Loc)); |
7185 | ||
7186 | Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); | |
7187 | Append_To (Decl_List, Func_Decl); | |
7188 | ||
7189 | -- Build a wrapper body that calls the parent function. The body | |
7190 | -- contains a single return statement that returns an extension | |
7191 | -- aggregate whose ancestor part is a call to the parent function, | |
7192 | -- passing the formals as actuals (with any controlling arguments | |
7193 | -- converted to the types of the corresponding formals of the | |
7194 | -- parent function, which might be anonymous access types), and | |
7195 | -- having a null extension. | |
7196 | ||
7197 | Formal := First_Formal (Subp); | |
7198 | Par_Formal := First_Formal (Alias (Subp)); | |
7199 | Formal_Node := First (Formal_List); | |
7200 | ||
7201 | if Present (Formal) then | |
7202 | Actual_List := New_List; | |
7203 | else | |
7204 | Actual_List := No_List; | |
7205 | end if; | |
7206 | ||
7207 | while Present (Formal) loop | |
7208 | if Is_Controlling_Formal (Formal) then | |
7209 | Append_To (Actual_List, | |
7210 | Make_Type_Conversion (Loc, | |
7211 | Subtype_Mark => | |
7212 | New_Occurrence_Of (Etype (Par_Formal), Loc), | |
7213 | Expression => | |
7214 | New_Reference_To | |
7215 | (Defining_Identifier (Formal_Node), Loc))); | |
7216 | else | |
7217 | Append_To | |
7218 | (Actual_List, | |
7219 | New_Reference_To | |
7220 | (Defining_Identifier (Formal_Node), Loc)); | |
7221 | end if; | |
7222 | ||
7223 | Next_Formal (Formal); | |
7224 | Next_Formal (Par_Formal); | |
7225 | Next (Formal_Node); | |
7226 | end loop; | |
7227 | ||
7228 | Return_Stmt := | |
04df6250 | 7229 | Make_Simple_Return_Statement (Loc, |
a05e99a2 JM |
7230 | Expression => |
7231 | Make_Extension_Aggregate (Loc, | |
7232 | Ancestor_Part => | |
7233 | Make_Function_Call (Loc, | |
7234 | Name => New_Reference_To (Alias (Subp), Loc), | |
7235 | Parameter_Associations => Actual_List), | |
7236 | Null_Record_Present => True)); | |
7237 | ||
7238 | Func_Body := | |
7239 | Make_Subprogram_Body (Loc, | |
7240 | Specification => New_Copy_Tree (Func_Spec), | |
7241 | Declarations => Empty_List, | |
7242 | Handled_Statement_Sequence => | |
7243 | Make_Handled_Sequence_Of_Statements (Loc, | |
7244 | Statements => New_List (Return_Stmt))); | |
7245 | ||
7246 | Set_Defining_Unit_Name | |
7247 | (Specification (Func_Body), | |
7248 | Make_Defining_Identifier (Loc, Chars (Subp))); | |
7249 | ||
7250 | Append_To (Body_List, Func_Body); | |
7251 | ||
7252 | -- Replace the inherited function with the wrapper function | |
7253 | -- in the primitive operations list. | |
7254 | ||
7255 | Override_Dispatching_Operation | |
7256 | (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec)); | |
7257 | end if; | |
7258 | ||
04df6250 | 7259 | <<Next_Prim>> |
a05e99a2 JM |
7260 | Next_Elmt (Prim_Elmt); |
7261 | end loop; | |
7262 | end Make_Controlling_Function_Wrappers; | |
7263 | ||
70482933 RK |
7264 | ------------------ |
7265 | -- Make_Eq_Case -- | |
7266 | ------------------ | |
7267 | ||
d70d147e | 7268 | -- <Make_Eq_If shared components> |
70482933 RK |
7269 | -- case X.D1 is |
7270 | -- when V1 => <Make_Eq_Case> on subcomponents | |
7271 | -- ... | |
7272 | -- when Vn => <Make_Eq_Case> on subcomponents | |
7273 | -- end case; | |
7274 | ||
5d09245e AC |
7275 | function Make_Eq_Case |
7276 | (E : Entity_Id; | |
7277 | CL : Node_Id; | |
7278 | Discr : Entity_Id := Empty) return List_Id | |
7279 | is | |
7280 | Loc : constant Source_Ptr := Sloc (E); | |
fbf5a39b | 7281 | Result : constant List_Id := New_List; |
70482933 RK |
7282 | Variant : Node_Id; |
7283 | Alt_List : List_Id; | |
70482933 RK |
7284 | |
7285 | begin | |
5d09245e | 7286 | Append_To (Result, Make_Eq_If (E, Component_Items (CL))); |
70482933 RK |
7287 | |
7288 | if No (Variant_Part (CL)) then | |
7289 | return Result; | |
7290 | end if; | |
7291 | ||
7292 | Variant := First_Non_Pragma (Variants (Variant_Part (CL))); | |
7293 | ||
7294 | if No (Variant) then | |
7295 | return Result; | |
7296 | end if; | |
7297 | ||
7298 | Alt_List := New_List; | |
7299 | ||
7300 | while Present (Variant) loop | |
7301 | Append_To (Alt_List, | |
7302 | Make_Case_Statement_Alternative (Loc, | |
7303 | Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)), | |
5d09245e | 7304 | Statements => Make_Eq_Case (E, Component_List (Variant)))); |
70482933 RK |
7305 | |
7306 | Next_Non_Pragma (Variant); | |
7307 | end loop; | |
7308 | ||
5d09245e AC |
7309 | -- If we have an Unchecked_Union, use one of the parameters that |
7310 | -- captures the discriminants. | |
7311 | ||
7312 | if Is_Unchecked_Union (E) then | |
7313 | Append_To (Result, | |
7314 | Make_Case_Statement (Loc, | |
7315 | Expression => New_Reference_To (Discr, Loc), | |
7316 | Alternatives => Alt_List)); | |
7317 | ||
7318 | else | |
7319 | Append_To (Result, | |
7320 | Make_Case_Statement (Loc, | |
7321 | Expression => | |
7322 | Make_Selected_Component (Loc, | |
7323 | Prefix => Make_Identifier (Loc, Name_X), | |
7324 | Selector_Name => New_Copy (Name (Variant_Part (CL)))), | |
7325 | Alternatives => Alt_List)); | |
7326 | end if; | |
70482933 RK |
7327 | |
7328 | return Result; | |
7329 | end Make_Eq_Case; | |
7330 | ||
7331 | ---------------- | |
7332 | -- Make_Eq_If -- | |
7333 | ---------------- | |
7334 | ||
7335 | -- Generates: | |
7336 | ||
7337 | -- if | |
7338 | -- X.C1 /= Y.C1 | |
7339 | -- or else | |
7340 | -- X.C2 /= Y.C2 | |
7341 | -- ... | |
7342 | -- then | |
7343 | -- return False; | |
7344 | -- end if; | |
7345 | ||
5a30024a | 7346 | -- or a null statement if the list L is empty |
70482933 | 7347 | |
5d09245e AC |
7348 | function Make_Eq_If |
7349 | (E : Entity_Id; | |
7350 | L : List_Id) return Node_Id | |
7351 | is | |
7352 | Loc : constant Source_Ptr := Sloc (E); | |
70482933 RK |
7353 | C : Node_Id; |
7354 | Field_Name : Name_Id; | |
7355 | Cond : Node_Id; | |
7356 | ||
7357 | begin | |
7358 | if No (L) then | |
7359 | return Make_Null_Statement (Loc); | |
7360 | ||
7361 | else | |
7362 | Cond := Empty; | |
7363 | ||
7364 | C := First_Non_Pragma (L); | |
7365 | while Present (C) loop | |
7366 | Field_Name := Chars (Defining_Identifier (C)); | |
7367 | ||
47cc8d6b ES |
7368 | -- The tags must not be compared: they are not part of the value. |
7369 | -- Ditto for the controller component, if present. | |
7370 | ||
70482933 RK |
7371 | -- Note also that in the following, we use Make_Identifier for |
7372 | -- the component names. Use of New_Reference_To to identify the | |
7373 | -- components would be incorrect because the wrong entities for | |
7374 | -- discriminants could be picked up in the private type case. | |
7375 | ||
47cc8d6b ES |
7376 | if Field_Name /= Name_uTag |
7377 | and then | |
7378 | Field_Name /= Name_uController | |
7379 | then | |
70482933 RK |
7380 | Evolve_Or_Else (Cond, |
7381 | Make_Op_Ne (Loc, | |
7382 | Left_Opnd => | |
7383 | Make_Selected_Component (Loc, | |
7384 | Prefix => Make_Identifier (Loc, Name_X), | |
7385 | Selector_Name => | |
7386 | Make_Identifier (Loc, Field_Name)), | |
7387 | ||
7388 | Right_Opnd => | |
7389 | Make_Selected_Component (Loc, | |
7390 | Prefix => Make_Identifier (Loc, Name_Y), | |
7391 | Selector_Name => | |
7392 | Make_Identifier (Loc, Field_Name)))); | |
7393 | end if; | |
7394 | ||
7395 | Next_Non_Pragma (C); | |
7396 | end loop; | |
7397 | ||
7398 | if No (Cond) then | |
7399 | return Make_Null_Statement (Loc); | |
7400 | ||
7401 | else | |
7402 | return | |
5d09245e | 7403 | Make_Implicit_If_Statement (E, |
70482933 RK |
7404 | Condition => Cond, |
7405 | Then_Statements => New_List ( | |
04df6250 | 7406 | Make_Simple_Return_Statement (Loc, |
70482933 RK |
7407 | Expression => New_Occurrence_Of (Standard_False, Loc)))); |
7408 | end if; | |
7409 | end if; | |
7410 | end Make_Eq_If; | |
7411 | ||
3476f949 JM |
7412 | ------------------------------- |
7413 | -- Make_Null_Procedure_Specs -- | |
7414 | ------------------------------- | |
7415 | ||
7416 | procedure Make_Null_Procedure_Specs | |
7417 | (Tag_Typ : Entity_Id; | |
7418 | Decl_List : out List_Id) | |
7419 | is | |
7420 | Loc : constant Source_Ptr := Sloc (Tag_Typ); | |
7421 | Formal : Entity_Id; | |
7422 | Formal_List : List_Id; | |
7423 | Parent_Subp : Entity_Id; | |
7424 | Prim_Elmt : Elmt_Id; | |
7425 | Proc_Spec : Node_Id; | |
7426 | Proc_Decl : Node_Id; | |
7427 | Subp : Entity_Id; | |
7428 | ||
7429 | function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean; | |
7430 | -- Returns True if E is a null procedure that is an interface primitive | |
7431 | ||
7432 | --------------------------------- | |
7433 | -- Is_Null_Interface_Primitive -- | |
7434 | --------------------------------- | |
7435 | ||
7436 | function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is | |
7437 | begin | |
7438 | return Comes_From_Source (E) | |
7439 | and then Is_Dispatching_Operation (E) | |
7440 | and then Ekind (E) = E_Procedure | |
7441 | and then Null_Present (Parent (E)) | |
7442 | and then Is_Interface (Find_Dispatching_Type (E)); | |
7443 | end Is_Null_Interface_Primitive; | |
7444 | ||
7445 | -- Start of processing for Make_Null_Procedure_Specs | |
7446 | ||
7447 | begin | |
7448 | Decl_List := New_List; | |
7449 | Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); | |
7450 | while Present (Prim_Elmt) loop | |
7451 | Subp := Node (Prim_Elmt); | |
7452 | ||
7453 | -- If a null procedure inherited from an interface has not been | |
7454 | -- overridden, then we build a null procedure declaration to | |
7455 | -- override the inherited procedure. | |
7456 | ||
7457 | Parent_Subp := Alias (Subp); | |
7458 | ||
7459 | if Present (Parent_Subp) | |
7460 | and then Is_Null_Interface_Primitive (Parent_Subp) | |
7461 | then | |
7462 | Formal_List := No_List; | |
7463 | Formal := First_Formal (Subp); | |
7464 | ||
7465 | if Present (Formal) then | |
7466 | Formal_List := New_List; | |
7467 | ||
7468 | while Present (Formal) loop | |
7469 | Append | |
7470 | (Make_Parameter_Specification (Loc, | |
7471 | Defining_Identifier => | |
7472 | Make_Defining_Identifier (Sloc (Formal), | |
7473 | Chars => Chars (Formal)), | |
7474 | In_Present => In_Present (Parent (Formal)), | |
7475 | Out_Present => Out_Present (Parent (Formal)), | |
04df6250 TQ |
7476 | Null_Exclusion_Present => |
7477 | Null_Exclusion_Present (Parent (Formal)), | |
3476f949 JM |
7478 | Parameter_Type => |
7479 | New_Reference_To (Etype (Formal), Loc), | |
7480 | Expression => | |
7481 | New_Copy_Tree (Expression (Parent (Formal)))), | |
7482 | Formal_List); | |
7483 | ||
7484 | Next_Formal (Formal); | |
7485 | end loop; | |
7486 | end if; | |
7487 | ||
7488 | Proc_Spec := | |
7489 | Make_Procedure_Specification (Loc, | |
7490 | Defining_Unit_Name => | |
7491 | Make_Defining_Identifier (Loc, Chars (Subp)), | |
7492 | Parameter_Specifications => Formal_List); | |
7493 | Set_Null_Present (Proc_Spec); | |
7494 | ||
7495 | Proc_Decl := Make_Subprogram_Declaration (Loc, Proc_Spec); | |
7496 | Append_To (Decl_List, Proc_Decl); | |
7497 | Analyze (Proc_Decl); | |
7498 | end if; | |
7499 | ||
7500 | Next_Elmt (Prim_Elmt); | |
7501 | end loop; | |
7502 | end Make_Null_Procedure_Specs; | |
7503 | ||
70482933 RK |
7504 | ------------------------------------- |
7505 | -- Make_Predefined_Primitive_Specs -- | |
7506 | ------------------------------------- | |
7507 | ||
7508 | procedure Make_Predefined_Primitive_Specs | |
7509 | (Tag_Typ : Entity_Id; | |
7510 | Predef_List : out List_Id; | |
4ce9a2d8 | 7511 | Renamed_Eq : out Entity_Id) |
70482933 RK |
7512 | is |
7513 | Loc : constant Source_Ptr := Sloc (Tag_Typ); | |
fbf5a39b | 7514 | Res : constant List_Id := New_List; |
70482933 RK |
7515 | Prim : Elmt_Id; |
7516 | Eq_Needed : Boolean; | |
7517 | Eq_Spec : Node_Id; | |
7518 | Eq_Name : Name_Id := Name_Op_Eq; | |
7519 | ||
7520 | function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean; | |
7521 | -- Returns true if Prim is a renaming of an unresolved predefined | |
7522 | -- equality operation. | |
7523 | ||
fbf5a39b AC |
7524 | ------------------------------- |
7525 | -- Is_Predefined_Eq_Renaming -- | |
7526 | ------------------------------- | |
7527 | ||
70482933 RK |
7528 | function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is |
7529 | begin | |
7530 | return Chars (Prim) /= Name_Op_Eq | |
7531 | and then Present (Alias (Prim)) | |
7532 | and then Comes_From_Source (Prim) | |
7533 | and then Is_Intrinsic_Subprogram (Alias (Prim)) | |
7534 | and then Chars (Alias (Prim)) = Name_Op_Eq; | |
7535 | end Is_Predefined_Eq_Renaming; | |
7536 | ||
7537 | -- Start of processing for Make_Predefined_Primitive_Specs | |
7538 | ||
7539 | begin | |
7540 | Renamed_Eq := Empty; | |
7541 | ||
a9d8907c | 7542 | -- Spec of _Size |
fbf5a39b AC |
7543 | |
7544 | Append_To (Res, Predef_Spec_Or_Body (Loc, | |
7545 | Tag_Typ => Tag_Typ, | |
a9d8907c | 7546 | Name => Name_uSize, |
fbf5a39b AC |
7547 | Profile => New_List ( |
7548 | Make_Parameter_Specification (Loc, | |
7549 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
7550 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))), | |
7551 | ||
a9d8907c | 7552 | Ret_Type => Standard_Long_Long_Integer)); |
fbf5a39b | 7553 | |
a9d8907c | 7554 | -- Spec of _Alignment |
70482933 RK |
7555 | |
7556 | Append_To (Res, Predef_Spec_Or_Body (Loc, | |
7557 | Tag_Typ => Tag_Typ, | |
a9d8907c | 7558 | Name => Name_uAlignment, |
70482933 RK |
7559 | Profile => New_List ( |
7560 | Make_Parameter_Specification (Loc, | |
7561 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
7562 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))), | |
7563 | ||
a9d8907c | 7564 | Ret_Type => Standard_Integer)); |
70482933 | 7565 | |
3ca505dc | 7566 | -- Specs for dispatching stream attributes |
d2d3604c TQ |
7567 | |
7568 | declare | |
7569 | Stream_Op_TSS_Names : | |
7570 | constant array (Integer range <>) of TSS_Name_Type := | |
7571 | (TSS_Stream_Read, | |
7572 | TSS_Stream_Write, | |
7573 | TSS_Stream_Input, | |
7574 | TSS_Stream_Output); | |
ae7adb1b | 7575 | |
d2d3604c TQ |
7576 | begin |
7577 | for Op in Stream_Op_TSS_Names'Range loop | |
7578 | if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then | |
7579 | Append_To (Res, | |
ae7adb1b ES |
7580 | Predef_Stream_Attr_Spec (Loc, Tag_Typ, |
7581 | Stream_Op_TSS_Names (Op))); | |
d2d3604c TQ |
7582 | end if; |
7583 | end loop; | |
7584 | end; | |
70482933 | 7585 | |
4ce9a2d8 | 7586 | -- Spec of "=" is expanded if the type is not limited and if a |
fbf5a39b AC |
7587 | -- user defined "=" was not already declared for the non-full |
7588 | -- view of a private extension | |
70482933 | 7589 | |
fbf5a39b | 7590 | if not Is_Limited_Type (Tag_Typ) then |
70482933 | 7591 | Eq_Needed := True; |
70482933 RK |
7592 | Prim := First_Elmt (Primitive_Operations (Tag_Typ)); |
7593 | while Present (Prim) loop | |
fbf5a39b | 7594 | |
70482933 RK |
7595 | -- If a primitive is encountered that renames the predefined |
7596 | -- equality operator before reaching any explicit equality | |
7597 | -- primitive, then we still need to create a predefined | |
7598 | -- equality function, because calls to it can occur via | |
7599 | -- the renaming. A new name is created for the equality | |
7600 | -- to avoid conflicting with any user-defined equality. | |
7601 | -- (Note that this doesn't account for renamings of | |
7602 | -- equality nested within subpackages???) | |
7603 | ||
7604 | if Is_Predefined_Eq_Renaming (Node (Prim)) then | |
7605 | Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); | |
7606 | ||
4ce9a2d8 HK |
7607 | -- User-defined equality |
7608 | ||
70482933 | 7609 | elsif Chars (Node (Prim)) = Name_Op_Eq |
70482933 RK |
7610 | and then Etype (First_Formal (Node (Prim))) = |
7611 | Etype (Next_Formal (First_Formal (Node (Prim)))) | |
e6f69614 | 7612 | and then Base_Type (Etype (Node (Prim))) = Standard_Boolean |
70482933 | 7613 | then |
ce2b6ba5 JM |
7614 | if No (Alias (Node (Prim))) |
7615 | or else Nkind (Unit_Declaration_Node (Node (Prim))) = | |
7616 | N_Subprogram_Renaming_Declaration | |
7617 | then | |
7618 | Eq_Needed := False; | |
7619 | exit; | |
70482933 | 7620 | |
ce2b6ba5 JM |
7621 | -- If the parent is not an interface type and has an abstract |
7622 | -- equality function, the inherited equality is abstract as | |
7623 | -- well, and no body can be created for it. | |
70482933 | 7624 | |
ce2b6ba5 JM |
7625 | elsif not Is_Interface (Etype (Tag_Typ)) |
7626 | and then Present (Alias (Node (Prim))) | |
7627 | and then Is_Abstract_Subprogram (Alias (Node (Prim))) | |
7628 | then | |
7629 | Eq_Needed := False; | |
7630 | exit; | |
7631 | ||
7632 | -- If the type has an equality function corresponding with | |
7633 | -- a primitive defined in an interface type, the inherited | |
7634 | -- equality is abstract as well, and no body can be created | |
7635 | -- for it. | |
7636 | ||
7637 | elsif Present (Alias (Node (Prim))) | |
7638 | and then Comes_From_Source (Ultimate_Alias (Node (Prim))) | |
7639 | and then | |
7640 | Is_Interface | |
7641 | (Find_Dispatching_Type (Ultimate_Alias (Node (Prim)))) | |
7642 | then | |
7643 | Eq_Needed := False; | |
7644 | exit; | |
7645 | end if; | |
70482933 RK |
7646 | end if; |
7647 | ||
7648 | Next_Elmt (Prim); | |
7649 | end loop; | |
7650 | ||
47cc8d6b ES |
7651 | -- If a renaming of predefined equality was found but there was no |
7652 | -- user-defined equality (so Eq_Needed is still true), then set the | |
7653 | -- name back to Name_Op_Eq. But in the case where a user-defined | |
7654 | -- equality was located after such a renaming, then the predefined | |
7655 | -- equality function is still needed, so Eq_Needed must be set back | |
7656 | -- to True. | |
70482933 RK |
7657 | |
7658 | if Eq_Name /= Name_Op_Eq then | |
7659 | if Eq_Needed then | |
7660 | Eq_Name := Name_Op_Eq; | |
7661 | else | |
7662 | Eq_Needed := True; | |
7663 | end if; | |
7664 | end if; | |
7665 | ||
7666 | if Eq_Needed then | |
7667 | Eq_Spec := Predef_Spec_Or_Body (Loc, | |
7668 | Tag_Typ => Tag_Typ, | |
7669 | Name => Eq_Name, | |
7670 | Profile => New_List ( | |
7671 | Make_Parameter_Specification (Loc, | |
7672 | Defining_Identifier => | |
7673 | Make_Defining_Identifier (Loc, Name_X), | |
7674 | Parameter_Type => New_Reference_To (Tag_Typ, Loc)), | |
7675 | Make_Parameter_Specification (Loc, | |
7676 | Defining_Identifier => | |
7677 | Make_Defining_Identifier (Loc, Name_Y), | |
7678 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))), | |
7679 | Ret_Type => Standard_Boolean); | |
7680 | Append_To (Res, Eq_Spec); | |
7681 | ||
7682 | if Eq_Name /= Name_Op_Eq then | |
7683 | Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec)); | |
7684 | ||
7685 | Prim := First_Elmt (Primitive_Operations (Tag_Typ)); | |
7686 | while Present (Prim) loop | |
7687 | ||
7688 | -- Any renamings of equality that appeared before an | |
47cc8d6b ES |
7689 | -- overriding equality must be updated to refer to the |
7690 | -- entity for the predefined equality, otherwise calls via | |
7691 | -- the renaming would get incorrectly resolved to call the | |
7692 | -- user-defined equality function. | |
70482933 RK |
7693 | |
7694 | if Is_Predefined_Eq_Renaming (Node (Prim)) then | |
7695 | Set_Alias (Node (Prim), Renamed_Eq); | |
7696 | ||
7697 | -- Exit upon encountering a user-defined equality | |
7698 | ||
7699 | elsif Chars (Node (Prim)) = Name_Op_Eq | |
7700 | and then No (Alias (Node (Prim))) | |
7701 | then | |
7702 | exit; | |
7703 | end if; | |
7704 | ||
7705 | Next_Elmt (Prim); | |
7706 | end loop; | |
7707 | end if; | |
7708 | end if; | |
7709 | ||
7710 | -- Spec for dispatching assignment | |
7711 | ||
7712 | Append_To (Res, Predef_Spec_Or_Body (Loc, | |
7713 | Tag_Typ => Tag_Typ, | |
7714 | Name => Name_uAssign, | |
7715 | Profile => New_List ( | |
7716 | Make_Parameter_Specification (Loc, | |
7717 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
7718 | Out_Present => True, | |
7719 | Parameter_Type => New_Reference_To (Tag_Typ, Loc)), | |
7720 | ||
7721 | Make_Parameter_Specification (Loc, | |
7722 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), | |
7723 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))))); | |
7724 | end if; | |
7725 | ||
47cc8d6b ES |
7726 | -- Ada 2005: Generate declarations for the following primitive |
7727 | -- operations for limited interfaces and synchronized types that | |
7728 | -- implement a limited interface. | |
4d744221 | 7729 | |
4ce9a2d8 HK |
7730 | -- Disp_Asynchronous_Select |
7731 | -- Disp_Conditional_Select | |
7732 | -- Disp_Get_Prim_Op_Kind | |
7733 | -- Disp_Get_Task_Id | |
7734 | -- Disp_Requeue | |
7735 | -- Disp_Timed_Select | |
4d744221 | 7736 | |
47cc8d6b ES |
7737 | -- These operations cannot be implemented on VM targets, so we simply |
7738 | -- disable their generation in this case. We also disable generation | |
7739 | -- of these bodies if No_Dispatching_Calls is active. | |
10b93b2e HK |
7740 | |
7741 | if Ada_Version >= Ada_05 | |
47cc8d6b | 7742 | and then VM_Target = No_VM |
f2cbd970 | 7743 | and then RTE_Available (RE_Select_Specific_Data) |
10b93b2e | 7744 | then |
4ce9a2d8 | 7745 | -- These primitives are defined abstract in interface types |
10b93b2e | 7746 | |
4ce9a2d8 HK |
7747 | if Is_Interface (Tag_Typ) |
7748 | and then Is_Limited_Record (Tag_Typ) | |
7749 | then | |
7750 | Append_To (Res, | |
7751 | Make_Abstract_Subprogram_Declaration (Loc, | |
7752 | Specification => | |
7753 | Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); | |
10b93b2e | 7754 | |
4ce9a2d8 HK |
7755 | Append_To (Res, |
7756 | Make_Abstract_Subprogram_Declaration (Loc, | |
7757 | Specification => | |
7758 | Make_Disp_Conditional_Select_Spec (Tag_Typ))); | |
10b93b2e | 7759 | |
4ce9a2d8 HK |
7760 | Append_To (Res, |
7761 | Make_Abstract_Subprogram_Declaration (Loc, | |
7762 | Specification => | |
7763 | Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); | |
10b93b2e | 7764 | |
4ce9a2d8 HK |
7765 | Append_To (Res, |
7766 | Make_Abstract_Subprogram_Declaration (Loc, | |
7767 | Specification => | |
7768 | Make_Disp_Get_Task_Id_Spec (Tag_Typ))); | |
7769 | ||
7770 | Append_To (Res, | |
7771 | Make_Abstract_Subprogram_Declaration (Loc, | |
7772 | Specification => | |
7773 | Make_Disp_Requeue_Spec (Tag_Typ))); | |
7774 | ||
7775 | Append_To (Res, | |
7776 | Make_Abstract_Subprogram_Declaration (Loc, | |
7777 | Specification => | |
7778 | Make_Disp_Timed_Select_Spec (Tag_Typ))); | |
7779 | ||
7780 | -- If the ancestor is an interface type we declare non-abstract | |
7781 | -- primitives to override the abstract primitives of the interface | |
7782 | -- type. | |
7783 | ||
7784 | elsif (not Is_Interface (Tag_Typ) | |
7785 | and then Is_Interface (Etype (Tag_Typ)) | |
7786 | and then Is_Limited_Record (Etype (Tag_Typ))) | |
7787 | or else | |
7788 | (Is_Concurrent_Record_Type (Tag_Typ) | |
ce2b6ba5 | 7789 | and then Has_Interfaces (Tag_Typ)) |
4ce9a2d8 HK |
7790 | then |
7791 | Append_To (Res, | |
7792 | Make_Subprogram_Declaration (Loc, | |
7793 | Specification => | |
7794 | Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); | |
7795 | ||
7796 | Append_To (Res, | |
7797 | Make_Subprogram_Declaration (Loc, | |
7798 | Specification => | |
7799 | Make_Disp_Conditional_Select_Spec (Tag_Typ))); | |
7800 | ||
7801 | Append_To (Res, | |
7802 | Make_Subprogram_Declaration (Loc, | |
7803 | Specification => | |
7804 | Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); | |
7805 | ||
7806 | Append_To (Res, | |
7807 | Make_Subprogram_Declaration (Loc, | |
7808 | Specification => | |
7809 | Make_Disp_Get_Task_Id_Spec (Tag_Typ))); | |
7810 | ||
7811 | Append_To (Res, | |
7812 | Make_Subprogram_Declaration (Loc, | |
7813 | Specification => | |
7814 | Make_Disp_Requeue_Spec (Tag_Typ))); | |
7815 | ||
7816 | Append_To (Res, | |
7817 | Make_Subprogram_Declaration (Loc, | |
7818 | Specification => | |
7819 | Make_Disp_Timed_Select_Spec (Tag_Typ))); | |
7820 | end if; | |
10b93b2e HK |
7821 | end if; |
7822 | ||
47cc8d6b ES |
7823 | -- Specs for finalization actions that may be required in case a future |
7824 | -- extension contain a controlled element. We generate those only for | |
7825 | -- root tagged types where they will get dummy bodies or when the type | |
7826 | -- has controlled components and their body must be generated. It is | |
7827 | -- also impossible to provide those for tagged types defined within | |
7828 | -- s-finimp since it would involve circularity problems | |
70482933 RK |
7829 | |
7830 | if In_Finalization_Root (Tag_Typ) then | |
7831 | null; | |
7832 | ||
fbf5a39b | 7833 | -- We also skip these if finalization is not available |
70482933 | 7834 | |
6e937c1c | 7835 | elsif Restriction_Active (No_Finalization) then |
70482933 RK |
7836 | null; |
7837 | ||
3476f949 JM |
7838 | elsif Etype (Tag_Typ) = Tag_Typ |
7839 | or else Controlled_Type (Tag_Typ) | |
7840 | ||
7841 | -- Ada 2005 (AI-251): We must also generate these subprograms if | |
7842 | -- the immediate ancestor is an interface to ensure the correct | |
7843 | -- initialization of its dispatch table. | |
7844 | ||
7845 | or else (not Is_Interface (Tag_Typ) | |
f2cbd970 JM |
7846 | and then Is_Interface (Etype (Tag_Typ))) |
7847 | ||
7848 | -- Ada 205 (AI-251): We must also generate these subprograms if | |
7849 | -- the parent of an nonlimited interface is a limited interface | |
7850 | ||
7851 | or else (Is_Interface (Tag_Typ) | |
7852 | and then not Is_Limited_Interface (Tag_Typ) | |
7853 | and then Is_Limited_Interface (Etype (Tag_Typ))) | |
3476f949 | 7854 | then |
70482933 RK |
7855 | if not Is_Limited_Type (Tag_Typ) then |
7856 | Append_To (Res, | |
fbf5a39b | 7857 | Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust)); |
70482933 RK |
7858 | end if; |
7859 | ||
fbf5a39b | 7860 | Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize)); |
70482933 RK |
7861 | end if; |
7862 | ||
7863 | Predef_List := Res; | |
7864 | end Make_Predefined_Primitive_Specs; | |
7865 | ||
7866 | --------------------------------- | |
7867 | -- Needs_Simple_Initialization -- | |
7868 | --------------------------------- | |
7869 | ||
7870 | function Needs_Simple_Initialization (T : Entity_Id) return Boolean is | |
7871 | begin | |
47cc8d6b ES |
7872 | -- Check for private type, in which case test applies to the underlying |
7873 | -- type of the private type. | |
07fc65c4 GB |
7874 | |
7875 | if Is_Private_Type (T) then | |
7876 | declare | |
7877 | RT : constant Entity_Id := Underlying_Type (T); | |
7878 | ||
7879 | begin | |
7880 | if Present (RT) then | |
7881 | return Needs_Simple_Initialization (RT); | |
7882 | else | |
7883 | return False; | |
7884 | end if; | |
7885 | end; | |
7886 | ||
70482933 RK |
7887 | -- Cases needing simple initialization are access types, and, if pragma |
7888 | -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar | |
7889 | -- types. | |
7890 | ||
07fc65c4 | 7891 | elsif Is_Access_Type (T) |
70482933 | 7892 | or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T))) |
70482933 RK |
7893 | then |
7894 | return True; | |
7895 | ||
7896 | -- If Initialize/Normalize_Scalars is in effect, string objects also | |
7897 | -- need initialization, unless they are created in the course of | |
7898 | -- expanding an aggregate (since in the latter case they will be | |
7899 | -- filled with appropriate initializing values before they are used). | |
7900 | ||
7901 | elsif Init_Or_Norm_Scalars | |
7902 | and then | |
7903 | (Root_Type (T) = Standard_String | |
82c80734 RD |
7904 | or else Root_Type (T) = Standard_Wide_String |
7905 | or else Root_Type (T) = Standard_Wide_Wide_String) | |
70482933 RK |
7906 | and then |
7907 | (not Is_Itype (T) | |
7908 | or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate) | |
7909 | then | |
7910 | return True; | |
7911 | ||
70482933 RK |
7912 | else |
7913 | return False; | |
7914 | end if; | |
7915 | end Needs_Simple_Initialization; | |
7916 | ||
7917 | ---------------------- | |
7918 | -- Predef_Deep_Spec -- | |
7919 | ---------------------- | |
7920 | ||
7921 | function Predef_Deep_Spec | |
7922 | (Loc : Source_Ptr; | |
7923 | Tag_Typ : Entity_Id; | |
fbf5a39b | 7924 | Name : TSS_Name_Type; |
2e071734 | 7925 | For_Body : Boolean := False) return Node_Id |
70482933 RK |
7926 | is |
7927 | Prof : List_Id; | |
7928 | Type_B : Entity_Id; | |
7929 | ||
7930 | begin | |
fbf5a39b | 7931 | if Name = TSS_Deep_Finalize then |
70482933 RK |
7932 | Prof := New_List; |
7933 | Type_B := Standard_Boolean; | |
7934 | ||
7935 | else | |
7936 | Prof := New_List ( | |
7937 | Make_Parameter_Specification (Loc, | |
7938 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_L), | |
7939 | In_Present => True, | |
7940 | Out_Present => True, | |
7941 | Parameter_Type => | |
7942 | New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); | |
7943 | Type_B := Standard_Short_Short_Integer; | |
7944 | end if; | |
7945 | ||
7946 | Append_To (Prof, | |
7947 | Make_Parameter_Specification (Loc, | |
7948 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), | |
7949 | In_Present => True, | |
7950 | Out_Present => True, | |
7951 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))); | |
7952 | ||
7953 | Append_To (Prof, | |
7954 | Make_Parameter_Specification (Loc, | |
7955 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_B), | |
7956 | Parameter_Type => New_Reference_To (Type_B, Loc))); | |
7957 | ||
7958 | return Predef_Spec_Or_Body (Loc, | |
fbf5a39b | 7959 | Name => Make_TSS_Name (Tag_Typ, Name), |
70482933 RK |
7960 | Tag_Typ => Tag_Typ, |
7961 | Profile => Prof, | |
7962 | For_Body => For_Body); | |
fbf5a39b AC |
7963 | |
7964 | exception | |
7965 | when RE_Not_Available => | |
7966 | return Empty; | |
70482933 RK |
7967 | end Predef_Deep_Spec; |
7968 | ||
7969 | ------------------------- | |
7970 | -- Predef_Spec_Or_Body -- | |
7971 | ------------------------- | |
7972 | ||
7973 | function Predef_Spec_Or_Body | |
7974 | (Loc : Source_Ptr; | |
7975 | Tag_Typ : Entity_Id; | |
7976 | Name : Name_Id; | |
7977 | Profile : List_Id; | |
7978 | Ret_Type : Entity_Id := Empty; | |
2e071734 | 7979 | For_Body : Boolean := False) return Node_Id |
70482933 | 7980 | is |
fbf5a39b | 7981 | Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name); |
70482933 RK |
7982 | Spec : Node_Id; |
7983 | ||
7984 | begin | |
7985 | Set_Is_Public (Id, Is_Public (Tag_Typ)); | |
7986 | ||
47cc8d6b ES |
7987 | -- The internal flag is set to mark these declarations because they have |
7988 | -- specific properties. First, they are primitives even if they are not | |
7989 | -- defined in the type scope (the freezing point is not necessarily in | |
7990 | -- the same scope). Second, the predefined equality can be overridden by | |
7991 | -- a user-defined equality, no body will be generated in this case. | |
70482933 RK |
7992 | |
7993 | Set_Is_Internal (Id); | |
7994 | ||
7995 | if not Debug_Generated_Code then | |
7996 | Set_Debug_Info_Off (Id); | |
7997 | end if; | |
7998 | ||
7999 | if No (Ret_Type) then | |
8000 | Spec := | |
8001 | Make_Procedure_Specification (Loc, | |
8002 | Defining_Unit_Name => Id, | |
8003 | Parameter_Specifications => Profile); | |
8004 | else | |
8005 | Spec := | |
8006 | Make_Function_Specification (Loc, | |
8007 | Defining_Unit_Name => Id, | |
8008 | Parameter_Specifications => Profile, | |
10b93b2e | 8009 | Result_Definition => |
70482933 RK |
8010 | New_Reference_To (Ret_Type, Loc)); |
8011 | end if; | |
8012 | ||
4ce9a2d8 HK |
8013 | if Is_Interface (Tag_Typ) then |
8014 | return Make_Abstract_Subprogram_Declaration (Loc, Spec); | |
8015 | ||
47cc8d6b ES |
8016 | -- If body case, return empty subprogram body. Note that this is ill- |
8017 | -- formed, because there is not even a null statement, and certainly not | |
8018 | -- a return in the function case. The caller is expected to do surgery | |
8019 | -- on the body to add the appropriate stuff. | |
70482933 | 8020 | |
4ce9a2d8 | 8021 | elsif For_Body then |
70482933 RK |
8022 | return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty); |
8023 | ||
93188a0b GD |
8024 | -- For the case of an Input attribute predefined for an abstract type, |
8025 | -- generate an abstract specification. This will never be called, but we | |
8026 | -- need the slot allocated in the dispatching table so that attributes | |
47cc8d6b | 8027 | -- typ'Class'Input and typ'Class'Output will work properly. |
70482933 | 8028 | |
93188a0b | 8029 | elsif Is_TSS (Name, TSS_Stream_Input) |
ea1941af | 8030 | and then Is_Abstract_Type (Tag_Typ) |
70482933 RK |
8031 | then |
8032 | return Make_Abstract_Subprogram_Declaration (Loc, Spec); | |
8033 | ||
8034 | -- Normal spec case, where we return a subprogram declaration | |
8035 | ||
8036 | else | |
8037 | return Make_Subprogram_Declaration (Loc, Spec); | |
8038 | end if; | |
8039 | end Predef_Spec_Or_Body; | |
8040 | ||
8041 | ----------------------------- | |
8042 | -- Predef_Stream_Attr_Spec -- | |
8043 | ----------------------------- | |
8044 | ||
8045 | function Predef_Stream_Attr_Spec | |
8046 | (Loc : Source_Ptr; | |
8047 | Tag_Typ : Entity_Id; | |
fbf5a39b | 8048 | Name : TSS_Name_Type; |
2e071734 | 8049 | For_Body : Boolean := False) return Node_Id |
70482933 RK |
8050 | is |
8051 | Ret_Type : Entity_Id; | |
8052 | ||
8053 | begin | |
fbf5a39b | 8054 | if Name = TSS_Stream_Input then |
70482933 RK |
8055 | Ret_Type := Tag_Typ; |
8056 | else | |
8057 | Ret_Type := Empty; | |
8058 | end if; | |
8059 | ||
8060 | return Predef_Spec_Or_Body (Loc, | |
fbf5a39b | 8061 | Name => Make_TSS_Name (Tag_Typ, Name), |
70482933 RK |
8062 | Tag_Typ => Tag_Typ, |
8063 | Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name), | |
8064 | Ret_Type => Ret_Type, | |
8065 | For_Body => For_Body); | |
8066 | end Predef_Stream_Attr_Spec; | |
8067 | ||
8068 | --------------------------------- | |
8069 | -- Predefined_Primitive_Bodies -- | |
8070 | --------------------------------- | |
8071 | ||
8072 | function Predefined_Primitive_Bodies | |
8073 | (Tag_Typ : Entity_Id; | |
4ce9a2d8 | 8074 | Renamed_Eq : Entity_Id) return List_Id |
70482933 RK |
8075 | is |
8076 | Loc : constant Source_Ptr := Sloc (Tag_Typ); | |
fbf5a39b | 8077 | Res : constant List_Id := New_List; |
70482933 | 8078 | Decl : Node_Id; |
70482933 RK |
8079 | Prim : Elmt_Id; |
8080 | Eq_Needed : Boolean; | |
8081 | Eq_Name : Name_Id; | |
8082 | Ent : Entity_Id; | |
8083 | ||
ae7adb1b ES |
8084 | pragma Warnings (Off, Ent); |
8085 | ||
70482933 | 8086 | begin |
4ce9a2d8 HK |
8087 | pragma Assert (not Is_Interface (Tag_Typ)); |
8088 | ||
70482933 RK |
8089 | -- See if we have a predefined "=" operator |
8090 | ||
8091 | if Present (Renamed_Eq) then | |
8092 | Eq_Needed := True; | |
8093 | Eq_Name := Chars (Renamed_Eq); | |
8094 | ||
4ce9a2d8 HK |
8095 | -- If the parent is an interface type then it has defined all the |
8096 | -- predefined primitives abstract and we need to check if the type | |
8097 | -- has some user defined "=" function to avoid generating it. | |
8098 | ||
8099 | elsif Is_Interface (Etype (Tag_Typ)) then | |
8100 | Eq_Needed := True; | |
8101 | Eq_Name := Name_Op_Eq; | |
8102 | ||
8103 | Prim := First_Elmt (Primitive_Operations (Tag_Typ)); | |
8104 | while Present (Prim) loop | |
8105 | if Chars (Node (Prim)) = Name_Op_Eq | |
8106 | and then not Is_Internal (Node (Prim)) | |
8107 | then | |
8108 | Eq_Needed := False; | |
8109 | Eq_Name := No_Name; | |
8110 | exit; | |
8111 | end if; | |
8112 | ||
8113 | Next_Elmt (Prim); | |
8114 | end loop; | |
8115 | ||
70482933 RK |
8116 | else |
8117 | Eq_Needed := False; | |
8118 | Eq_Name := No_Name; | |
8119 | ||
8120 | Prim := First_Elmt (Primitive_Operations (Tag_Typ)); | |
8121 | while Present (Prim) loop | |
8122 | if Chars (Node (Prim)) = Name_Op_Eq | |
8123 | and then Is_Internal (Node (Prim)) | |
8124 | then | |
8125 | Eq_Needed := True; | |
8126 | Eq_Name := Name_Op_Eq; | |
4ce9a2d8 | 8127 | exit; |
70482933 RK |
8128 | end if; |
8129 | ||
8130 | Next_Elmt (Prim); | |
8131 | end loop; | |
8132 | end if; | |
8133 | ||
fbf5a39b AC |
8134 | -- Body of _Alignment |
8135 | ||
8136 | Decl := Predef_Spec_Or_Body (Loc, | |
8137 | Tag_Typ => Tag_Typ, | |
8138 | Name => Name_uAlignment, | |
8139 | Profile => New_List ( | |
8140 | Make_Parameter_Specification (Loc, | |
8141 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
8142 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))), | |
8143 | ||
8144 | Ret_Type => Standard_Integer, | |
8145 | For_Body => True); | |
8146 | ||
8147 | Set_Handled_Statement_Sequence (Decl, | |
8148 | Make_Handled_Sequence_Of_Statements (Loc, New_List ( | |
04df6250 | 8149 | Make_Simple_Return_Statement (Loc, |
fbf5a39b AC |
8150 | Expression => |
8151 | Make_Attribute_Reference (Loc, | |
8152 | Prefix => Make_Identifier (Loc, Name_X), | |
8153 | Attribute_Name => Name_Alignment))))); | |
8154 | ||
8155 | Append_To (Res, Decl); | |
8156 | ||
70482933 RK |
8157 | -- Body of _Size |
8158 | ||
8159 | Decl := Predef_Spec_Or_Body (Loc, | |
8160 | Tag_Typ => Tag_Typ, | |
8161 | Name => Name_uSize, | |
8162 | Profile => New_List ( | |
8163 | Make_Parameter_Specification (Loc, | |
8164 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
8165 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))), | |
8166 | ||
8167 | Ret_Type => Standard_Long_Long_Integer, | |
8168 | For_Body => True); | |
8169 | ||
8170 | Set_Handled_Statement_Sequence (Decl, | |
8171 | Make_Handled_Sequence_Of_Statements (Loc, New_List ( | |
04df6250 | 8172 | Make_Simple_Return_Statement (Loc, |
70482933 RK |
8173 | Expression => |
8174 | Make_Attribute_Reference (Loc, | |
8175 | Prefix => Make_Identifier (Loc, Name_X), | |
8176 | Attribute_Name => Name_Size))))); | |
8177 | ||
8178 | Append_To (Res, Decl); | |
8179 | ||
8180 | -- Bodies for Dispatching stream IO routines. We need these only for | |
8181 | -- non-limited types (in the limited case there is no dispatching). | |
a778d033 | 8182 | -- We also skip them if dispatching or finalization are not available. |
70482933 | 8183 | |
d2d3604c TQ |
8184 | if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read) |
8185 | and then No (TSS (Tag_Typ, TSS_Stream_Read)) | |
8186 | then | |
8187 | Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent); | |
8188 | Append_To (Res, Decl); | |
8189 | end if; | |
70482933 | 8190 | |
d2d3604c TQ |
8191 | if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write) |
8192 | and then No (TSS (Tag_Typ, TSS_Stream_Write)) | |
8193 | then | |
8194 | Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent); | |
8195 | Append_To (Res, Decl); | |
8196 | end if; | |
70482933 | 8197 | |
93188a0b GD |
8198 | -- Skip body of _Input for the abstract case, since the corresponding |
8199 | -- spec is abstract (see Predef_Spec_Or_Body). | |
70482933 | 8200 | |
93188a0b GD |
8201 | if not Is_Abstract_Type (Tag_Typ) |
8202 | and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input) | |
8203 | and then No (TSS (Tag_Typ, TSS_Stream_Input)) | |
8204 | then | |
8205 | Build_Record_Or_Elementary_Input_Function | |
8206 | (Loc, Tag_Typ, Decl, Ent); | |
8207 | Append_To (Res, Decl); | |
8208 | end if; | |
70482933 | 8209 | |
93188a0b GD |
8210 | if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output) |
8211 | and then No (TSS (Tag_Typ, TSS_Stream_Output)) | |
8212 | then | |
8213 | Build_Record_Or_Elementary_Output_Procedure | |
8214 | (Loc, Tag_Typ, Decl, Ent); | |
8215 | Append_To (Res, Decl); | |
70482933 RK |
8216 | end if; |
8217 | ||
47cc8d6b ES |
8218 | -- Ada 2005: Generate bodies for the following primitive operations for |
8219 | -- limited interfaces and synchronized types that implement a limited | |
8220 | -- interface. | |
f4d379b8 | 8221 | |
10b93b2e HK |
8222 | -- disp_asynchronous_select |
8223 | -- disp_conditional_select | |
8224 | -- disp_get_prim_op_kind | |
f4d379b8 | 8225 | -- disp_get_task_id |
10b93b2e | 8226 | -- disp_timed_select |
f4d379b8 | 8227 | |
47cc8d6b ES |
8228 | -- The interface versions will have null bodies |
8229 | ||
8230 | -- These operations cannot be implemented on VM targets, so we simply | |
8231 | -- disable their generation in this case. We also disable generation | |
8232 | -- of these bodies if No_Dispatching_Calls is active. | |
10b93b2e HK |
8233 | |
8234 | if Ada_Version >= Ada_05 | |
47cc8d6b ES |
8235 | and then VM_Target = No_VM |
8236 | and then not Restriction_Active (No_Dispatching_Calls) | |
4ce9a2d8 | 8237 | and then not Is_Interface (Tag_Typ) |
f4d379b8 | 8238 | and then |
4ce9a2d8 HK |
8239 | ((Is_Interface (Etype (Tag_Typ)) |
8240 | and then Is_Limited_Record (Etype (Tag_Typ))) | |
8241 | or else (Is_Concurrent_Record_Type (Tag_Typ) | |
ce2b6ba5 | 8242 | and then Has_Interfaces (Tag_Typ))) |
f2cbd970 | 8243 | and then RTE_Available (RE_Select_Specific_Data) |
10b93b2e | 8244 | then |
f4d379b8 HK |
8245 | Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); |
8246 | Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); | |
8247 | Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ)); | |
8248 | Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ)); | |
4ce9a2d8 | 8249 | Append_To (Res, Make_Disp_Requeue_Body (Tag_Typ)); |
f4d379b8 | 8250 | Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ)); |
10b93b2e HK |
8251 | end if; |
8252 | ||
4ce9a2d8 HK |
8253 | if not Is_Limited_Type (Tag_Typ) |
8254 | and then not Is_Interface (Tag_Typ) | |
8255 | then | |
70482933 RK |
8256 | -- Body for equality |
8257 | ||
8258 | if Eq_Needed then | |
f4d379b8 HK |
8259 | Decl := |
8260 | Predef_Spec_Or_Body (Loc, | |
8261 | Tag_Typ => Tag_Typ, | |
8262 | Name => Eq_Name, | |
8263 | Profile => New_List ( | |
8264 | Make_Parameter_Specification (Loc, | |
8265 | Defining_Identifier => | |
8266 | Make_Defining_Identifier (Loc, Name_X), | |
8267 | Parameter_Type => New_Reference_To (Tag_Typ, Loc)), | |
70482933 | 8268 | |
f4d379b8 HK |
8269 | Make_Parameter_Specification (Loc, |
8270 | Defining_Identifier => | |
8271 | Make_Defining_Identifier (Loc, Name_Y), | |
8272 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))), | |
70482933 | 8273 | |
f4d379b8 HK |
8274 | Ret_Type => Standard_Boolean, |
8275 | For_Body => True); | |
70482933 RK |
8276 | |
8277 | declare | |
8278 | Def : constant Node_Id := Parent (Tag_Typ); | |
fbf5a39b | 8279 | Stmts : constant List_Id := New_List; |
70482933 RK |
8280 | Variant_Case : Boolean := Has_Discriminants (Tag_Typ); |
8281 | Comps : Node_Id := Empty; | |
8282 | Typ_Def : Node_Id := Type_Definition (Def); | |
70482933 RK |
8283 | |
8284 | begin | |
8285 | if Variant_Case then | |
8286 | if Nkind (Typ_Def) = N_Derived_Type_Definition then | |
8287 | Typ_Def := Record_Extension_Part (Typ_Def); | |
8288 | end if; | |
8289 | ||
8290 | if Present (Typ_Def) then | |
8291 | Comps := Component_List (Typ_Def); | |
8292 | end if; | |
8293 | ||
8294 | Variant_Case := Present (Comps) | |
8295 | and then Present (Variant_Part (Comps)); | |
8296 | end if; | |
8297 | ||
8298 | if Variant_Case then | |
8299 | Append_To (Stmts, | |
8300 | Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def))); | |
8301 | Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps)); | |
8302 | Append_To (Stmts, | |
04df6250 | 8303 | Make_Simple_Return_Statement (Loc, |
70482933 RK |
8304 | Expression => New_Reference_To (Standard_True, Loc))); |
8305 | ||
8306 | else | |
8307 | Append_To (Stmts, | |
04df6250 | 8308 | Make_Simple_Return_Statement (Loc, |
70482933 RK |
8309 | Expression => |
8310 | Expand_Record_Equality (Tag_Typ, | |
8311 | Typ => Tag_Typ, | |
8312 | Lhs => Make_Identifier (Loc, Name_X), | |
8313 | Rhs => Make_Identifier (Loc, Name_Y), | |
8314 | Bodies => Declarations (Decl)))); | |
8315 | end if; | |
8316 | ||
8317 | Set_Handled_Statement_Sequence (Decl, | |
8318 | Make_Handled_Sequence_Of_Statements (Loc, Stmts)); | |
8319 | end; | |
8320 | Append_To (Res, Decl); | |
8321 | end if; | |
8322 | ||
8323 | -- Body for dispatching assignment | |
8324 | ||
f4d379b8 HK |
8325 | Decl := |
8326 | Predef_Spec_Or_Body (Loc, | |
8327 | Tag_Typ => Tag_Typ, | |
8328 | Name => Name_uAssign, | |
8329 | Profile => New_List ( | |
8330 | Make_Parameter_Specification (Loc, | |
8331 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
8332 | Out_Present => True, | |
8333 | Parameter_Type => New_Reference_To (Tag_Typ, Loc)), | |
8334 | ||
8335 | Make_Parameter_Specification (Loc, | |
8336 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), | |
8337 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))), | |
8338 | For_Body => True); | |
70482933 RK |
8339 | |
8340 | Set_Handled_Statement_Sequence (Decl, | |
8341 | Make_Handled_Sequence_Of_Statements (Loc, New_List ( | |
8342 | Make_Assignment_Statement (Loc, | |
8343 | Name => Make_Identifier (Loc, Name_X), | |
8344 | Expression => Make_Identifier (Loc, Name_Y))))); | |
8345 | ||
8346 | Append_To (Res, Decl); | |
8347 | end if; | |
8348 | ||
8349 | -- Generate dummy bodies for finalization actions of types that have | |
8350 | -- no controlled components. | |
8351 | ||
8352 | -- Skip this processing if we are in the finalization routine in the | |
8353 | -- runtime itself, otherwise we get hopelessly circularly confused! | |
8354 | ||
8355 | if In_Finalization_Root (Tag_Typ) then | |
8356 | null; | |
8357 | ||
fbf5a39b | 8358 | -- Skip this if finalization is not available |
70482933 | 8359 | |
6e937c1c | 8360 | elsif Restriction_Active (No_Finalization) then |
70482933 RK |
8361 | null; |
8362 | ||
3476f949 JM |
8363 | elsif (Etype (Tag_Typ) = Tag_Typ |
8364 | or else Is_Controlled (Tag_Typ) | |
8365 | ||
8366 | -- Ada 2005 (AI-251): We must also generate these subprograms | |
8367 | -- if the immediate ancestor of Tag_Typ is an interface to | |
8368 | -- ensure the correct initialization of its dispatch table. | |
8369 | ||
8370 | or else (not Is_Interface (Tag_Typ) | |
8371 | and then | |
8372 | Is_Interface (Etype (Tag_Typ)))) | |
70482933 RK |
8373 | and then not Has_Controlled_Component (Tag_Typ) |
8374 | then | |
8375 | if not Is_Limited_Type (Tag_Typ) then | |
fbf5a39b | 8376 | Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True); |
70482933 RK |
8377 | |
8378 | if Is_Controlled (Tag_Typ) then | |
8379 | Set_Handled_Statement_Sequence (Decl, | |
8380 | Make_Handled_Sequence_Of_Statements (Loc, | |
8381 | Make_Adjust_Call ( | |
8382 | Ref => Make_Identifier (Loc, Name_V), | |
8383 | Typ => Tag_Typ, | |
8384 | Flist_Ref => Make_Identifier (Loc, Name_L), | |
8385 | With_Attach => Make_Identifier (Loc, Name_B)))); | |
8386 | ||
8387 | else | |
8388 | Set_Handled_Statement_Sequence (Decl, | |
8389 | Make_Handled_Sequence_Of_Statements (Loc, New_List ( | |
8390 | Make_Null_Statement (Loc)))); | |
8391 | end if; | |
8392 | ||
8393 | Append_To (Res, Decl); | |
8394 | end if; | |
8395 | ||
fbf5a39b | 8396 | Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True); |
70482933 RK |
8397 | |
8398 | if Is_Controlled (Tag_Typ) then | |
8399 | Set_Handled_Statement_Sequence (Decl, | |
8400 | Make_Handled_Sequence_Of_Statements (Loc, | |
8401 | Make_Final_Call ( | |
8402 | Ref => Make_Identifier (Loc, Name_V), | |
8403 | Typ => Tag_Typ, | |
8404 | With_Detach => Make_Identifier (Loc, Name_B)))); | |
8405 | ||
8406 | else | |
8407 | Set_Handled_Statement_Sequence (Decl, | |
8408 | Make_Handled_Sequence_Of_Statements (Loc, New_List ( | |
8409 | Make_Null_Statement (Loc)))); | |
8410 | end if; | |
8411 | ||
8412 | Append_To (Res, Decl); | |
8413 | end if; | |
8414 | ||
8415 | return Res; | |
8416 | end Predefined_Primitive_Bodies; | |
8417 | ||
8418 | --------------------------------- | |
8419 | -- Predefined_Primitive_Freeze -- | |
8420 | --------------------------------- | |
8421 | ||
8422 | function Predefined_Primitive_Freeze | |
fbf5a39b | 8423 | (Tag_Typ : Entity_Id) return List_Id |
70482933 RK |
8424 | is |
8425 | Loc : constant Source_Ptr := Sloc (Tag_Typ); | |
fbf5a39b | 8426 | Res : constant List_Id := New_List; |
70482933 RK |
8427 | Prim : Elmt_Id; |
8428 | Frnodes : List_Id; | |
8429 | ||
8430 | begin | |
8431 | Prim := First_Elmt (Primitive_Operations (Tag_Typ)); | |
8432 | while Present (Prim) loop | |
47cc8d6b | 8433 | if Is_Predefined_Dispatching_Operation (Node (Prim)) then |
70482933 RK |
8434 | Frnodes := Freeze_Entity (Node (Prim), Loc); |
8435 | ||
8436 | if Present (Frnodes) then | |
8437 | Append_List_To (Res, Frnodes); | |
8438 | end if; | |
8439 | end if; | |
8440 | ||
8441 | Next_Elmt (Prim); | |
8442 | end loop; | |
8443 | ||
8444 | return Res; | |
8445 | end Predefined_Primitive_Freeze; | |
a778d033 | 8446 | |
d2d3604c TQ |
8447 | ------------------------- |
8448 | -- Stream_Operation_OK -- | |
8449 | ------------------------- | |
8450 | ||
8451 | function Stream_Operation_OK | |
8452 | (Typ : Entity_Id; | |
8453 | Operation : TSS_Name_Type) return Boolean | |
8454 | is | |
19590d70 | 8455 | Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False; |
a778d033 | 8456 | |
a778d033 | 8457 | begin |
19590d70 GD |
8458 | -- Special case of a limited type extension: a default implementation |
8459 | -- of the stream attributes Read or Write exists if that attribute | |
8460 | -- has been specified or is available for an ancestor type; a default | |
8461 | -- implementation of the attribute Output (resp. Input) exists if the | |
8462 | -- attribute has been specified or Write (resp. Read) is available for | |
8463 | -- an ancestor type. The last condition only applies under Ada 2005. | |
8464 | ||
d2d3604c TQ |
8465 | if Is_Limited_Type (Typ) |
8466 | and then Is_Tagged_Type (Typ) | |
d2d3604c | 8467 | then |
19590d70 GD |
8468 | if Operation = TSS_Stream_Read then |
8469 | Has_Predefined_Or_Specified_Stream_Attribute := | |
8470 | Has_Specified_Stream_Read (Typ); | |
8471 | ||
8472 | elsif Operation = TSS_Stream_Write then | |
8473 | Has_Predefined_Or_Specified_Stream_Attribute := | |
8474 | Has_Specified_Stream_Write (Typ); | |
8475 | ||
8476 | elsif Operation = TSS_Stream_Input then | |
8477 | Has_Predefined_Or_Specified_Stream_Attribute := | |
8478 | Has_Specified_Stream_Input (Typ) | |
8479 | or else | |
8480 | (Ada_Version >= Ada_05 | |
8481 | and then Stream_Operation_OK (Typ, TSS_Stream_Read)); | |
8482 | ||
8483 | elsif Operation = TSS_Stream_Output then | |
8484 | Has_Predefined_Or_Specified_Stream_Attribute := | |
8485 | Has_Specified_Stream_Output (Typ) | |
8486 | or else | |
8487 | (Ada_Version >= Ada_05 | |
8488 | and then Stream_Operation_OK (Typ, TSS_Stream_Write)); | |
8489 | end if; | |
8490 | ||
8491 | -- Case of inherited TSS_Stream_Read or TSS_Stream_Write | |
d2d3604c | 8492 | |
19590d70 GD |
8493 | if not Has_Predefined_Or_Specified_Stream_Attribute |
8494 | and then Is_Derived_Type (Typ) | |
8495 | and then (Operation = TSS_Stream_Read | |
8496 | or else Operation = TSS_Stream_Write) | |
8497 | then | |
8498 | Has_Predefined_Or_Specified_Stream_Attribute := | |
8499 | Present | |
8500 | (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation)); | |
8501 | end if; | |
d2d3604c TQ |
8502 | end if; |
8503 | ||
93188a0b GD |
8504 | -- If the type is not limited, or else is limited but the attribute is |
8505 | -- explicitly specified or is predefined for the type, then return True, | |
8506 | -- unless other conditions prevail, such as restrictions prohibiting | |
8507 | -- streams or dispatching operations. | |
8508 | ||
8509 | -- We exclude the Input operation from being a predefined subprogram in | |
8510 | -- the case where the associated type is an abstract extension, because | |
8511 | -- the attribute is not callable in that case, per 13.13.2(49/2). Also, | |
8512 | -- we don't want an abstract version created because types derived from | |
8513 | -- the abstract type may not even have Input available (for example if | |
8514 | -- derived from a private view of the abstract type that doesn't have | |
8515 | -- a visible Input), but a VM such as .NET or the Java VM can treat the | |
8516 | -- operation as inherited anyway, and we don't want an abstract function | |
8517 | -- to be (implicitly) inherited in that case because it can lead to a VM | |
8518 | -- exception. | |
8519 | ||
19590d70 GD |
8520 | return (not Is_Limited_Type (Typ) |
8521 | or else Has_Predefined_Or_Specified_Stream_Attribute) | |
93188a0b GD |
8522 | and then (Operation /= TSS_Stream_Input |
8523 | or else not Is_Abstract_Type (Typ) | |
8524 | or else not Is_Derived_Type (Typ)) | |
19590d70 GD |
8525 | and then not Has_Unknown_Discriminants (Typ) |
8526 | and then not (Is_Interface (Typ) | |
8527 | and then (Is_Task_Interface (Typ) | |
8528 | or else Is_Protected_Interface (Typ) | |
8529 | or else Is_Synchronized_Interface (Typ))) | |
8530 | and then not Restriction_Active (No_Streams) | |
8531 | and then not Restriction_Active (No_Dispatch) | |
8532 | and then not No_Run_Time_Mode | |
8533 | and then RTE_Available (RE_Tag) | |
8534 | and then RTE_Available (RE_Root_Stream_Type); | |
d2d3604c | 8535 | end Stream_Operation_OK; |
19590d70 | 8536 | |
70482933 | 8537 | end Exp_Ch3; |