]>
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 | -- -- | |
82c80734 | 9 | -- Copyright (C) 1992-2005 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- -- | |
13 | -- ware Foundation; either version 2, or (at your option) any later ver- -- | |
14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
17 | -- for more details. You should have received a copy of the GNU General -- | |
18 | -- Public License distributed with GNAT; see file COPYING. If not, write -- | |
19 | -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- | |
20 | -- MA 02111-1307, USA. -- | |
21 | -- -- | |
22 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 23 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
24 | -- -- |
25 | ------------------------------------------------------------------------------ | |
26 | ||
27 | with Atree; use Atree; | |
28 | with Checks; use Checks; | |
29 | with Einfo; use Einfo; | |
30 | with Elists; use Elists; | |
07fc65c4 | 31 | with Errout; use Errout; |
70482933 RK |
32 | with Exp_Aggr; use Exp_Aggr; |
33 | with Exp_Ch4; use Exp_Ch4; | |
34 | with Exp_Ch7; use Exp_Ch7; | |
35 | with Exp_Ch9; use Exp_Ch9; | |
36 | with Exp_Ch11; use Exp_Ch11; | |
37 | with Exp_Disp; use Exp_Disp; | |
38 | with Exp_Dist; use Exp_Dist; | |
39 | with Exp_Smem; use Exp_Smem; | |
40 | with Exp_Strm; use Exp_Strm; | |
41 | with Exp_Tss; use Exp_Tss; | |
42 | with Exp_Util; use Exp_Util; | |
43 | with Freeze; use Freeze; | |
44 | with Hostparm; use Hostparm; | |
45 | with Nlists; use Nlists; | |
46 | with Nmake; use Nmake; | |
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; | |
52 | with Sem_Ch3; use Sem_Ch3; | |
53 | with Sem_Ch8; use Sem_Ch8; | |
54 | with Sem_Eval; use Sem_Eval; | |
55 | with Sem_Mech; use Sem_Mech; | |
56 | with Sem_Res; use Sem_Res; | |
57 | with Sem_Util; use Sem_Util; | |
58 | with Sinfo; use Sinfo; | |
59 | with Stand; use Stand; | |
60 | with Snames; use Snames; | |
61 | with Tbuild; use Tbuild; | |
62 | with Ttypes; use Ttypes; | |
70482933 RK |
63 | with Validsw; use Validsw; |
64 | ||
65 | package body Exp_Ch3 is | |
66 | ||
67 | ----------------------- | |
68 | -- Local Subprograms -- | |
69 | ----------------------- | |
70 | ||
71 | procedure Adjust_Discriminants (Rtype : Entity_Id); | |
72 | -- This is used when freezing a record type. It attempts to construct | |
73 | -- more restrictive subtypes for discriminants so that the max size of | |
74 | -- the record can be calculated more accurately. See the body of this | |
75 | -- procedure for details. | |
76 | ||
77 | procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id); | |
78 | -- Build initialization procedure for given array type. Nod is a node | |
79 | -- used for attachment of any actions required in its construction. | |
80 | -- It also supplies the source location used for the procedure. | |
81 | ||
82 | procedure Build_Class_Wide_Master (T : Entity_Id); | |
83 | -- for access to class-wide limited types we must build a task master | |
84 | -- because some subsequent extension may add a task component. To avoid | |
85 | -- bringing in the tasking run-time whenever an access-to-class-wide | |
86 | -- limited type is used, we use the soft-link mechanism and add a level | |
87 | -- of indirection to calls to routines that manipulate Master_Ids. | |
88 | ||
89 | function Build_Discriminant_Formals | |
90 | (Rec_Id : Entity_Id; | |
2e071734 | 91 | Use_Dl : Boolean) return List_Id; |
70482933 RK |
92 | -- This function uses the discriminants of a type to build a list of |
93 | -- formal parameters, used in the following function. If the flag Use_Dl | |
94 | -- is set, the list is built using the already defined discriminals | |
95 | -- of the type. Otherwise new identifiers are created, with the source | |
96 | -- names of the discriminants. | |
97 | ||
98 | procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id); | |
99 | -- If the designated type of an access type is a task type or contains | |
100 | -- tasks, we make sure that a _Master variable is declared in the current | |
101 | -- scope, and then declare a renaming for it: | |
102 | -- | |
103 | -- atypeM : Master_Id renames _Master; | |
104 | -- | |
105 | -- where atyp is the name of the access type. This declaration is | |
106 | -- used when an allocator for the access type is expanded. The node N | |
107 | -- is the full declaration of the designated type that contains tasks. | |
108 | -- The renaming declaration is inserted before N, and after the Master | |
109 | -- declaration. | |
110 | ||
111 | procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id); | |
112 | -- Build record initialization procedure. N is the type declaration | |
113 | -- node, and Pe is the corresponding entity for the record type. | |
114 | ||
26fd4eae AC |
115 | procedure Build_Slice_Assignment (Typ : Entity_Id); |
116 | -- Build assignment procedure for one-dimensional arrays of controlled | |
117 | -- types. Other array and slice assignments are expanded in-line, but | |
118 | -- the code expansion for controlled components (when control actions | |
119 | -- are active) can lead to very large blocks that GCC3 handles poorly. | |
120 | ||
70482933 RK |
121 | procedure Build_Variant_Record_Equality (Typ : Entity_Id); |
122 | -- Create An Equality function for the non-tagged variant record 'Typ' | |
123 | -- and attach it to the TSS list | |
124 | ||
07fc65c4 GB |
125 | procedure Check_Stream_Attributes (Typ : Entity_Id); |
126 | -- Check that if a limited extension has a parent with user-defined | |
127 | -- stream attributes, any limited component of the extension also has | |
128 | -- the corresponding user-defined stream attributes. | |
129 | ||
70482933 RK |
130 | procedure Expand_Tagged_Root (T : Entity_Id); |
131 | -- Add a field _Tag at the beginning of the record. This field carries | |
132 | -- the value of the access to the Dispatch table. This procedure is only | |
133 | -- called on root (non CPP_Class) types, the _Tag field being inherited | |
134 | -- by the descendants. | |
135 | ||
136 | procedure Expand_Record_Controller (T : Entity_Id); | |
fbf5a39b AC |
137 | -- T must be a record type that Has_Controlled_Component. Add a field |
138 | -- _controller of type Record_Controller or Limited_Record_Controller | |
139 | -- in the record T. | |
70482933 RK |
140 | |
141 | procedure Freeze_Array_Type (N : Node_Id); | |
142 | -- Freeze an array type. Deals with building the initialization procedure, | |
143 | -- creating the packed array type for a packed array and also with the | |
144 | -- creation of the controlling procedures for the controlled case. The | |
145 | -- argument N is the N_Freeze_Entity node for the type. | |
146 | ||
147 | procedure Freeze_Enumeration_Type (N : Node_Id); | |
148 | -- Freeze enumeration type with non-standard representation. Builds the | |
149 | -- array and function needed to convert between enumeration pos and | |
150 | -- enumeration representation values. N is the N_Freeze_Entity node | |
151 | -- for the type. | |
152 | ||
153 | procedure Freeze_Record_Type (N : Node_Id); | |
154 | -- Freeze record type. Builds all necessary discriminant checking | |
155 | -- and other ancillary functions, and builds dispatch tables where | |
156 | -- needed. The argument N is the N_Freeze_Entity node. This processing | |
157 | -- applies only to E_Record_Type entities, not to class wide types, | |
158 | -- record subtypes, or private types. | |
159 | ||
07fc65c4 GB |
160 | procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id); |
161 | -- Treat user-defined stream operations as renaming_as_body if the | |
162 | -- subprogram they rename is not frozen when the type is frozen. | |
163 | ||
70482933 RK |
164 | function Init_Formals (Typ : Entity_Id) return List_Id; |
165 | -- This function builds the list of formals for an initialization routine. | |
166 | -- The first formal is always _Init with the given type. For task value | |
167 | -- record types and types containing tasks, three additional formals are | |
168 | -- added: | |
169 | -- | |
fbf5a39b AC |
170 | -- _Master : Master_Id |
171 | -- _Chain : in out Activation_Chain | |
172 | -- _Task_Name : String | |
70482933 RK |
173 | -- |
174 | -- The caller must append additional entries for discriminants if required. | |
175 | ||
176 | function In_Runtime (E : Entity_Id) return Boolean; | |
177 | -- Check if E is defined in the RTL (in a child of Ada or System). Used | |
178 | -- to avoid to bring in the overhead of _Input, _Output for tagged types. | |
179 | ||
5d09245e AC |
180 | function Make_Eq_Case |
181 | (E : Entity_Id; | |
182 | CL : Node_Id; | |
183 | Discr : Entity_Id := Empty) return List_Id; | |
70482933 RK |
184 | -- Building block for variant record equality. Defined to share the |
185 | -- code between the tagged and non-tagged case. Given a Component_List | |
186 | -- node CL, it generates an 'if' followed by a 'case' statement that | |
187 | -- compares all components of local temporaries named X and Y (that | |
5d09245e AC |
188 | -- are declared as formals at some upper level). E provides the Sloc to be |
189 | -- used for the generated code. Discr is used as the case statement switch | |
190 | -- in the case of Unchecked_Union equality. | |
70482933 | 191 | |
5d09245e AC |
192 | function Make_Eq_If |
193 | (E : Entity_Id; | |
194 | L : List_Id) return Node_Id; | |
70482933 RK |
195 | -- Building block for variant record equality. Defined to share the |
196 | -- code between the tagged and non-tagged case. Given the list of | |
197 | -- components (or discriminants) L, it generates a return statement | |
198 | -- that compares all components of local temporaries named X and Y | |
5d09245e AC |
199 | -- (that are declared as formals at some upper level). E provides the Sloc |
200 | -- to be used for the generated code. | |
70482933 RK |
201 | |
202 | procedure Make_Predefined_Primitive_Specs | |
203 | (Tag_Typ : Entity_Id; | |
204 | Predef_List : out List_Id; | |
205 | Renamed_Eq : out Node_Id); | |
206 | -- Create a list with the specs of the predefined primitive operations. | |
fbf5a39b AC |
207 | -- The following entries are present for all tagged types, and provide |
208 | -- the results of the corresponding attribute applied to the object. | |
209 | -- Dispatching is required in general, since the result of the attribute | |
210 | -- will vary with the actual object subtype. | |
211 | -- | |
212 | -- _alignment provides result of 'Alignment attribute | |
213 | -- _size provides result of 'Size attribute | |
214 | -- typSR provides result of 'Read attribute | |
215 | -- typSW provides result of 'Write attribute | |
216 | -- typSI provides result of 'Input attribute | |
217 | -- typSO provides result of 'Output attribute | |
218 | -- | |
219 | -- The following entries are additionally present for non-limited | |
220 | -- tagged types, and implement additional dispatching operations | |
221 | -- for predefined operations: | |
222 | -- | |
223 | -- _equality implements "=" operator | |
224 | -- _assign implements assignment operation | |
225 | -- typDF implements deep finalization | |
226 | -- typDA implements deep adust | |
227 | -- | |
228 | -- The latter two are empty procedures unless the type contains some | |
229 | -- controlled components that require finalization actions (the deep | |
230 | -- in the name refers to the fact that the action applies to components). | |
231 | -- | |
232 | -- The list is returned in Predef_List. The Parameter Renamed_Eq | |
233 | -- either returns the value Empty, or else the defining unit name | |
234 | -- for the predefined equality function in the case where the type | |
235 | -- has a primitive operation that is a renaming of predefined equality | |
236 | -- (but only if there is also an overriding user-defined equality | |
237 | -- function). The returned Renamed_Eq will be passed to the | |
238 | -- corresponding parameter of Predefined_Primitive_Bodies. | |
70482933 RK |
239 | |
240 | function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean; | |
241 | -- returns True if there are representation clauses for type T that | |
242 | -- are not inherited. If the result is false, the init_proc and the | |
243 | -- discriminant_checking functions of the parent can be reused by | |
244 | -- a derived type. | |
245 | ||
246 | function Predef_Spec_Or_Body | |
247 | (Loc : Source_Ptr; | |
248 | Tag_Typ : Entity_Id; | |
249 | Name : Name_Id; | |
250 | Profile : List_Id; | |
251 | Ret_Type : Entity_Id := Empty; | |
2e071734 | 252 | For_Body : Boolean := False) return Node_Id; |
70482933 RK |
253 | -- This function generates the appropriate expansion for a predefined |
254 | -- primitive operation specified by its name, parameter profile and | |
255 | -- return type (Empty means this is a procedure). If For_Body is false, | |
256 | -- then the returned node is a subprogram declaration. If For_Body is | |
257 | -- true, then the returned node is a empty subprogram body containing | |
258 | -- no declarations and no statements. | |
259 | ||
260 | function Predef_Stream_Attr_Spec | |
261 | (Loc : Source_Ptr; | |
262 | Tag_Typ : Entity_Id; | |
fbf5a39b | 263 | Name : TSS_Name_Type; |
2e071734 | 264 | For_Body : Boolean := False) return Node_Id; |
fbf5a39b AC |
265 | -- Specialized version of Predef_Spec_Or_Body that apply to read, write, |
266 | -- input and output attribute whose specs are constructed in Exp_Strm. | |
70482933 RK |
267 | |
268 | function Predef_Deep_Spec | |
269 | (Loc : Source_Ptr; | |
270 | Tag_Typ : Entity_Id; | |
fbf5a39b | 271 | Name : TSS_Name_Type; |
2e071734 | 272 | For_Body : Boolean := False) return Node_Id; |
70482933 RK |
273 | -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust |
274 | -- and _deep_finalize | |
275 | ||
276 | function Predefined_Primitive_Bodies | |
277 | (Tag_Typ : Entity_Id; | |
2e071734 | 278 | Renamed_Eq : Node_Id) return List_Id; |
70482933 RK |
279 | -- Create the bodies of the predefined primitives that are described in |
280 | -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote | |
281 | -- the defining unit name of the type's predefined equality as returned | |
282 | -- by Make_Predefined_Primitive_Specs. | |
283 | ||
284 | function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id; | |
285 | -- Freeze entities of all predefined primitive operations. This is needed | |
286 | -- because the bodies of these operations do not normally do any freezeing. | |
287 | ||
d2d3604c TQ |
288 | function Stream_Operation_OK |
289 | (Typ : Entity_Id; | |
290 | Operation : TSS_Name_Type) return Boolean; | |
291 | -- Check whether the named stream operation must be emitted for a given | |
292 | -- type. The rules for inheritance of stream attributes by type extensions | |
293 | -- are enforced by this function. Furthermore, various restrictions prevent | |
294 | -- the generation of these operations, as a useful optimization or for | |
295 | -- certification purposes. | |
a778d033 | 296 | |
70482933 RK |
297 | -------------------------- |
298 | -- Adjust_Discriminants -- | |
299 | -------------------------- | |
300 | ||
301 | -- This procedure attempts to define subtypes for discriminants that | |
302 | -- are more restrictive than those declared. Such a replacement is | |
303 | -- possible if we can demonstrate that values outside the restricted | |
304 | -- range would cause constraint errors in any case. The advantage of | |
305 | -- restricting the discriminant types in this way is tha the maximum | |
306 | -- size of the variant record can be calculated more conservatively. | |
307 | ||
308 | -- An example of a situation in which we can perform this type of | |
309 | -- restriction is the following: | |
310 | ||
311 | -- subtype B is range 1 .. 10; | |
312 | -- type Q is array (B range <>) of Integer; | |
313 | ||
314 | -- type V (N : Natural) is record | |
315 | -- C : Q (1 .. N); | |
316 | -- end record; | |
317 | ||
318 | -- In this situation, we can restrict the upper bound of N to 10, since | |
319 | -- any larger value would cause a constraint error in any case. | |
320 | ||
321 | -- There are many situations in which such restriction is possible, but | |
322 | -- for now, we just look for cases like the above, where the component | |
323 | -- in question is a one dimensional array whose upper bound is one of | |
324 | -- the record discriminants. Also the component must not be part of | |
325 | -- any variant part, since then the component does not always exist. | |
326 | ||
327 | procedure Adjust_Discriminants (Rtype : Entity_Id) is | |
328 | Loc : constant Source_Ptr := Sloc (Rtype); | |
329 | Comp : Entity_Id; | |
330 | Ctyp : Entity_Id; | |
331 | Ityp : Entity_Id; | |
332 | Lo : Node_Id; | |
333 | Hi : Node_Id; | |
334 | P : Node_Id; | |
335 | Loval : Uint; | |
336 | Discr : Entity_Id; | |
337 | Dtyp : Entity_Id; | |
338 | Dhi : Node_Id; | |
339 | Dhiv : Uint; | |
340 | Ahi : Node_Id; | |
341 | Ahiv : Uint; | |
342 | Tnn : Entity_Id; | |
343 | ||
344 | begin | |
345 | Comp := First_Component (Rtype); | |
346 | while Present (Comp) loop | |
347 | ||
348 | -- If our parent is a variant, quit, we do not look at components | |
349 | -- that are in variant parts, because they may not always exist. | |
350 | ||
351 | P := Parent (Comp); -- component declaration | |
352 | P := Parent (P); -- component list | |
353 | ||
354 | exit when Nkind (Parent (P)) = N_Variant; | |
355 | ||
356 | -- We are looking for a one dimensional array type | |
357 | ||
358 | Ctyp := Etype (Comp); | |
359 | ||
360 | if not Is_Array_Type (Ctyp) | |
361 | or else Number_Dimensions (Ctyp) > 1 | |
362 | then | |
363 | goto Continue; | |
364 | end if; | |
365 | ||
366 | -- The lower bound must be constant, and the upper bound is a | |
367 | -- discriminant (which is a discriminant of the current record). | |
368 | ||
369 | Ityp := Etype (First_Index (Ctyp)); | |
370 | Lo := Type_Low_Bound (Ityp); | |
371 | Hi := Type_High_Bound (Ityp); | |
372 | ||
373 | if not Compile_Time_Known_Value (Lo) | |
374 | or else Nkind (Hi) /= N_Identifier | |
375 | or else No (Entity (Hi)) | |
376 | or else Ekind (Entity (Hi)) /= E_Discriminant | |
377 | then | |
378 | goto Continue; | |
379 | end if; | |
380 | ||
381 | -- We have an array with appropriate bounds | |
382 | ||
383 | Loval := Expr_Value (Lo); | |
384 | Discr := Entity (Hi); | |
385 | Dtyp := Etype (Discr); | |
386 | ||
387 | -- See if the discriminant has a known upper bound | |
388 | ||
389 | Dhi := Type_High_Bound (Dtyp); | |
390 | ||
391 | if not Compile_Time_Known_Value (Dhi) then | |
392 | goto Continue; | |
393 | end if; | |
394 | ||
395 | Dhiv := Expr_Value (Dhi); | |
396 | ||
397 | -- See if base type of component array has known upper bound | |
398 | ||
399 | Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp)))); | |
400 | ||
401 | if not Compile_Time_Known_Value (Ahi) then | |
402 | goto Continue; | |
403 | end if; | |
404 | ||
405 | Ahiv := Expr_Value (Ahi); | |
406 | ||
407 | -- The condition for doing the restriction is that the high bound | |
408 | -- of the discriminant is greater than the low bound of the array, | |
409 | -- and is also greater than the high bound of the base type index. | |
410 | ||
411 | if Dhiv > Loval and then Dhiv > Ahiv then | |
412 | ||
413 | -- We can reset the upper bound of the discriminant type to | |
414 | -- whichever is larger, the low bound of the component, or | |
415 | -- the high bound of the base type array index. | |
416 | ||
417 | -- We build a subtype that is declared as | |
418 | ||
419 | -- subtype Tnn is discr_type range discr_type'First .. max; | |
420 | ||
421 | -- And insert this declaration into the tree. The type of the | |
422 | -- discriminant is then reset to this more restricted subtype. | |
423 | ||
424 | Tnn := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); | |
425 | ||
426 | Insert_Action (Declaration_Node (Rtype), | |
427 | Make_Subtype_Declaration (Loc, | |
428 | Defining_Identifier => Tnn, | |
429 | Subtype_Indication => | |
430 | Make_Subtype_Indication (Loc, | |
431 | Subtype_Mark => New_Occurrence_Of (Dtyp, Loc), | |
432 | Constraint => | |
433 | Make_Range_Constraint (Loc, | |
434 | Range_Expression => | |
435 | Make_Range (Loc, | |
436 | Low_Bound => | |
437 | Make_Attribute_Reference (Loc, | |
438 | Attribute_Name => Name_First, | |
439 | Prefix => New_Occurrence_Of (Dtyp, Loc)), | |
440 | High_Bound => | |
441 | Make_Integer_Literal (Loc, | |
442 | Intval => UI_Max (Loval, Ahiv))))))); | |
443 | ||
444 | Set_Etype (Discr, Tnn); | |
445 | end if; | |
446 | ||
447 | <<Continue>> | |
448 | Next_Component (Comp); | |
449 | end loop; | |
70482933 RK |
450 | end Adjust_Discriminants; |
451 | ||
452 | --------------------------- | |
453 | -- Build_Array_Init_Proc -- | |
454 | --------------------------- | |
455 | ||
456 | procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is | |
457 | Loc : constant Source_Ptr := Sloc (Nod); | |
458 | Comp_Type : constant Entity_Id := Component_Type (A_Type); | |
459 | Index_List : List_Id; | |
460 | Proc_Id : Entity_Id; | |
70482933 RK |
461 | Body_Stmts : List_Id; |
462 | ||
463 | function Init_Component return List_Id; | |
464 | -- Create one statement to initialize one array component, designated | |
465 | -- by a full set of indices. | |
466 | ||
467 | function Init_One_Dimension (N : Int) return List_Id; | |
468 | -- Create loop to initialize one dimension of the array. The single | |
469 | -- statement in the loop body initializes the inner dimensions if any, | |
470 | -- or else the single component. Note that this procedure is called | |
471 | -- recursively, with N being the dimension to be initialized. A call | |
472 | -- with N greater than the number of dimensions simply generates the | |
473 | -- component initialization, terminating the recursion. | |
474 | ||
475 | -------------------- | |
476 | -- Init_Component -- | |
477 | -------------------- | |
478 | ||
479 | function Init_Component return List_Id is | |
480 | Comp : Node_Id; | |
481 | ||
482 | begin | |
483 | Comp := | |
484 | Make_Indexed_Component (Loc, | |
485 | Prefix => Make_Identifier (Loc, Name_uInit), | |
486 | Expressions => Index_List); | |
487 | ||
488 | if Needs_Simple_Initialization (Comp_Type) then | |
489 | Set_Assignment_OK (Comp); | |
490 | return New_List ( | |
491 | Make_Assignment_Statement (Loc, | |
492 | Name => Comp, | |
82c80734 RD |
493 | Expression => |
494 | Get_Simple_Init_Val | |
495 | (Comp_Type, Loc, Component_Size (A_Type)))); | |
70482933 RK |
496 | |
497 | else | |
498 | return | |
499 | Build_Initialization_Call (Loc, Comp, Comp_Type, True, A_Type); | |
500 | end if; | |
501 | end Init_Component; | |
502 | ||
503 | ------------------------ | |
504 | -- Init_One_Dimension -- | |
505 | ------------------------ | |
506 | ||
507 | function Init_One_Dimension (N : Int) return List_Id is | |
508 | Index : Entity_Id; | |
509 | ||
510 | begin | |
511 | -- If the component does not need initializing, then there is nothing | |
512 | -- to do here, so we return a null body. This occurs when generating | |
513 | -- the dummy Init_Proc needed for Initialize_Scalars processing. | |
514 | ||
515 | if not Has_Non_Null_Base_Init_Proc (Comp_Type) | |
516 | and then not Needs_Simple_Initialization (Comp_Type) | |
517 | and then not Has_Task (Comp_Type) | |
518 | then | |
519 | return New_List (Make_Null_Statement (Loc)); | |
520 | ||
521 | -- If all dimensions dealt with, we simply initialize the component | |
522 | ||
523 | elsif N > Number_Dimensions (A_Type) then | |
524 | return Init_Component; | |
525 | ||
526 | -- Here we generate the required loop | |
527 | ||
528 | else | |
529 | Index := | |
530 | Make_Defining_Identifier (Loc, New_External_Name ('J', N)); | |
531 | ||
532 | Append (New_Reference_To (Index, Loc), Index_List); | |
533 | ||
534 | return New_List ( | |
535 | Make_Implicit_Loop_Statement (Nod, | |
536 | Identifier => Empty, | |
537 | Iteration_Scheme => | |
538 | Make_Iteration_Scheme (Loc, | |
539 | Loop_Parameter_Specification => | |
540 | Make_Loop_Parameter_Specification (Loc, | |
541 | Defining_Identifier => Index, | |
542 | Discrete_Subtype_Definition => | |
543 | Make_Attribute_Reference (Loc, | |
544 | Prefix => Make_Identifier (Loc, Name_uInit), | |
545 | Attribute_Name => Name_Range, | |
546 | Expressions => New_List ( | |
547 | Make_Integer_Literal (Loc, N))))), | |
548 | Statements => Init_One_Dimension (N + 1))); | |
549 | end if; | |
550 | end Init_One_Dimension; | |
551 | ||
552 | -- Start of processing for Build_Array_Init_Proc | |
553 | ||
554 | begin | |
555 | if Suppress_Init_Proc (A_Type) then | |
556 | return; | |
557 | end if; | |
558 | ||
559 | Index_List := New_List; | |
560 | ||
561 | -- We need an initialization procedure if any of the following is true: | |
562 | ||
563 | -- 1. The component type has an initialization procedure | |
564 | -- 2. The component type needs simple initialization | |
565 | -- 3. Tasks are present | |
566 | -- 4. The type is marked as a publc entity | |
567 | ||
568 | -- The reason for the public entity test is to deal properly with the | |
569 | -- Initialize_Scalars pragma. This pragma can be set in the client and | |
570 | -- not in the declaring package, this means the client will make a call | |
571 | -- to the initialization procedure (because one of conditions 1-3 must | |
572 | -- apply in this case), and we must generate a procedure (even if it is | |
573 | -- null) to satisfy the call in this case. | |
574 | ||
82c80734 RD |
575 | -- Exception: do not build an array init_proc for a type whose root |
576 | -- type is Standard.String or Standard.Wide_[Wide_]String, since there | |
577 | -- is no place to put the code, and in any case we handle initialization | |
578 | -- of such types (in the Initialize_Scalars case, that's the only time | |
579 | -- the issue arises) in a special manner anyway which does not need an | |
580 | -- init_proc. | |
70482933 RK |
581 | |
582 | if Has_Non_Null_Base_Init_Proc (Comp_Type) | |
583 | or else Needs_Simple_Initialization (Comp_Type) | |
584 | or else Has_Task (Comp_Type) | |
6e937c1c | 585 | or else (not Restriction_Active (No_Initialize_Scalars) |
fbf5a39b | 586 | and then Is_Public (A_Type) |
70482933 | 587 | and then Root_Type (A_Type) /= Standard_String |
82c80734 RD |
588 | and then Root_Type (A_Type) /= Standard_Wide_String |
589 | and then Root_Type (A_Type) /= Standard_Wide_Wide_String) | |
70482933 RK |
590 | then |
591 | Proc_Id := | |
fbf5a39b | 592 | Make_Defining_Identifier (Loc, Make_Init_Proc_Name (A_Type)); |
70482933 RK |
593 | |
594 | Body_Stmts := Init_One_Dimension (1); | |
595 | ||
fbf5a39b | 596 | Discard_Node ( |
70482933 RK |
597 | Make_Subprogram_Body (Loc, |
598 | Specification => | |
599 | Make_Procedure_Specification (Loc, | |
600 | Defining_Unit_Name => Proc_Id, | |
601 | Parameter_Specifications => Init_Formals (A_Type)), | |
602 | Declarations => New_List, | |
603 | Handled_Statement_Sequence => | |
604 | Make_Handled_Sequence_Of_Statements (Loc, | |
fbf5a39b | 605 | Statements => Body_Stmts))); |
70482933 RK |
606 | |
607 | Set_Ekind (Proc_Id, E_Procedure); | |
608 | Set_Is_Public (Proc_Id, Is_Public (A_Type)); | |
70482933 RK |
609 | Set_Is_Internal (Proc_Id); |
610 | Set_Has_Completion (Proc_Id); | |
611 | ||
612 | if not Debug_Generated_Code then | |
613 | Set_Debug_Info_Off (Proc_Id); | |
614 | end if; | |
615 | ||
07fc65c4 GB |
616 | -- Set inlined unless controlled stuff or tasks around, in which |
617 | -- case we do not want to inline, because nested stuff may cause | |
618 | -- difficulties in interunit inlining, and furthermore there is | |
619 | -- in any case no point in inlining such complex init procs. | |
620 | ||
621 | if not Has_Task (Proc_Id) | |
622 | and then not Controlled_Type (Proc_Id) | |
623 | then | |
624 | Set_Is_Inlined (Proc_Id); | |
625 | end if; | |
626 | ||
70482933 RK |
627 | -- Associate Init_Proc with type, and determine if the procedure |
628 | -- is null (happens because of the Initialize_Scalars pragma case, | |
629 | -- where we have to generate a null procedure in case it is called | |
630 | -- by a client with Initialize_Scalars set). Such procedures have | |
631 | -- to be generated, but do not have to be called, so we mark them | |
632 | -- as null to suppress the call. | |
633 | ||
634 | Set_Init_Proc (A_Type, Proc_Id); | |
635 | ||
636 | if List_Length (Body_Stmts) = 1 | |
637 | and then Nkind (First (Body_Stmts)) = N_Null_Statement | |
638 | then | |
639 | Set_Is_Null_Init_Proc (Proc_Id); | |
640 | end if; | |
641 | end if; | |
70482933 RK |
642 | end Build_Array_Init_Proc; |
643 | ||
644 | ----------------------------- | |
645 | -- Build_Class_Wide_Master -- | |
646 | ----------------------------- | |
647 | ||
648 | procedure Build_Class_Wide_Master (T : Entity_Id) is | |
649 | Loc : constant Source_Ptr := Sloc (T); | |
650 | M_Id : Entity_Id; | |
651 | Decl : Node_Id; | |
652 | P : Node_Id; | |
653 | ||
654 | begin | |
a5b62485 | 655 | -- Nothing to do if there is no task hierarchy |
70482933 | 656 | |
6e937c1c | 657 | if Restriction_Active (No_Task_Hierarchy) then |
70482933 RK |
658 | return; |
659 | end if; | |
660 | ||
661 | -- Nothing to do if we already built a master entity for this scope | |
662 | ||
663 | if not Has_Master_Entity (Scope (T)) then | |
82c80734 | 664 | |
70482933 RK |
665 | -- first build the master entity |
666 | -- _Master : constant Master_Id := Current_Master.all; | |
667 | -- and insert it just before the current declaration | |
668 | ||
669 | Decl := | |
670 | Make_Object_Declaration (Loc, | |
671 | Defining_Identifier => | |
672 | Make_Defining_Identifier (Loc, Name_uMaster), | |
673 | Constant_Present => True, | |
674 | Object_Definition => New_Reference_To (Standard_Integer, Loc), | |
675 | Expression => | |
676 | Make_Explicit_Dereference (Loc, | |
677 | New_Reference_To (RTE (RE_Current_Master), Loc))); | |
678 | ||
679 | P := Parent (T); | |
680 | Insert_Before (P, Decl); | |
681 | Analyze (Decl); | |
682 | Set_Has_Master_Entity (Scope (T)); | |
683 | ||
684 | -- Now mark the containing scope as a task master | |
685 | ||
686 | while Nkind (P) /= N_Compilation_Unit loop | |
687 | P := Parent (P); | |
688 | ||
689 | -- If we fall off the top, we are at the outer level, and the | |
690 | -- environment task is our effective master, so nothing to mark. | |
691 | ||
692 | if Nkind (P) = N_Task_Body | |
693 | or else Nkind (P) = N_Block_Statement | |
694 | or else Nkind (P) = N_Subprogram_Body | |
695 | then | |
696 | Set_Is_Task_Master (P, True); | |
697 | exit; | |
698 | end if; | |
699 | end loop; | |
700 | end if; | |
701 | ||
a5b62485 | 702 | -- Now define the renaming of the master_id |
70482933 RK |
703 | |
704 | M_Id := | |
705 | Make_Defining_Identifier (Loc, | |
706 | New_External_Name (Chars (T), 'M')); | |
707 | ||
708 | Decl := | |
709 | Make_Object_Renaming_Declaration (Loc, | |
710 | Defining_Identifier => M_Id, | |
711 | Subtype_Mark => New_Reference_To (Standard_Integer, Loc), | |
712 | Name => Make_Identifier (Loc, Name_uMaster)); | |
713 | Insert_Before (Parent (T), Decl); | |
714 | Analyze (Decl); | |
715 | ||
716 | Set_Master_Id (T, M_Id); | |
fbf5a39b AC |
717 | |
718 | exception | |
719 | when RE_Not_Available => | |
720 | return; | |
70482933 RK |
721 | end Build_Class_Wide_Master; |
722 | ||
723 | -------------------------------- | |
724 | -- Build_Discr_Checking_Funcs -- | |
725 | -------------------------------- | |
726 | ||
727 | procedure Build_Discr_Checking_Funcs (N : Node_Id) is | |
728 | Rec_Id : Entity_Id; | |
729 | Loc : Source_Ptr; | |
730 | Enclosing_Func_Id : Entity_Id; | |
731 | Sequence : Nat := 1; | |
732 | Type_Def : Node_Id; | |
733 | V : Node_Id; | |
734 | ||
735 | function Build_Case_Statement | |
736 | (Case_Id : Entity_Id; | |
2e071734 | 737 | Variant : Node_Id) return Node_Id; |
fbf5a39b AC |
738 | -- Build a case statement containing only two alternatives. The |
739 | -- first alternative corresponds exactly to the discrete choices | |
740 | -- given on the variant with contains the components that we are | |
741 | -- generating the checks for. If the discriminant is one of these | |
742 | -- return False. The second alternative is an OTHERS choice that | |
743 | -- will return True indicating the discriminant did not match. | |
70482933 RK |
744 | |
745 | function Build_Dcheck_Function | |
746 | (Case_Id : Entity_Id; | |
2e071734 | 747 | Variant : Node_Id) return Entity_Id; |
70482933 RK |
748 | -- Build the discriminant checking function for a given variant |
749 | ||
750 | procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id); | |
751 | -- Builds the discriminant checking function for each variant of the | |
752 | -- given variant part of the record type. | |
753 | ||
754 | -------------------------- | |
755 | -- Build_Case_Statement -- | |
756 | -------------------------- | |
757 | ||
758 | function Build_Case_Statement | |
759 | (Case_Id : Entity_Id; | |
2e071734 | 760 | Variant : Node_Id) return Node_Id |
70482933 | 761 | is |
fbf5a39b | 762 | Alt_List : constant List_Id := New_List; |
70482933 | 763 | Actuals_List : List_Id; |
70482933 RK |
764 | Case_Node : Node_Id; |
765 | Case_Alt_Node : Node_Id; | |
766 | Choice : Node_Id; | |
767 | Choice_List : List_Id; | |
768 | D : Entity_Id; | |
769 | Return_Node : Node_Id; | |
770 | ||
771 | begin | |
70482933 RK |
772 | Case_Node := New_Node (N_Case_Statement, Loc); |
773 | ||
774 | -- Replace the discriminant which controls the variant, with the | |
775 | -- name of the formal of the checking function. | |
776 | ||
777 | Set_Expression (Case_Node, | |
fbf5a39b | 778 | Make_Identifier (Loc, Chars (Case_Id))); |
70482933 RK |
779 | |
780 | Choice := First (Discrete_Choices (Variant)); | |
781 | ||
782 | if Nkind (Choice) = N_Others_Choice then | |
783 | Choice_List := New_Copy_List (Others_Discrete_Choices (Choice)); | |
784 | else | |
785 | Choice_List := New_Copy_List (Discrete_Choices (Variant)); | |
786 | end if; | |
787 | ||
788 | if not Is_Empty_List (Choice_List) then | |
789 | Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); | |
790 | Set_Discrete_Choices (Case_Alt_Node, Choice_List); | |
791 | ||
792 | -- In case this is a nested variant, we need to return the result | |
793 | -- of the discriminant checking function for the immediately | |
794 | -- enclosing variant. | |
795 | ||
796 | if Present (Enclosing_Func_Id) then | |
797 | Actuals_List := New_List; | |
798 | ||
799 | D := First_Discriminant (Rec_Id); | |
800 | while Present (D) loop | |
801 | Append (Make_Identifier (Loc, Chars (D)), Actuals_List); | |
802 | Next_Discriminant (D); | |
803 | end loop; | |
804 | ||
805 | Return_Node := | |
806 | Make_Return_Statement (Loc, | |
807 | Expression => | |
808 | Make_Function_Call (Loc, | |
809 | Name => | |
810 | New_Reference_To (Enclosing_Func_Id, Loc), | |
811 | Parameter_Associations => | |
812 | Actuals_List)); | |
813 | ||
814 | else | |
815 | Return_Node := | |
816 | Make_Return_Statement (Loc, | |
817 | Expression => | |
818 | New_Reference_To (Standard_False, Loc)); | |
819 | end if; | |
820 | ||
821 | Set_Statements (Case_Alt_Node, New_List (Return_Node)); | |
822 | Append (Case_Alt_Node, Alt_List); | |
823 | end if; | |
824 | ||
825 | Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); | |
826 | Choice_List := New_List (New_Node (N_Others_Choice, Loc)); | |
827 | Set_Discrete_Choices (Case_Alt_Node, Choice_List); | |
828 | ||
829 | Return_Node := | |
830 | Make_Return_Statement (Loc, | |
831 | Expression => | |
832 | New_Reference_To (Standard_True, Loc)); | |
833 | ||
834 | Set_Statements (Case_Alt_Node, New_List (Return_Node)); | |
835 | Append (Case_Alt_Node, Alt_List); | |
836 | ||
837 | Set_Alternatives (Case_Node, Alt_List); | |
838 | return Case_Node; | |
839 | end Build_Case_Statement; | |
840 | ||
841 | --------------------------- | |
842 | -- Build_Dcheck_Function -- | |
843 | --------------------------- | |
844 | ||
845 | function Build_Dcheck_Function | |
846 | (Case_Id : Entity_Id; | |
2e071734 | 847 | Variant : Node_Id) return Entity_Id |
70482933 RK |
848 | is |
849 | Body_Node : Node_Id; | |
850 | Func_Id : Entity_Id; | |
851 | Parameter_List : List_Id; | |
852 | Spec_Node : Node_Id; | |
853 | ||
854 | begin | |
855 | Body_Node := New_Node (N_Subprogram_Body, Loc); | |
856 | Sequence := Sequence + 1; | |
857 | ||
858 | Func_Id := | |
859 | Make_Defining_Identifier (Loc, | |
860 | Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence)); | |
861 | ||
862 | Spec_Node := New_Node (N_Function_Specification, Loc); | |
863 | Set_Defining_Unit_Name (Spec_Node, Func_Id); | |
864 | ||
865 | Parameter_List := Build_Discriminant_Formals (Rec_Id, False); | |
866 | ||
867 | Set_Parameter_Specifications (Spec_Node, Parameter_List); | |
868 | Set_Subtype_Mark (Spec_Node, | |
869 | New_Reference_To (Standard_Boolean, Loc)); | |
870 | Set_Specification (Body_Node, Spec_Node); | |
871 | Set_Declarations (Body_Node, New_List); | |
872 | ||
873 | Set_Handled_Statement_Sequence (Body_Node, | |
874 | Make_Handled_Sequence_Of_Statements (Loc, | |
875 | Statements => New_List ( | |
876 | Build_Case_Statement (Case_Id, Variant)))); | |
877 | ||
878 | Set_Ekind (Func_Id, E_Function); | |
879 | Set_Mechanism (Func_Id, Default_Mechanism); | |
880 | Set_Is_Inlined (Func_Id, True); | |
881 | Set_Is_Pure (Func_Id, True); | |
882 | Set_Is_Public (Func_Id, Is_Public (Rec_Id)); | |
883 | Set_Is_Internal (Func_Id, True); | |
884 | ||
885 | if not Debug_Generated_Code then | |
886 | Set_Debug_Info_Off (Func_Id); | |
887 | end if; | |
888 | ||
fbf5a39b AC |
889 | Analyze (Body_Node); |
890 | ||
70482933 RK |
891 | Append_Freeze_Action (Rec_Id, Body_Node); |
892 | Set_Dcheck_Function (Variant, Func_Id); | |
893 | return Func_Id; | |
894 | end Build_Dcheck_Function; | |
895 | ||
896 | ---------------------------- | |
897 | -- Build_Dcheck_Functions -- | |
898 | ---------------------------- | |
899 | ||
900 | procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is | |
901 | Component_List_Node : Node_Id; | |
902 | Decl : Entity_Id; | |
903 | Discr_Name : Entity_Id; | |
904 | Func_Id : Entity_Id; | |
905 | Variant : Node_Id; | |
906 | Saved_Enclosing_Func_Id : Entity_Id; | |
907 | ||
908 | begin | |
909 | -- Build the discriminant checking function for each variant, label | |
910 | -- all components of that variant with the function's name. | |
911 | ||
912 | Discr_Name := Entity (Name (Variant_Part_Node)); | |
913 | Variant := First_Non_Pragma (Variants (Variant_Part_Node)); | |
914 | ||
915 | while Present (Variant) loop | |
916 | Func_Id := Build_Dcheck_Function (Discr_Name, Variant); | |
917 | Component_List_Node := Component_List (Variant); | |
918 | ||
919 | if not Null_Present (Component_List_Node) then | |
920 | Decl := | |
921 | First_Non_Pragma (Component_Items (Component_List_Node)); | |
922 | ||
923 | while Present (Decl) loop | |
924 | Set_Discriminant_Checking_Func | |
925 | (Defining_Identifier (Decl), Func_Id); | |
926 | ||
927 | Next_Non_Pragma (Decl); | |
928 | end loop; | |
929 | ||
930 | if Present (Variant_Part (Component_List_Node)) then | |
931 | Saved_Enclosing_Func_Id := Enclosing_Func_Id; | |
932 | Enclosing_Func_Id := Func_Id; | |
933 | Build_Dcheck_Functions (Variant_Part (Component_List_Node)); | |
934 | Enclosing_Func_Id := Saved_Enclosing_Func_Id; | |
935 | end if; | |
936 | end if; | |
937 | ||
938 | Next_Non_Pragma (Variant); | |
939 | end loop; | |
940 | end Build_Dcheck_Functions; | |
941 | ||
942 | -- Start of processing for Build_Discr_Checking_Funcs | |
943 | ||
944 | begin | |
945 | -- Only build if not done already | |
946 | ||
947 | if not Discr_Check_Funcs_Built (N) then | |
948 | Type_Def := Type_Definition (N); | |
949 | ||
950 | if Nkind (Type_Def) = N_Record_Definition then | |
951 | if No (Component_List (Type_Def)) then -- null record. | |
952 | return; | |
953 | else | |
954 | V := Variant_Part (Component_List (Type_Def)); | |
955 | end if; | |
956 | ||
957 | else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition); | |
958 | if No (Component_List (Record_Extension_Part (Type_Def))) then | |
959 | return; | |
960 | else | |
961 | V := Variant_Part | |
962 | (Component_List (Record_Extension_Part (Type_Def))); | |
963 | end if; | |
964 | end if; | |
965 | ||
966 | Rec_Id := Defining_Identifier (N); | |
967 | ||
968 | if Present (V) and then not Is_Unchecked_Union (Rec_Id) then | |
969 | Loc := Sloc (N); | |
970 | Enclosing_Func_Id := Empty; | |
971 | Build_Dcheck_Functions (V); | |
972 | end if; | |
973 | ||
974 | Set_Discr_Check_Funcs_Built (N); | |
975 | end if; | |
976 | end Build_Discr_Checking_Funcs; | |
977 | ||
978 | -------------------------------- | |
979 | -- Build_Discriminant_Formals -- | |
980 | -------------------------------- | |
981 | ||
982 | function Build_Discriminant_Formals | |
983 | (Rec_Id : Entity_Id; | |
2e071734 | 984 | Use_Dl : Boolean) return List_Id |
70482933 | 985 | is |
fbf5a39b AC |
986 | Loc : Source_Ptr := Sloc (Rec_Id); |
987 | Parameter_List : constant List_Id := New_List; | |
70482933 RK |
988 | D : Entity_Id; |
989 | Formal : Entity_Id; | |
70482933 | 990 | Param_Spec_Node : Node_Id; |
70482933 RK |
991 | |
992 | begin | |
993 | if Has_Discriminants (Rec_Id) then | |
994 | D := First_Discriminant (Rec_Id); | |
70482933 RK |
995 | while Present (D) loop |
996 | Loc := Sloc (D); | |
997 | ||
998 | if Use_Dl then | |
999 | Formal := Discriminal (D); | |
1000 | else | |
fbf5a39b | 1001 | Formal := Make_Defining_Identifier (Loc, Chars (D)); |
70482933 RK |
1002 | end if; |
1003 | ||
1004 | Param_Spec_Node := | |
1005 | Make_Parameter_Specification (Loc, | |
1006 | Defining_Identifier => Formal, | |
1007 | Parameter_Type => | |
1008 | New_Reference_To (Etype (D), Loc)); | |
1009 | Append (Param_Spec_Node, Parameter_List); | |
1010 | Next_Discriminant (D); | |
1011 | end loop; | |
1012 | end if; | |
1013 | ||
1014 | return Parameter_List; | |
1015 | end Build_Discriminant_Formals; | |
1016 | ||
1017 | ------------------------------- | |
1018 | -- Build_Initialization_Call -- | |
1019 | ------------------------------- | |
1020 | ||
1021 | -- References to a discriminant inside the record type declaration | |
1022 | -- can appear either in the subtype_indication to constrain a | |
1023 | -- record or an array, or as part of a larger expression given for | |
1024 | -- the initial value of a component. In both of these cases N appears | |
1025 | -- in the record initialization procedure and needs to be replaced by | |
1026 | -- the formal parameter of the initialization procedure which | |
1027 | -- corresponds to that discriminant. | |
1028 | ||
1029 | -- In the example below, references to discriminants D1 and D2 in proc_1 | |
1030 | -- are replaced by references to formals with the same name | |
1031 | -- (discriminals) | |
1032 | ||
1033 | -- A similar replacement is done for calls to any record | |
1034 | -- initialization procedure for any components that are themselves | |
1035 | -- of a record type. | |
1036 | ||
1037 | -- type R (D1, D2 : Integer) is record | |
1038 | -- X : Integer := F * D1; | |
1039 | -- Y : Integer := F * D2; | |
1040 | -- end record; | |
1041 | ||
1042 | -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is | |
1043 | -- begin | |
1044 | -- Out_2.D1 := D1; | |
1045 | -- Out_2.D2 := D2; | |
1046 | -- Out_2.X := F * D1; | |
1047 | -- Out_2.Y := F * D2; | |
1048 | -- end; | |
1049 | ||
1050 | function Build_Initialization_Call | |
c45b6ae0 AC |
1051 | (Loc : Source_Ptr; |
1052 | Id_Ref : Node_Id; | |
1053 | Typ : Entity_Id; | |
1054 | In_Init_Proc : Boolean := False; | |
1055 | Enclos_Type : Entity_Id := Empty; | |
1056 | Discr_Map : Elist_Id := New_Elmt_List; | |
2e071734 | 1057 | With_Default_Init : Boolean := False) return List_Id |
70482933 RK |
1058 | is |
1059 | First_Arg : Node_Id; | |
1060 | Args : List_Id; | |
1061 | Decls : List_Id; | |
1062 | Decl : Node_Id; | |
1063 | Discr : Entity_Id; | |
1064 | Arg : Node_Id; | |
1065 | Proc : constant Entity_Id := Base_Init_Proc (Typ); | |
1066 | Init_Type : constant Entity_Id := Etype (First_Formal (Proc)); | |
1067 | Full_Init_Type : constant Entity_Id := Underlying_Type (Init_Type); | |
fbf5a39b | 1068 | Res : constant List_Id := New_List; |
70482933 RK |
1069 | Full_Type : Entity_Id := Typ; |
1070 | Controller_Typ : Entity_Id; | |
1071 | ||
1072 | begin | |
2820d220 | 1073 | -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars |
70482933 RK |
1074 | -- is active (in which case we make the call anyway, since in the |
1075 | -- actual compiled client it may be non null). | |
1076 | ||
1077 | if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then | |
1078 | return Empty_List; | |
1079 | end if; | |
1080 | ||
fbf5a39b AC |
1081 | -- Go to full view if private type. In the case of successive |
1082 | -- private derivations, this can require more than one step. | |
70482933 | 1083 | |
fbf5a39b AC |
1084 | while Is_Private_Type (Full_Type) |
1085 | and then Present (Full_View (Full_Type)) | |
1086 | loop | |
1087 | Full_Type := Full_View (Full_Type); | |
1088 | end loop; | |
70482933 RK |
1089 | |
1090 | -- If Typ is derived, the procedure is the initialization procedure for | |
1091 | -- the root type. Wrap the argument in an conversion to make it type | |
1092 | -- honest. Actually it isn't quite type honest, because there can be | |
1093 | -- conflicts of views in the private type case. That is why we set | |
1094 | -- Conversion_OK in the conversion node. | |
70482933 RK |
1095 | if (Is_Record_Type (Typ) |
1096 | or else Is_Array_Type (Typ) | |
1097 | or else Is_Private_Type (Typ)) | |
1098 | and then Init_Type /= Base_Type (Typ) | |
1099 | then | |
1100 | First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref); | |
1101 | Set_Etype (First_Arg, Init_Type); | |
1102 | ||
1103 | else | |
1104 | First_Arg := Id_Ref; | |
1105 | end if; | |
1106 | ||
1107 | Args := New_List (Convert_Concurrent (First_Arg, Typ)); | |
1108 | ||
1109 | -- In the tasks case, add _Master as the value of the _Master parameter | |
1110 | -- and _Chain as the value of the _Chain parameter. At the outer level, | |
1111 | -- these will be variables holding the corresponding values obtained | |
1112 | -- from GNARL. At inner levels, they will be the parameters passed down | |
1113 | -- through the outer routines. | |
1114 | ||
1115 | if Has_Task (Full_Type) then | |
6e937c1c | 1116 | if Restriction_Active (No_Task_Hierarchy) then |
70482933 RK |
1117 | |
1118 | -- See comments in System.Tasking.Initialization.Init_RTS | |
fbf5a39b | 1119 | -- for the value 3 (should be rtsfindable constant ???) |
70482933 RK |
1120 | |
1121 | Append_To (Args, Make_Integer_Literal (Loc, 3)); | |
1122 | else | |
1123 | Append_To (Args, Make_Identifier (Loc, Name_uMaster)); | |
1124 | end if; | |
1125 | ||
1126 | Append_To (Args, Make_Identifier (Loc, Name_uChain)); | |
1127 | ||
0ab80019 | 1128 | -- Ada 2005 (AI-287): In case of default initialized components |
c45b6ae0 AC |
1129 | -- with tasks, we generate a null string actual parameter. |
1130 | -- This is just a workaround that must be improved later??? | |
70482933 | 1131 | |
c45b6ae0 | 1132 | if With_Default_Init then |
1d571f3b AC |
1133 | Append_To (Args, |
1134 | Make_String_Literal (Loc, | |
1135 | Strval => "")); | |
1136 | ||
c45b6ae0 AC |
1137 | else |
1138 | Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type); | |
1139 | Decl := Last (Decls); | |
1140 | ||
1141 | Append_To (Args, | |
1142 | New_Occurrence_Of (Defining_Identifier (Decl), Loc)); | |
1143 | Append_List (Decls, Res); | |
1144 | end if; | |
70482933 RK |
1145 | |
1146 | else | |
1147 | Decls := No_List; | |
1148 | Decl := Empty; | |
1149 | end if; | |
1150 | ||
1151 | -- Add discriminant values if discriminants are present | |
1152 | ||
1153 | if Has_Discriminants (Full_Init_Type) then | |
1154 | Discr := First_Discriminant (Full_Init_Type); | |
1155 | ||
1156 | while Present (Discr) loop | |
1157 | ||
1158 | -- If this is a discriminated concurrent type, the init_proc | |
1159 | -- for the corresponding record is being called. Use that | |
1160 | -- type directly to find the discriminant value, to handle | |
1161 | -- properly intervening renamed discriminants. | |
1162 | ||
1163 | declare | |
1164 | T : Entity_Id := Full_Type; | |
1165 | ||
1166 | begin | |
1167 | if Is_Protected_Type (T) then | |
1168 | T := Corresponding_Record_Type (T); | |
fbf5a39b AC |
1169 | |
1170 | elsif Is_Private_Type (T) | |
1171 | and then Present (Underlying_Full_View (T)) | |
1172 | and then Is_Protected_Type (Underlying_Full_View (T)) | |
1173 | then | |
1174 | T := Corresponding_Record_Type (Underlying_Full_View (T)); | |
70482933 RK |
1175 | end if; |
1176 | ||
1177 | Arg := | |
1178 | Get_Discriminant_Value ( | |
1179 | Discr, | |
1180 | T, | |
1181 | Discriminant_Constraint (Full_Type)); | |
1182 | end; | |
1183 | ||
1184 | if In_Init_Proc then | |
1185 | ||
1186 | -- Replace any possible references to the discriminant in the | |
1187 | -- call to the record initialization procedure with references | |
1188 | -- to the appropriate formal parameter. | |
1189 | ||
1190 | if Nkind (Arg) = N_Identifier | |
1191 | and then Ekind (Entity (Arg)) = E_Discriminant | |
1192 | then | |
1193 | Arg := New_Reference_To (Discriminal (Entity (Arg)), Loc); | |
1194 | ||
1195 | -- Case of access discriminants. We replace the reference | |
1196 | -- to the type by a reference to the actual object | |
1197 | ||
1198 | elsif Nkind (Arg) = N_Attribute_Reference | |
1199 | and then Is_Access_Type (Etype (Arg)) | |
1200 | and then Is_Entity_Name (Prefix (Arg)) | |
1201 | and then Is_Type (Entity (Prefix (Arg))) | |
1202 | then | |
1203 | Arg := | |
1204 | Make_Attribute_Reference (Loc, | |
1205 | Prefix => New_Copy (Prefix (Id_Ref)), | |
1206 | Attribute_Name => Name_Unrestricted_Access); | |
1207 | ||
1208 | -- Otherwise make a copy of the default expression. Note | |
1209 | -- that we use the current Sloc for this, because we do not | |
1210 | -- want the call to appear to be at the declaration point. | |
1211 | -- Within the expression, replace discriminants with their | |
1212 | -- discriminals. | |
1213 | ||
1214 | else | |
1215 | Arg := | |
1216 | New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc); | |
1217 | end if; | |
1218 | ||
1219 | else | |
1220 | if Is_Constrained (Full_Type) then | |
fbf5a39b | 1221 | Arg := Duplicate_Subexpr_No_Checks (Arg); |
70482933 RK |
1222 | else |
1223 | -- The constraints come from the discriminant default | |
1224 | -- exps, they must be reevaluated, so we use New_Copy_Tree | |
1225 | -- but we ensure the proper Sloc (for any embedded calls). | |
1226 | ||
1227 | Arg := New_Copy_Tree (Arg, New_Sloc => Loc); | |
1228 | end if; | |
1229 | end if; | |
1230 | ||
0ab80019 AC |
1231 | -- Ada 2005 (AI-287) In case of default initialized components, |
1232 | -- we need to generate the corresponding selected component node | |
c45b6ae0 AC |
1233 | -- to access the discriminant value. In other cases this is not |
1234 | -- required because we are inside the init proc and we use the | |
1235 | -- corresponding formal. | |
1236 | ||
1237 | if With_Default_Init | |
1238 | and then Nkind (Id_Ref) = N_Selected_Component | |
1239 | then | |
1240 | Append_To (Args, | |
1241 | Make_Selected_Component (Loc, | |
1242 | Prefix => New_Copy_Tree (Prefix (Id_Ref)), | |
1243 | Selector_Name => Arg)); | |
1244 | else | |
1245 | Append_To (Args, Arg); | |
1246 | end if; | |
70482933 RK |
1247 | |
1248 | Next_Discriminant (Discr); | |
1249 | end loop; | |
1250 | end if; | |
1251 | ||
1252 | -- If this is a call to initialize the parent component of a derived | |
1253 | -- tagged type, indicate that the tag should not be set in the parent. | |
1254 | ||
1255 | if Is_Tagged_Type (Full_Init_Type) | |
1256 | and then not Is_CPP_Class (Full_Init_Type) | |
1257 | and then Nkind (Id_Ref) = N_Selected_Component | |
1258 | and then Chars (Selector_Name (Id_Ref)) = Name_uParent | |
1259 | then | |
1260 | Append_To (Args, New_Occurrence_Of (Standard_False, Loc)); | |
1261 | end if; | |
1262 | ||
1263 | Append_To (Res, | |
1264 | Make_Procedure_Call_Statement (Loc, | |
1265 | Name => New_Occurrence_Of (Proc, Loc), | |
1266 | Parameter_Associations => Args)); | |
1267 | ||
1268 | if Controlled_Type (Typ) | |
1269 | and then Nkind (Id_Ref) = N_Selected_Component | |
1270 | then | |
1271 | if Chars (Selector_Name (Id_Ref)) /= Name_uParent then | |
1272 | Append_List_To (Res, | |
1273 | Make_Init_Call ( | |
1274 | Ref => New_Copy_Tree (First_Arg), | |
1275 | Typ => Typ, | |
1276 | Flist_Ref => | |
1277 | Find_Final_List (Typ, New_Copy_Tree (First_Arg)), | |
1278 | With_Attach => Make_Integer_Literal (Loc, 1))); | |
1279 | ||
1280 | -- If the enclosing type is an extension with new controlled | |
1281 | -- components, it has his own record controller. If the parent | |
1282 | -- also had a record controller, attach it to the new one. | |
1283 | -- Build_Init_Statements relies on the fact that in this specific | |
1284 | -- case the last statement of the result is the attach call to | |
1285 | -- the controller. If this is changed, it must be synchronized. | |
1286 | ||
1287 | elsif Present (Enclos_Type) | |
1288 | and then Has_New_Controlled_Component (Enclos_Type) | |
1289 | and then Has_Controlled_Component (Typ) | |
1290 | then | |
1291 | if Is_Return_By_Reference_Type (Typ) then | |
1292 | Controller_Typ := RTE (RE_Limited_Record_Controller); | |
1293 | else | |
1294 | Controller_Typ := RTE (RE_Record_Controller); | |
1295 | end if; | |
1296 | ||
1297 | Append_List_To (Res, | |
1298 | Make_Init_Call ( | |
1299 | Ref => | |
1300 | Make_Selected_Component (Loc, | |
1301 | Prefix => New_Copy_Tree (First_Arg), | |
1302 | Selector_Name => Make_Identifier (Loc, Name_uController)), | |
1303 | Typ => Controller_Typ, | |
1304 | Flist_Ref => Find_Final_List (Typ, New_Copy_Tree (First_Arg)), | |
1305 | With_Attach => Make_Integer_Literal (Loc, 1))); | |
1306 | end if; | |
1307 | end if; | |
1308 | ||
70482933 | 1309 | return Res; |
fbf5a39b AC |
1310 | |
1311 | exception | |
1312 | when RE_Not_Available => | |
1313 | return Empty_List; | |
70482933 RK |
1314 | end Build_Initialization_Call; |
1315 | ||
1316 | --------------------------- | |
1317 | -- Build_Master_Renaming -- | |
1318 | --------------------------- | |
1319 | ||
1320 | procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is | |
1321 | Loc : constant Source_Ptr := Sloc (N); | |
1322 | M_Id : Entity_Id; | |
1323 | Decl : Node_Id; | |
1324 | ||
1325 | begin | |
a5b62485 | 1326 | -- Nothing to do if there is no task hierarchy |
70482933 | 1327 | |
6e937c1c | 1328 | if Restriction_Active (No_Task_Hierarchy) then |
70482933 RK |
1329 | return; |
1330 | end if; | |
1331 | ||
1332 | M_Id := | |
1333 | Make_Defining_Identifier (Loc, | |
1334 | New_External_Name (Chars (T), 'M')); | |
1335 | ||
1336 | Decl := | |
1337 | Make_Object_Renaming_Declaration (Loc, | |
1338 | Defining_Identifier => M_Id, | |
1339 | Subtype_Mark => New_Reference_To (RTE (RE_Master_Id), Loc), | |
1340 | Name => Make_Identifier (Loc, Name_uMaster)); | |
1341 | Insert_Before (N, Decl); | |
1342 | Analyze (Decl); | |
1343 | ||
1344 | Set_Master_Id (T, M_Id); | |
1345 | ||
fbf5a39b AC |
1346 | exception |
1347 | when RE_Not_Available => | |
1348 | return; | |
70482933 RK |
1349 | end Build_Master_Renaming; |
1350 | ||
1351 | ---------------------------- | |
1352 | -- Build_Record_Init_Proc -- | |
1353 | ---------------------------- | |
1354 | ||
1355 | procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is | |
1356 | Loc : Source_Ptr := Sloc (N); | |
fbf5a39b | 1357 | Discr_Map : constant Elist_Id := New_Elmt_List; |
70482933 RK |
1358 | Proc_Id : Entity_Id; |
1359 | Rec_Type : Entity_Id; | |
70482933 RK |
1360 | Set_Tag : Entity_Id := Empty; |
1361 | ||
1362 | function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; | |
1363 | -- Build a assignment statement node which assigns to record | |
1364 | -- component its default expression if defined. The left hand side | |
1365 | -- of the assignment is marked Assignment_OK so that initialization | |
1366 | -- of limited private records works correctly, Return also the | |
1367 | -- adjustment call for controlled objects | |
1368 | ||
1369 | procedure Build_Discriminant_Assignments (Statement_List : List_Id); | |
1370 | -- If the record has discriminants, adds assignment statements to | |
1371 | -- statement list to initialize the discriminant values from the | |
1372 | -- arguments of the initialization procedure. | |
1373 | ||
1374 | function Build_Init_Statements (Comp_List : Node_Id) return List_Id; | |
1375 | -- Build a list representing a sequence of statements which initialize | |
1376 | -- components of the given component list. This may involve building | |
1377 | -- case statements for the variant parts. | |
1378 | ||
2e071734 | 1379 | function Build_Init_Call_Thru (Parameters : List_Id) return List_Id; |
70482933 RK |
1380 | -- Given a non-tagged type-derivation that declares discriminants, |
1381 | -- such as | |
1382 | -- | |
1383 | -- type R (R1, R2 : Integer) is record ... end record; | |
1384 | -- | |
1385 | -- type D (D1 : Integer) is new R (1, D1); | |
1386 | -- | |
1387 | -- we make the _init_proc of D be | |
1388 | -- | |
1389 | -- procedure _init_proc(X : D; D1 : Integer) is | |
1390 | -- begin | |
1391 | -- _init_proc( R(X), 1, D1); | |
1392 | -- end _init_proc; | |
1393 | -- | |
1394 | -- This function builds the call statement in this _init_proc. | |
1395 | ||
1396 | procedure Build_Init_Procedure; | |
1397 | -- Build the tree corresponding to the procedure specification and body | |
1398 | -- of the initialization procedure (by calling all the preceding | |
1399 | -- auxiliary routines), and install it as the _init TSS. | |
1400 | ||
07fc65c4 | 1401 | procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id); |
70482933 | 1402 | -- Add range checks to components of disciminated records. S is a |
07fc65c4 GB |
1403 | -- subtype indication of a record component. Check_List is a list |
1404 | -- to which the check actions are appended. | |
70482933 RK |
1405 | |
1406 | function Component_Needs_Simple_Initialization | |
2e071734 | 1407 | (T : Entity_Id) return Boolean; |
70482933 | 1408 | -- Determines if a component needs simple initialization, given its |
0c644933 | 1409 | -- type T. This is the same as Needs_Simple_Initialization except |
c885d7a1 AC |
1410 | -- for the following difference: the types Tag and Vtable_Ptr, which |
1411 | -- are access types which would normally require simple initialization | |
1412 | -- to null, do not require initialization as components, since they | |
1413 | -- are explicitly initialized by other means. | |
70482933 RK |
1414 | |
1415 | procedure Constrain_Array | |
07fc65c4 GB |
1416 | (SI : Node_Id; |
1417 | Check_List : List_Id); | |
70482933 RK |
1418 | -- Called from Build_Record_Checks. |
1419 | -- Apply a list of index constraints to an unconstrained array type. | |
1420 | -- The first parameter is the entity for the resulting subtype. | |
07fc65c4 | 1421 | -- Check_List is a list to which the check actions are appended. |
70482933 RK |
1422 | |
1423 | procedure Constrain_Index | |
07fc65c4 GB |
1424 | (Index : Node_Id; |
1425 | S : Node_Id; | |
1426 | Check_List : List_Id); | |
70482933 RK |
1427 | -- Called from Build_Record_Checks. |
1428 | -- Process an index constraint in a constrained array declaration. | |
1429 | -- The constraint can be a subtype name, or a range with or without | |
1430 | -- an explicit subtype mark. The index is the corresponding index of the | |
1431 | -- unconstrained array. S is the range expression. Check_List is a list | |
1432 | -- to which the check actions are appended. | |
1433 | ||
1434 | function Parent_Subtype_Renaming_Discrims return Boolean; | |
1435 | -- Returns True for base types N that rename discriminants, else False | |
1436 | ||
1437 | function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean; | |
1438 | -- Determines whether a record initialization procedure needs to be | |
1439 | -- generated for the given record type. | |
1440 | ||
1441 | ---------------------- | |
1442 | -- Build_Assignment -- | |
1443 | ---------------------- | |
1444 | ||
1445 | function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is | |
1446 | Exp : Node_Id := N; | |
1447 | Lhs : Node_Id; | |
1448 | Typ : constant Entity_Id := Underlying_Type (Etype (Id)); | |
1449 | Kind : Node_Kind := Nkind (N); | |
1450 | Res : List_Id; | |
1451 | ||
1452 | begin | |
1453 | Loc := Sloc (N); | |
1454 | Lhs := | |
1455 | Make_Selected_Component (Loc, | |
1456 | Prefix => Make_Identifier (Loc, Name_uInit), | |
1457 | Selector_Name => New_Occurrence_Of (Id, Loc)); | |
1458 | Set_Assignment_OK (Lhs); | |
1459 | ||
c885d7a1 AC |
1460 | -- Case of an access attribute applied to the current instance. |
1461 | -- Replace the reference to the type by a reference to the actual | |
1462 | -- object. (Note that this handles the case of the top level of | |
1463 | -- the expression being given by such an attribute, but does not | |
1464 | -- cover uses nested within an initial value expression. Nested | |
1465 | -- uses are unlikely to occur in practice, but are theoretically | |
1466 | -- possible. It is not clear how to handle them without fully | |
1467 | -- traversing the expression. ??? | |
70482933 RK |
1468 | |
1469 | if Kind = N_Attribute_Reference | |
1470 | and then (Attribute_Name (N) = Name_Unchecked_Access | |
1471 | or else | |
1472 | Attribute_Name (N) = Name_Unrestricted_Access) | |
1473 | and then Is_Entity_Name (Prefix (N)) | |
1474 | and then Is_Type (Entity (Prefix (N))) | |
1475 | and then Entity (Prefix (N)) = Rec_Type | |
1476 | then | |
1477 | Exp := | |
1478 | Make_Attribute_Reference (Loc, | |
1479 | Prefix => Make_Identifier (Loc, Name_uInit), | |
1480 | Attribute_Name => Name_Unrestricted_Access); | |
1481 | end if; | |
1482 | ||
0ab80019 | 1483 | -- Ada 2005 (AI-231): Generate conversion to the null-excluding |
c885d7a1 | 1484 | -- type to force the corresponding run-time check. |
2820d220 | 1485 | |
0ab80019 | 1486 | if Ada_Version >= Ada_05 |
2820d220 | 1487 | and then Can_Never_Be_Null (Etype (Id)) -- Lhs |
0ab80019 AC |
1488 | and then Present (Etype (Exp)) |
1489 | and then not Can_Never_Be_Null (Etype (Exp)) | |
2820d220 | 1490 | then |
0ab80019 | 1491 | Rewrite (Exp, Convert_To (Etype (Id), Relocate_Node (Exp))); |
2820d220 AC |
1492 | Analyze_And_Resolve (Exp, Etype (Id)); |
1493 | end if; | |
1494 | ||
c885d7a1 AC |
1495 | -- Take a copy of Exp to ensure that later copies of this |
1496 | -- component_declaration in derived types see the original tree, | |
1497 | -- not a node rewritten during expansion of the init_proc. | |
1498 | ||
1499 | Exp := New_Copy_Tree (Exp); | |
1500 | ||
70482933 RK |
1501 | Res := New_List ( |
1502 | Make_Assignment_Statement (Loc, | |
1503 | Name => Lhs, | |
1504 | Expression => Exp)); | |
1505 | ||
1506 | Set_No_Ctrl_Actions (First (Res)); | |
1507 | ||
1508 | -- Adjust the tag if tagged (because of possible view conversions). | |
1509 | -- Suppress the tag adjustment when Java_VM because JVM tags are | |
1510 | -- represented implicitly in objects. | |
1511 | ||
1512 | if Is_Tagged_Type (Typ) and then not Java_VM then | |
1513 | Append_To (Res, | |
1514 | Make_Assignment_Statement (Loc, | |
1515 | Name => | |
1516 | Make_Selected_Component (Loc, | |
1517 | Prefix => New_Copy_Tree (Lhs), | |
1518 | Selector_Name => | |
a9d8907c | 1519 | New_Reference_To (First_Tag_Component (Typ), Loc)), |
70482933 RK |
1520 | |
1521 | Expression => | |
1522 | Unchecked_Convert_To (RTE (RE_Tag), | |
a9d8907c JM |
1523 | New_Reference_To |
1524 | (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)))); | |
70482933 RK |
1525 | end if; |
1526 | ||
1527 | -- Adjust the component if controlled except if it is an | |
1528 | -- aggregate that will be expanded inline | |
1529 | ||
1530 | if Kind = N_Qualified_Expression then | |
9bc43c53 | 1531 | Kind := Nkind (Expression (N)); |
70482933 RK |
1532 | end if; |
1533 | ||
1534 | if Controlled_Type (Typ) | |
1535 | and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate) | |
1536 | then | |
1537 | Append_List_To (Res, | |
1538 | Make_Adjust_Call ( | |
1539 | Ref => New_Copy_Tree (Lhs), | |
1540 | Typ => Etype (Id), | |
1541 | Flist_Ref => | |
1542 | Find_Final_List (Etype (Id), New_Copy_Tree (Lhs)), | |
1543 | With_Attach => Make_Integer_Literal (Loc, 1))); | |
1544 | end if; | |
1545 | ||
1546 | return Res; | |
fbf5a39b AC |
1547 | |
1548 | exception | |
1549 | when RE_Not_Available => | |
1550 | return Empty_List; | |
70482933 RK |
1551 | end Build_Assignment; |
1552 | ||
1553 | ------------------------------------ | |
1554 | -- Build_Discriminant_Assignments -- | |
1555 | ------------------------------------ | |
1556 | ||
1557 | procedure Build_Discriminant_Assignments (Statement_List : List_Id) is | |
1558 | D : Entity_Id; | |
1559 | Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type); | |
1560 | ||
1561 | begin | |
1562 | if Has_Discriminants (Rec_Type) | |
1563 | and then not Is_Unchecked_Union (Rec_Type) | |
1564 | then | |
1565 | D := First_Discriminant (Rec_Type); | |
1566 | ||
1567 | while Present (D) loop | |
1568 | -- Don't generate the assignment for discriminants in derived | |
1569 | -- tagged types if the discriminant is a renaming of some | |
1570 | -- ancestor discriminant. This initialization will be done | |
1571 | -- when initializing the _parent field of the derived record. | |
1572 | ||
1573 | if Is_Tagged and then | |
1574 | Present (Corresponding_Discriminant (D)) | |
1575 | then | |
1576 | null; | |
1577 | ||
1578 | else | |
1579 | Loc := Sloc (D); | |
1580 | Append_List_To (Statement_List, | |
1581 | Build_Assignment (D, | |
1582 | New_Reference_To (Discriminal (D), Loc))); | |
1583 | end if; | |
1584 | ||
1585 | Next_Discriminant (D); | |
1586 | end loop; | |
1587 | end if; | |
1588 | end Build_Discriminant_Assignments; | |
1589 | ||
1590 | -------------------------- | |
1591 | -- Build_Init_Call_Thru -- | |
1592 | -------------------------- | |
1593 | ||
2e071734 AC |
1594 | function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is |
1595 | Parent_Proc : constant Entity_Id := | |
1596 | Base_Init_Proc (Etype (Rec_Type)); | |
70482933 | 1597 | |
2e071734 AC |
1598 | Parent_Type : constant Entity_Id := |
1599 | Etype (First_Formal (Parent_Proc)); | |
70482933 | 1600 | |
2e071734 AC |
1601 | Uparent_Type : constant Entity_Id := |
1602 | Underlying_Type (Parent_Type); | |
70482933 RK |
1603 | |
1604 | First_Discr_Param : Node_Id; | |
1605 | ||
1606 | Parent_Discr : Entity_Id; | |
1607 | First_Arg : Node_Id; | |
1608 | Args : List_Id; | |
1609 | Arg : Node_Id; | |
1610 | Res : List_Id; | |
1611 | ||
1612 | begin | |
1613 | -- First argument (_Init) is the object to be initialized. | |
1614 | -- ??? not sure where to get a reasonable Loc for First_Arg | |
1615 | ||
1616 | First_Arg := | |
1617 | OK_Convert_To (Parent_Type, | |
1618 | New_Reference_To (Defining_Identifier (First (Parameters)), Loc)); | |
1619 | ||
1620 | Set_Etype (First_Arg, Parent_Type); | |
1621 | ||
1622 | Args := New_List (Convert_Concurrent (First_Arg, Rec_Type)); | |
1623 | ||
1624 | -- In the tasks case, | |
1625 | -- add _Master as the value of the _Master parameter | |
1626 | -- add _Chain as the value of the _Chain parameter. | |
fbf5a39b | 1627 | -- add _Task_Name as the value of the _Task_Name parameter. |
70482933 RK |
1628 | -- At the outer level, these will be variables holding the |
1629 | -- corresponding values obtained from GNARL or the expander. | |
1630 | -- | |
1631 | -- At inner levels, they will be the parameters passed down through | |
1632 | -- the outer routines. | |
1633 | ||
1634 | First_Discr_Param := Next (First (Parameters)); | |
1635 | ||
1636 | if Has_Task (Rec_Type) then | |
6e937c1c | 1637 | if Restriction_Active (No_Task_Hierarchy) then |
70482933 RK |
1638 | |
1639 | -- See comments in System.Tasking.Initialization.Init_RTS | |
1640 | -- for the value 3. | |
1641 | ||
1642 | Append_To (Args, Make_Integer_Literal (Loc, 3)); | |
1643 | else | |
1644 | Append_To (Args, Make_Identifier (Loc, Name_uMaster)); | |
1645 | end if; | |
1646 | ||
1647 | Append_To (Args, Make_Identifier (Loc, Name_uChain)); | |
fbf5a39b | 1648 | Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); |
70482933 RK |
1649 | First_Discr_Param := Next (Next (Next (First_Discr_Param))); |
1650 | end if; | |
1651 | ||
1652 | -- Append discriminant values | |
1653 | ||
1654 | if Has_Discriminants (Uparent_Type) then | |
1655 | pragma Assert (not Is_Tagged_Type (Uparent_Type)); | |
1656 | ||
1657 | Parent_Discr := First_Discriminant (Uparent_Type); | |
1658 | while Present (Parent_Discr) loop | |
1659 | ||
1660 | -- Get the initial value for this discriminant | |
fbf5a39b | 1661 | -- ??? needs to be cleaned up to use parent_Discr_Constr |
70482933 RK |
1662 | -- directly. |
1663 | ||
1664 | declare | |
1665 | Discr_Value : Elmt_Id := | |
1666 | First_Elmt | |
fbf5a39b | 1667 | (Stored_Constraint (Rec_Type)); |
70482933 RK |
1668 | |
1669 | Discr : Entity_Id := | |
fbf5a39b | 1670 | First_Stored_Discriminant (Uparent_Type); |
70482933 RK |
1671 | begin |
1672 | while Original_Record_Component (Parent_Discr) /= Discr loop | |
fbf5a39b | 1673 | Next_Stored_Discriminant (Discr); |
70482933 RK |
1674 | Next_Elmt (Discr_Value); |
1675 | end loop; | |
1676 | ||
1677 | Arg := Node (Discr_Value); | |
1678 | end; | |
1679 | ||
1680 | -- Append it to the list | |
1681 | ||
1682 | if Nkind (Arg) = N_Identifier | |
1683 | and then Ekind (Entity (Arg)) = E_Discriminant | |
1684 | then | |
1685 | Append_To (Args, | |
1686 | New_Reference_To (Discriminal (Entity (Arg)), Loc)); | |
1687 | ||
1688 | -- Case of access discriminants. We replace the reference | |
1689 | -- to the type by a reference to the actual object | |
1690 | ||
fbf5a39b AC |
1691 | -- ??? why is this code deleted without comment |
1692 | ||
70482933 RK |
1693 | -- elsif Nkind (Arg) = N_Attribute_Reference |
1694 | -- and then Is_Entity_Name (Prefix (Arg)) | |
1695 | -- and then Is_Type (Entity (Prefix (Arg))) | |
1696 | -- then | |
1697 | -- Append_To (Args, | |
1698 | -- Make_Attribute_Reference (Loc, | |
1699 | -- Prefix => New_Copy (Prefix (Id_Ref)), | |
1700 | -- Attribute_Name => Name_Unrestricted_Access)); | |
1701 | ||
1702 | else | |
1703 | Append_To (Args, New_Copy (Arg)); | |
1704 | end if; | |
1705 | ||
1706 | Next_Discriminant (Parent_Discr); | |
1707 | end loop; | |
1708 | end if; | |
1709 | ||
1710 | Res := | |
1711 | New_List ( | |
1712 | Make_Procedure_Call_Statement (Loc, | |
1713 | Name => New_Occurrence_Of (Parent_Proc, Loc), | |
1714 | Parameter_Associations => Args)); | |
1715 | ||
1716 | return Res; | |
1717 | end Build_Init_Call_Thru; | |
1718 | ||
1719 | -------------------------- | |
1720 | -- Build_Init_Procedure -- | |
1721 | -------------------------- | |
1722 | ||
1723 | procedure Build_Init_Procedure is | |
1724 | Body_Node : Node_Id; | |
1725 | Handled_Stmt_Node : Node_Id; | |
1726 | Parameters : List_Id; | |
1727 | Proc_Spec_Node : Node_Id; | |
1728 | Body_Stmts : List_Id; | |
1729 | Record_Extension_Node : Node_Id; | |
1730 | Init_Tag : Node_Id; | |
1731 | ||
1732 | begin | |
1733 | Body_Stmts := New_List; | |
1734 | Body_Node := New_Node (N_Subprogram_Body, Loc); | |
1735 | ||
fbf5a39b AC |
1736 | Proc_Id := |
1737 | Make_Defining_Identifier (Loc, | |
1738 | Chars => Make_Init_Proc_Name (Rec_Type)); | |
70482933 RK |
1739 | Set_Ekind (Proc_Id, E_Procedure); |
1740 | ||
1741 | Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); | |
1742 | Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); | |
1743 | ||
1744 | Parameters := Init_Formals (Rec_Type); | |
1745 | Append_List_To (Parameters, | |
1746 | Build_Discriminant_Formals (Rec_Type, True)); | |
1747 | ||
1748 | -- For tagged types, we add a flag to indicate whether the routine | |
1749 | -- is called to initialize a parent component in the init_proc of | |
1750 | -- a type extension. If the flag is false, we do not set the tag | |
1751 | -- because it has been set already in the extension. | |
1752 | ||
1753 | if Is_Tagged_Type (Rec_Type) | |
1754 | and then not Is_CPP_Class (Rec_Type) | |
1755 | then | |
1756 | Set_Tag := | |
1757 | Make_Defining_Identifier (Loc, New_Internal_Name ('P')); | |
1758 | ||
1759 | Append_To (Parameters, | |
1760 | Make_Parameter_Specification (Loc, | |
1761 | Defining_Identifier => Set_Tag, | |
1762 | Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), | |
1763 | Expression => New_Occurrence_Of (Standard_True, Loc))); | |
1764 | end if; | |
1765 | ||
1766 | Set_Parameter_Specifications (Proc_Spec_Node, Parameters); | |
1767 | Set_Specification (Body_Node, Proc_Spec_Node); | |
1768 | Set_Declarations (Body_Node, New_List); | |
1769 | ||
1770 | if Parent_Subtype_Renaming_Discrims then | |
1771 | ||
1772 | -- N is a Derived_Type_Definition that renames the parameters | |
1773 | -- of the ancestor type. We init it by expanding our discrims | |
1774 | -- and call the ancestor _init_proc with a type-converted object | |
1775 | ||
1776 | Append_List_To (Body_Stmts, | |
fbf5a39b | 1777 | Build_Init_Call_Thru (Parameters)); |
70482933 RK |
1778 | |
1779 | elsif Nkind (Type_Definition (N)) = N_Record_Definition then | |
1780 | Build_Discriminant_Assignments (Body_Stmts); | |
1781 | ||
1782 | if not Null_Present (Type_Definition (N)) then | |
1783 | Append_List_To (Body_Stmts, | |
1784 | Build_Init_Statements ( | |
1785 | Component_List (Type_Definition (N)))); | |
1786 | end if; | |
1787 | ||
1788 | else | |
1789 | -- N is a Derived_Type_Definition with a possible non-empty | |
1790 | -- extension. The initialization of a type extension consists | |
1791 | -- in the initialization of the components in the extension. | |
1792 | ||
1793 | Build_Discriminant_Assignments (Body_Stmts); | |
1794 | ||
1795 | Record_Extension_Node := | |
1796 | Record_Extension_Part (Type_Definition (N)); | |
1797 | ||
1798 | if not Null_Present (Record_Extension_Node) then | |
1799 | declare | |
fbf5a39b AC |
1800 | Stmts : constant List_Id := |
1801 | Build_Init_Statements ( | |
1802 | Component_List (Record_Extension_Node)); | |
70482933 RK |
1803 | |
1804 | begin | |
1805 | -- The parent field must be initialized first because | |
1806 | -- the offset of the new discriminants may depend on it | |
1807 | ||
1808 | Prepend_To (Body_Stmts, Remove_Head (Stmts)); | |
1809 | Append_List_To (Body_Stmts, Stmts); | |
1810 | end; | |
1811 | end if; | |
1812 | end if; | |
1813 | ||
1814 | -- Add here the assignment to instantiate the Tag | |
1815 | ||
1816 | -- The assignement corresponds to the code: | |
1817 | ||
1818 | -- _Init._Tag := Typ'Tag; | |
1819 | ||
1820 | -- Suppress the tag assignment when Java_VM because JVM tags are | |
1821 | -- represented implicitly in objects. | |
1822 | ||
1823 | if Is_Tagged_Type (Rec_Type) | |
1824 | and then not Is_CPP_Class (Rec_Type) | |
1825 | and then not Java_VM | |
1826 | then | |
1827 | Init_Tag := | |
1828 | Make_Assignment_Statement (Loc, | |
1829 | Name => | |
1830 | Make_Selected_Component (Loc, | |
1831 | Prefix => Make_Identifier (Loc, Name_uInit), | |
1832 | Selector_Name => | |
a9d8907c | 1833 | New_Reference_To (First_Tag_Component (Rec_Type), Loc)), |
70482933 RK |
1834 | |
1835 | Expression => | |
a9d8907c JM |
1836 | New_Reference_To |
1837 | (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)); | |
70482933 RK |
1838 | |
1839 | -- The tag must be inserted before the assignments to other | |
1840 | -- components, because the initial value of the component may | |
1841 | -- depend ot the tag (eg. through a dispatching operation on | |
1842 | -- an access to the current type). The tag assignment is not done | |
1843 | -- when initializing the parent component of a type extension, | |
1844 | -- because in that case the tag is set in the extension. | |
1845 | -- Extensions of imported C++ classes add a final complication, | |
1846 | -- because we cannot inhibit tag setting in the constructor for | |
1847 | -- the parent. In that case we insert the tag initialization | |
1848 | -- after the calls to initialize the parent. | |
1849 | ||
1850 | Init_Tag := | |
1851 | Make_If_Statement (Loc, | |
1852 | Condition => New_Occurrence_Of (Set_Tag, Loc), | |
1853 | Then_Statements => New_List (Init_Tag)); | |
1854 | ||
1855 | if not Is_CPP_Class (Etype (Rec_Type)) then | |
1856 | Prepend_To (Body_Stmts, Init_Tag); | |
1857 | ||
1858 | else | |
1859 | declare | |
1860 | Nod : Node_Id := First (Body_Stmts); | |
1861 | ||
1862 | begin | |
1863 | -- We assume the first init_proc call is for the parent | |
1864 | ||
1865 | while Present (Next (Nod)) | |
1866 | and then (Nkind (Nod) /= N_Procedure_Call_Statement | |
fbf5a39b | 1867 | or else not Is_Init_Proc (Name (Nod))) |
70482933 RK |
1868 | loop |
1869 | Nod := Next (Nod); | |
1870 | end loop; | |
1871 | ||
1872 | Insert_After (Nod, Init_Tag); | |
1873 | end; | |
1874 | end if; | |
1875 | end if; | |
1876 | ||
1877 | Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc); | |
1878 | Set_Statements (Handled_Stmt_Node, Body_Stmts); | |
1879 | Set_Exception_Handlers (Handled_Stmt_Node, No_List); | |
1880 | Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); | |
1881 | ||
1882 | if not Debug_Generated_Code then | |
1883 | Set_Debug_Info_Off (Proc_Id); | |
1884 | end if; | |
1885 | ||
1886 | -- Associate Init_Proc with type, and determine if the procedure | |
1887 | -- is null (happens because of the Initialize_Scalars pragma case, | |
1888 | -- where we have to generate a null procedure in case it is called | |
1889 | -- by a client with Initialize_Scalars set). Such procedures have | |
1890 | -- to be generated, but do not have to be called, so we mark them | |
1891 | -- as null to suppress the call. | |
1892 | ||
1893 | Set_Init_Proc (Rec_Type, Proc_Id); | |
1894 | ||
1895 | if List_Length (Body_Stmts) = 1 | |
1896 | and then Nkind (First (Body_Stmts)) = N_Null_Statement | |
1897 | then | |
1898 | Set_Is_Null_Init_Proc (Proc_Id); | |
1899 | end if; | |
1900 | end Build_Init_Procedure; | |
1901 | ||
1902 | --------------------------- | |
1903 | -- Build_Init_Statements -- | |
1904 | --------------------------- | |
1905 | ||
1906 | function Build_Init_Statements (Comp_List : Node_Id) return List_Id is | |
fbf5a39b | 1907 | Check_List : constant List_Id := New_List; |
70482933 RK |
1908 | Alt_List : List_Id; |
1909 | Statement_List : List_Id; | |
1910 | Stmts : List_Id; | |
70482933 RK |
1911 | |
1912 | Per_Object_Constraint_Components : Boolean; | |
1913 | ||
1914 | Decl : Node_Id; | |
1915 | Variant : Node_Id; | |
1916 | ||
1917 | Id : Entity_Id; | |
1918 | Typ : Entity_Id; | |
1919 | ||
5d09245e AC |
1920 | function Has_Access_Constraint (E : Entity_Id) return Boolean; |
1921 | -- Components with access discriminants that depend on the current | |
1922 | -- instance must be initialized after all other components. | |
1923 | ||
1924 | --------------------------- | |
1925 | -- Has_Access_Constraint -- | |
1926 | --------------------------- | |
1927 | ||
1928 | function Has_Access_Constraint (E : Entity_Id) return Boolean is | |
1929 | Disc : Entity_Id; | |
1930 | T : constant Entity_Id := Etype (E); | |
1931 | ||
1932 | begin | |
1933 | if Has_Per_Object_Constraint (E) | |
1934 | and then Has_Discriminants (T) | |
1935 | then | |
1936 | Disc := First_Discriminant (T); | |
1937 | while Present (Disc) loop | |
1938 | if Is_Access_Type (Etype (Disc)) then | |
1939 | return True; | |
1940 | end if; | |
1941 | ||
1942 | Next_Discriminant (Disc); | |
1943 | end loop; | |
1944 | ||
1945 | return False; | |
1946 | else | |
1947 | return False; | |
1948 | end if; | |
1949 | end Has_Access_Constraint; | |
1950 | ||
1951 | -- Start of processing for Build_Init_Statements | |
1952 | ||
70482933 RK |
1953 | begin |
1954 | if Null_Present (Comp_List) then | |
1955 | return New_List (Make_Null_Statement (Loc)); | |
1956 | end if; | |
1957 | ||
1958 | Statement_List := New_List; | |
1959 | ||
1960 | -- Loop through components, skipping pragmas, in 2 steps. The first | |
1961 | -- step deals with regular components. The second step deals with | |
1962 | -- components have per object constraints, and no explicit initia- | |
1963 | -- lization. | |
1964 | ||
1965 | Per_Object_Constraint_Components := False; | |
1966 | ||
5d09245e | 1967 | -- First step : regular components |
70482933 RK |
1968 | |
1969 | Decl := First_Non_Pragma (Component_Items (Comp_List)); | |
1970 | while Present (Decl) loop | |
1971 | Loc := Sloc (Decl); | |
a397db96 AC |
1972 | Build_Record_Checks |
1973 | (Subtype_Indication (Component_Definition (Decl)), Check_List); | |
70482933 RK |
1974 | |
1975 | Id := Defining_Identifier (Decl); | |
1976 | Typ := Etype (Id); | |
1977 | ||
5d09245e | 1978 | if Has_Access_Constraint (Id) |
70482933 RK |
1979 | and then No (Expression (Decl)) |
1980 | then | |
1981 | -- Skip processing for now and ask for a second pass | |
1982 | ||
1983 | Per_Object_Constraint_Components := True; | |
fbf5a39b | 1984 | |
70482933 | 1985 | else |
fbf5a39b AC |
1986 | -- Case of explicit initialization |
1987 | ||
70482933 RK |
1988 | if Present (Expression (Decl)) then |
1989 | Stmts := Build_Assignment (Id, Expression (Decl)); | |
1990 | ||
fbf5a39b AC |
1991 | -- Case of composite component with its own Init_Proc |
1992 | ||
70482933 RK |
1993 | elsif Has_Non_Null_Base_Init_Proc (Typ) then |
1994 | Stmts := | |
fbf5a39b AC |
1995 | Build_Initialization_Call |
1996 | (Loc, | |
1997 | Make_Selected_Component (Loc, | |
1998 | Prefix => Make_Identifier (Loc, Name_uInit), | |
1999 | Selector_Name => New_Occurrence_Of (Id, Loc)), | |
2000 | Typ, | |
2001 | True, | |
2002 | Rec_Type, | |
2003 | Discr_Map => Discr_Map); | |
2004 | ||
2005 | -- Case of component needing simple initialization | |
70482933 RK |
2006 | |
2007 | elsif Component_Needs_Simple_Initialization (Typ) then | |
2008 | Stmts := | |
82c80734 RD |
2009 | Build_Assignment |
2010 | (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id))); | |
70482933 | 2011 | |
fbf5a39b AC |
2012 | -- Nothing needed for this case |
2013 | ||
70482933 RK |
2014 | else |
2015 | Stmts := No_List; | |
2016 | end if; | |
2017 | ||
2018 | if Present (Check_List) then | |
2019 | Append_List_To (Statement_List, Check_List); | |
2020 | end if; | |
2021 | ||
2022 | if Present (Stmts) then | |
2023 | ||
fbf5a39b AC |
2024 | -- Add the initialization of the record controller before |
2025 | -- the _Parent field is attached to it when the attachment | |
2026 | -- can occur. It does not work to simply initialize the | |
2027 | -- controller first: it must be initialized after the parent | |
2028 | -- if the parent holds discriminants that can be used | |
2029 | -- to compute the offset of the controller. We assume here | |
2030 | -- that the last statement of the initialization call is the | |
2031 | -- attachement of the parent (see Build_Initialization_Call) | |
70482933 RK |
2032 | |
2033 | if Chars (Id) = Name_uController | |
2034 | and then Rec_Type /= Etype (Rec_Type) | |
2035 | and then Has_Controlled_Component (Etype (Rec_Type)) | |
2036 | and then Has_New_Controlled_Component (Rec_Type) | |
2037 | then | |
2038 | Insert_List_Before (Last (Statement_List), Stmts); | |
2039 | else | |
2040 | Append_List_To (Statement_List, Stmts); | |
2041 | end if; | |
2042 | end if; | |
2043 | end if; | |
2044 | ||
2045 | Next_Non_Pragma (Decl); | |
2046 | end loop; | |
2047 | ||
2048 | if Per_Object_Constraint_Components then | |
2049 | ||
2050 | -- Second pass: components with per-object constraints | |
2051 | ||
2052 | Decl := First_Non_Pragma (Component_Items (Comp_List)); | |
2053 | ||
2054 | while Present (Decl) loop | |
2055 | Loc := Sloc (Decl); | |
2056 | Id := Defining_Identifier (Decl); | |
2057 | Typ := Etype (Id); | |
2058 | ||
5d09245e | 2059 | if Has_Access_Constraint (Id) |
70482933 RK |
2060 | and then No (Expression (Decl)) |
2061 | then | |
2062 | if Has_Non_Null_Base_Init_Proc (Typ) then | |
2063 | Append_List_To (Statement_List, | |
2064 | Build_Initialization_Call (Loc, | |
2065 | Make_Selected_Component (Loc, | |
2066 | Prefix => Make_Identifier (Loc, Name_uInit), | |
2067 | Selector_Name => New_Occurrence_Of (Id, Loc)), | |
2068 | Typ, True, Rec_Type, Discr_Map => Discr_Map)); | |
2069 | ||
2070 | elsif Component_Needs_Simple_Initialization (Typ) then | |
2071 | Append_List_To (Statement_List, | |
82c80734 RD |
2072 | Build_Assignment |
2073 | (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id)))); | |
70482933 RK |
2074 | end if; |
2075 | end if; | |
2076 | ||
2077 | Next_Non_Pragma (Decl); | |
2078 | end loop; | |
2079 | end if; | |
2080 | ||
2081 | -- Process the variant part | |
2082 | ||
2083 | if Present (Variant_Part (Comp_List)) then | |
2084 | Alt_List := New_List; | |
2085 | Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); | |
2086 | ||
2087 | while Present (Variant) loop | |
2088 | Loc := Sloc (Variant); | |
2089 | Append_To (Alt_List, | |
2090 | Make_Case_Statement_Alternative (Loc, | |
2091 | Discrete_Choices => | |
2092 | New_Copy_List (Discrete_Choices (Variant)), | |
2093 | Statements => | |
2094 | Build_Init_Statements (Component_List (Variant)))); | |
2095 | ||
2096 | Next_Non_Pragma (Variant); | |
2097 | end loop; | |
2098 | ||
2099 | -- The expression of the case statement which is a reference | |
2100 | -- to one of the discriminants is replaced by the appropriate | |
2101 | -- formal parameter of the initialization procedure. | |
2102 | ||
2103 | Append_To (Statement_List, | |
2104 | Make_Case_Statement (Loc, | |
2105 | Expression => | |
2106 | New_Reference_To (Discriminal ( | |
2107 | Entity (Name (Variant_Part (Comp_List)))), Loc), | |
2108 | Alternatives => Alt_List)); | |
2109 | end if; | |
2110 | ||
2111 | -- For a task record type, add the task create call and calls | |
2112 | -- to bind any interrupt (signal) entries. | |
2113 | ||
2114 | if Is_Task_Record_Type (Rec_Type) then | |
523456db AC |
2115 | |
2116 | -- In the case of the restricted run time the ATCB has already | |
2117 | -- been preallocated. | |
2118 | ||
2119 | if Restricted_Profile then | |
2120 | Append_To (Statement_List, | |
2121 | Make_Assignment_Statement (Loc, | |
2122 | Name => Make_Selected_Component (Loc, | |
2123 | Prefix => Make_Identifier (Loc, Name_uInit), | |
2124 | Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), | |
2125 | Expression => Make_Attribute_Reference (Loc, | |
2126 | Prefix => | |
2127 | Make_Selected_Component (Loc, | |
2128 | Prefix => Make_Identifier (Loc, Name_uInit), | |
2129 | Selector_Name => | |
2130 | Make_Identifier (Loc, Name_uATCB)), | |
2131 | Attribute_Name => Name_Unchecked_Access))); | |
2132 | end if; | |
2133 | ||
70482933 RK |
2134 | Append_To (Statement_List, Make_Task_Create_Call (Rec_Type)); |
2135 | ||
2136 | declare | |
2137 | Task_Type : constant Entity_Id := | |
2138 | Corresponding_Concurrent_Type (Rec_Type); | |
2139 | Task_Decl : constant Node_Id := Parent (Task_Type); | |
2140 | Task_Def : constant Node_Id := Task_Definition (Task_Decl); | |
2141 | Vis_Decl : Node_Id; | |
2142 | Ent : Entity_Id; | |
2143 | ||
2144 | begin | |
2145 | if Present (Task_Def) then | |
2146 | Vis_Decl := First (Visible_Declarations (Task_Def)); | |
2147 | while Present (Vis_Decl) loop | |
2148 | Loc := Sloc (Vis_Decl); | |
2149 | ||
2150 | if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then | |
2151 | if Get_Attribute_Id (Chars (Vis_Decl)) = | |
2152 | Attribute_Address | |
2153 | then | |
2154 | Ent := Entity (Name (Vis_Decl)); | |
2155 | ||
2156 | if Ekind (Ent) = E_Entry then | |
2157 | Append_To (Statement_List, | |
2158 | Make_Procedure_Call_Statement (Loc, | |
2159 | Name => New_Reference_To ( | |
2160 | RTE (RE_Bind_Interrupt_To_Entry), Loc), | |
2161 | Parameter_Associations => New_List ( | |
2162 | Make_Selected_Component (Loc, | |
2163 | Prefix => | |
2164 | Make_Identifier (Loc, Name_uInit), | |
2165 | Selector_Name => | |
2166 | Make_Identifier (Loc, Name_uTask_Id)), | |
2167 | Entry_Index_Expression ( | |
2168 | Loc, Ent, Empty, Task_Type), | |
2169 | Expression (Vis_Decl)))); | |
2170 | end if; | |
2171 | end if; | |
2172 | end if; | |
2173 | ||
2174 | Next (Vis_Decl); | |
2175 | end loop; | |
2176 | end if; | |
2177 | end; | |
2178 | end if; | |
2179 | ||
2180 | -- For a protected type, add statements generated by | |
2181 | -- Make_Initialize_Protection. | |
2182 | ||
2183 | if Is_Protected_Record_Type (Rec_Type) then | |
2184 | Append_List_To (Statement_List, | |
2185 | Make_Initialize_Protection (Rec_Type)); | |
2186 | end if; | |
2187 | ||
2188 | -- If no initializations when generated for component declarations | |
2189 | -- corresponding to this Statement_List, append a null statement | |
2190 | -- to the Statement_List to make it a valid Ada tree. | |
2191 | ||
2192 | if Is_Empty_List (Statement_List) then | |
2193 | Append (New_Node (N_Null_Statement, Loc), Statement_List); | |
2194 | end if; | |
2195 | ||
2196 | return Statement_List; | |
fbf5a39b AC |
2197 | |
2198 | exception | |
2199 | when RE_Not_Available => | |
2200 | return Empty_List; | |
70482933 RK |
2201 | end Build_Init_Statements; |
2202 | ||
2203 | ------------------------- | |
2204 | -- Build_Record_Checks -- | |
2205 | ------------------------- | |
2206 | ||
07fc65c4 | 2207 | procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is |
70482933 | 2208 | Subtype_Mark_Id : Entity_Id; |
70482933 | 2209 | |
07fc65c4 | 2210 | begin |
70482933 RK |
2211 | if Nkind (S) = N_Subtype_Indication then |
2212 | Find_Type (Subtype_Mark (S)); | |
70482933 RK |
2213 | Subtype_Mark_Id := Entity (Subtype_Mark (S)); |
2214 | ||
2215 | -- Remaining processing depends on type | |
2216 | ||
2217 | case Ekind (Subtype_Mark_Id) is | |
2218 | ||
2219 | when Array_Kind => | |
07fc65c4 | 2220 | Constrain_Array (S, Check_List); |
70482933 RK |
2221 | |
2222 | when others => | |
2223 | null; | |
2224 | end case; | |
2225 | end if; | |
70482933 RK |
2226 | end Build_Record_Checks; |
2227 | ||
2228 | ------------------------------------------- | |
2229 | -- Component_Needs_Simple_Initialization -- | |
2230 | ------------------------------------------- | |
2231 | ||
2232 | function Component_Needs_Simple_Initialization | |
2e071734 | 2233 | (T : Entity_Id) return Boolean |
70482933 RK |
2234 | is |
2235 | begin | |
2236 | return | |
2237 | Needs_Simple_Initialization (T) | |
2238 | and then not Is_RTE (T, RE_Tag) | |
c885d7a1 | 2239 | and then not Is_RTE (T, RE_Vtable_Ptr); |
70482933 RK |
2240 | end Component_Needs_Simple_Initialization; |
2241 | ||
2242 | --------------------- | |
2243 | -- Constrain_Array -- | |
2244 | --------------------- | |
2245 | ||
2246 | procedure Constrain_Array | |
2247 | (SI : Node_Id; | |
70482933 RK |
2248 | Check_List : List_Id) |
2249 | is | |
2250 | C : constant Node_Id := Constraint (SI); | |
2251 | Number_Of_Constraints : Nat := 0; | |
2252 | Index : Node_Id; | |
2253 | S, T : Entity_Id; | |
2254 | ||
2255 | begin | |
2256 | T := Entity (Subtype_Mark (SI)); | |
2257 | ||
2258 | if Ekind (T) in Access_Kind then | |
2259 | T := Designated_Type (T); | |
2260 | end if; | |
2261 | ||
2262 | S := First (Constraints (C)); | |
2263 | ||
2264 | while Present (S) loop | |
2265 | Number_Of_Constraints := Number_Of_Constraints + 1; | |
2266 | Next (S); | |
2267 | end loop; | |
2268 | ||
2269 | -- In either case, the index constraint must provide a discrete | |
2270 | -- range for each index of the array type and the type of each | |
2271 | -- discrete range must be the same as that of the corresponding | |
2272 | -- index. (RM 3.6.1) | |
2273 | ||
2274 | S := First (Constraints (C)); | |
2275 | Index := First_Index (T); | |
2276 | Analyze (Index); | |
2277 | ||
2278 | -- Apply constraints to each index type | |
2279 | ||
2280 | for J in 1 .. Number_Of_Constraints loop | |
07fc65c4 | 2281 | Constrain_Index (Index, S, Check_List); |
70482933 RK |
2282 | Next (Index); |
2283 | Next (S); | |
2284 | end loop; | |
2285 | ||
2286 | end Constrain_Array; | |
2287 | ||
2288 | --------------------- | |
2289 | -- Constrain_Index -- | |
2290 | --------------------- | |
2291 | ||
2292 | procedure Constrain_Index | |
2293 | (Index : Node_Id; | |
2294 | S : Node_Id; | |
70482933 RK |
2295 | Check_List : List_Id) |
2296 | is | |
2297 | T : constant Entity_Id := Etype (Index); | |
2298 | ||
2299 | begin | |
2300 | if Nkind (S) = N_Range then | |
07fc65c4 | 2301 | Process_Range_Expr_In_Decl (S, T, Check_List); |
70482933 RK |
2302 | end if; |
2303 | end Constrain_Index; | |
2304 | ||
2305 | -------------------------------------- | |
2306 | -- Parent_Subtype_Renaming_Discrims -- | |
2307 | -------------------------------------- | |
2308 | ||
2309 | function Parent_Subtype_Renaming_Discrims return Boolean is | |
2310 | De : Entity_Id; | |
2311 | Dp : Entity_Id; | |
2312 | ||
2313 | begin | |
2314 | if Base_Type (Pe) /= Pe then | |
2315 | return False; | |
2316 | end if; | |
2317 | ||
2318 | if Etype (Pe) = Pe | |
2319 | or else not Has_Discriminants (Pe) | |
2320 | or else Is_Constrained (Pe) | |
2321 | or else Is_Tagged_Type (Pe) | |
2322 | then | |
2323 | return False; | |
2324 | end if; | |
2325 | ||
fbf5a39b | 2326 | -- If there are no explicit stored discriminants we have inherited |
70482933 RK |
2327 | -- the root type discriminants so far, so no renamings occurred. |
2328 | ||
fbf5a39b | 2329 | if First_Discriminant (Pe) = First_Stored_Discriminant (Pe) then |
70482933 RK |
2330 | return False; |
2331 | end if; | |
2332 | ||
2333 | -- Check if we have done some trivial renaming of the parent | |
2334 | -- discriminants, i.e. someting like | |
2335 | -- | |
2336 | -- type DT (X1,X2: int) is new PT (X1,X2); | |
2337 | ||
2338 | De := First_Discriminant (Pe); | |
2339 | Dp := First_Discriminant (Etype (Pe)); | |
2340 | ||
2341 | while Present (De) loop | |
2342 | pragma Assert (Present (Dp)); | |
2343 | ||
2344 | if Corresponding_Discriminant (De) /= Dp then | |
2345 | return True; | |
2346 | end if; | |
2347 | ||
2348 | Next_Discriminant (De); | |
2349 | Next_Discriminant (Dp); | |
2350 | end loop; | |
2351 | ||
2352 | return Present (Dp); | |
2353 | end Parent_Subtype_Renaming_Discrims; | |
2354 | ||
2355 | ------------------------ | |
2356 | -- Requires_Init_Proc -- | |
2357 | ------------------------ | |
2358 | ||
2359 | function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is | |
2360 | Comp_Decl : Node_Id; | |
2361 | Id : Entity_Id; | |
2362 | Typ : Entity_Id; | |
2363 | ||
2364 | begin | |
2365 | -- Definitely do not need one if specifically suppressed | |
2366 | ||
2367 | if Suppress_Init_Proc (Rec_Id) then | |
2368 | return False; | |
2369 | end if; | |
2370 | ||
2371 | -- Otherwise we need to generate an initialization procedure if | |
2372 | -- Is_CPP_Class is False and at least one of the following applies: | |
2373 | ||
2374 | -- 1. Discriminants are present, since they need to be initialized | |
2375 | -- with the appropriate discriminant constraint expressions. | |
2376 | -- However, the discriminant of an unchecked union does not | |
2377 | -- count, since the discriminant is not present. | |
2378 | ||
2379 | -- 2. The type is a tagged type, since the implicit Tag component | |
2380 | -- needs to be initialized with a pointer to the dispatch table. | |
2381 | ||
2382 | -- 3. The type contains tasks | |
2383 | ||
2384 | -- 4. One or more components has an initial value | |
2385 | ||
2386 | -- 5. One or more components is for a type which itself requires | |
2387 | -- an initialization procedure. | |
2388 | ||
2389 | -- 6. One or more components is a type that requires simple | |
2390 | -- initialization (see Needs_Simple_Initialization), except | |
2391 | -- that types Tag and Vtable_Ptr are excluded, since fields | |
2392 | -- of these types are initialized by other means. | |
2393 | ||
2394 | -- 7. The type is the record type built for a task type (since at | |
2395 | -- the very least, Create_Task must be called) | |
2396 | ||
2397 | -- 8. The type is the record type built for a protected type (since | |
2398 | -- at least Initialize_Protection must be called) | |
2399 | ||
2400 | -- 9. The type is marked as a public entity. The reason we add this | |
2401 | -- case (even if none of the above apply) is to properly handle | |
2402 | -- Initialize_Scalars. If a package is compiled without an IS | |
2403 | -- pragma, and the client is compiled with an IS pragma, then | |
2404 | -- the client will think an initialization procedure is present | |
2405 | -- and call it, when in fact no such procedure is required, but | |
2406 | -- since the call is generated, there had better be a routine | |
2407 | -- at the other end of the call, even if it does nothing!) | |
2408 | ||
2409 | -- Note: the reason we exclude the CPP_Class case is ??? | |
2410 | ||
2411 | if Is_CPP_Class (Rec_Id) then | |
2412 | return False; | |
2413 | ||
6e937c1c | 2414 | elsif not Restriction_Active (No_Initialize_Scalars) |
fbf5a39b AC |
2415 | and then Is_Public (Rec_Id) |
2416 | then | |
70482933 RK |
2417 | return True; |
2418 | ||
2419 | elsif (Has_Discriminants (Rec_Id) | |
2420 | and then not Is_Unchecked_Union (Rec_Id)) | |
2421 | or else Is_Tagged_Type (Rec_Id) | |
2422 | or else Is_Concurrent_Record_Type (Rec_Id) | |
2423 | or else Has_Task (Rec_Id) | |
2424 | then | |
2425 | return True; | |
2426 | end if; | |
2427 | ||
2428 | Id := First_Component (Rec_Id); | |
2429 | ||
2430 | while Present (Id) loop | |
2431 | Comp_Decl := Parent (Id); | |
2432 | Typ := Etype (Id); | |
2433 | ||
2434 | if Present (Expression (Comp_Decl)) | |
2435 | or else Has_Non_Null_Base_Init_Proc (Typ) | |
2436 | or else Component_Needs_Simple_Initialization (Typ) | |
2437 | then | |
2438 | return True; | |
2439 | end if; | |
2440 | ||
2441 | Next_Component (Id); | |
2442 | end loop; | |
2443 | ||
2444 | return False; | |
2445 | end Requires_Init_Proc; | |
2446 | ||
2447 | -- Start of processing for Build_Record_Init_Proc | |
2448 | ||
2449 | begin | |
2450 | Rec_Type := Defining_Identifier (N); | |
2451 | ||
2452 | -- This may be full declaration of a private type, in which case | |
2453 | -- the visible entity is a record, and the private entity has been | |
2454 | -- exchanged with it in the private part of the current package. | |
2455 | -- The initialization procedure is built for the record type, which | |
2456 | -- is retrievable from the private entity. | |
2457 | ||
2458 | if Is_Incomplete_Or_Private_Type (Rec_Type) then | |
2459 | Rec_Type := Underlying_Type (Rec_Type); | |
2460 | end if; | |
2461 | ||
2462 | -- If there are discriminants, build the discriminant map to replace | |
2463 | -- discriminants by their discriminals in complex bound expressions. | |
2464 | -- These only arise for the corresponding records of protected types. | |
2465 | ||
2466 | if Is_Concurrent_Record_Type (Rec_Type) | |
2467 | and then Has_Discriminants (Rec_Type) | |
2468 | then | |
2469 | declare | |
2470 | Disc : Entity_Id; | |
2471 | ||
2472 | begin | |
2473 | Disc := First_Discriminant (Rec_Type); | |
2474 | ||
2475 | while Present (Disc) loop | |
2476 | Append_Elmt (Disc, Discr_Map); | |
2477 | Append_Elmt (Discriminal (Disc), Discr_Map); | |
2478 | Next_Discriminant (Disc); | |
2479 | end loop; | |
2480 | end; | |
2481 | end if; | |
2482 | ||
2483 | -- Derived types that have no type extension can use the initialization | |
2484 | -- procedure of their parent and do not need a procedure of their own. | |
2485 | -- This is only correct if there are no representation clauses for the | |
2486 | -- type or its parent, and if the parent has in fact been frozen so | |
2487 | -- that its initialization procedure exists. | |
2488 | ||
2489 | if Is_Derived_Type (Rec_Type) | |
2490 | and then not Is_Tagged_Type (Rec_Type) | |
5d09245e | 2491 | and then not Is_Unchecked_Union (Rec_Type) |
70482933 RK |
2492 | and then not Has_New_Non_Standard_Rep (Rec_Type) |
2493 | and then not Parent_Subtype_Renaming_Discrims | |
2494 | and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type)) | |
2495 | then | |
2496 | Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type); | |
2497 | ||
2498 | -- Otherwise if we need an initialization procedure, then build one, | |
2499 | -- mark it as public and inlinable and as having a completion. | |
2500 | ||
5d09245e AC |
2501 | elsif Requires_Init_Proc (Rec_Type) |
2502 | or else Is_Unchecked_Union (Rec_Type) | |
2503 | then | |
70482933 RK |
2504 | Build_Init_Procedure; |
2505 | Set_Is_Public (Proc_Id, Is_Public (Pe)); | |
2506 | ||
2507 | -- The initialization of protected records is not worth inlining. | |
2508 | -- In addition, when compiled for another unit for inlining purposes, | |
2509 | -- it may make reference to entities that have not been elaborated | |
2510 | -- yet. The initialization of controlled records contains a nested | |
2511 | -- clean-up procedure that makes it impractical to inline as well, | |
2512 | -- and leads to undefined symbols if inlined in a different unit. | |
07fc65c4 | 2513 | -- Similar considerations apply to task types. |
70482933 | 2514 | |
07fc65c4 GB |
2515 | if not Is_Concurrent_Type (Rec_Type) |
2516 | and then not Has_Task (Rec_Type) | |
70482933 RK |
2517 | and then not Controlled_Type (Rec_Type) |
2518 | then | |
2519 | Set_Is_Inlined (Proc_Id); | |
2520 | end if; | |
2521 | ||
2522 | Set_Is_Internal (Proc_Id); | |
2523 | Set_Has_Completion (Proc_Id); | |
2524 | ||
2525 | if not Debug_Generated_Code then | |
2526 | Set_Debug_Info_Off (Proc_Id); | |
2527 | end if; | |
2528 | end if; | |
2529 | end Build_Record_Init_Proc; | |
2530 | ||
26fd4eae AC |
2531 | ---------------------------- |
2532 | -- Build_Slice_Assignment -- | |
2533 | ---------------------------- | |
2534 | ||
2535 | -- Generates the following subprogram: | |
6e937c1c | 2536 | |
26fd4eae AC |
2537 | -- procedure Assign |
2538 | -- (Source, Target : Array_Type, | |
2539 | -- Left_Lo, Left_Hi, Right_Lo, Right_Hi : Index; | |
2540 | -- Rev : Boolean) | |
2541 | -- is | |
2542 | -- Li1 : Index; | |
2543 | -- Ri1 : Index; | |
6e937c1c | 2544 | |
26fd4eae AC |
2545 | -- begin |
2546 | -- if Rev then | |
2547 | -- Li1 := Left_Hi; | |
2548 | -- Ri1 := Right_Hi; | |
2549 | -- else | |
2550 | -- Li1 := Left_Lo; | |
2551 | -- Ri1 := Right_Lo; | |
2552 | -- end if; | |
6e937c1c | 2553 | |
26fd4eae | 2554 | -- loop |
a41ea816 AC |
2555 | -- if Rev then |
2556 | -- exit when Li1 < Left_Lo; | |
2557 | -- else | |
2558 | -- exit when Li1 > Left_Hi; | |
2559 | -- end if; | |
2560 | ||
26fd4eae | 2561 | -- Target (Li1) := Source (Ri1); |
6e937c1c | 2562 | |
26fd4eae | 2563 | -- if Rev then |
a41ea816 AC |
2564 | -- Li1 := Index'pred (Li1); |
2565 | -- Ri1 := Index'pred (Ri1); | |
26fd4eae | 2566 | -- else |
a41ea816 AC |
2567 | -- Li1 := Index'succ (Li1); |
2568 | -- Ri1 := Index'succ (Ri1); | |
26fd4eae AC |
2569 | -- end if; |
2570 | -- end loop; | |
2571 | -- end Assign; | |
2572 | ||
2573 | procedure Build_Slice_Assignment (Typ : Entity_Id) is | |
2574 | Loc : constant Source_Ptr := Sloc (Typ); | |
2575 | Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); | |
2576 | ||
2577 | -- Build formal parameters of procedure | |
2578 | ||
2579 | Larray : constant Entity_Id := | |
2580 | Make_Defining_Identifier | |
2581 | (Loc, Chars => New_Internal_Name ('A')); | |
2582 | Rarray : constant Entity_Id := | |
2583 | Make_Defining_Identifier | |
2584 | (Loc, Chars => New_Internal_Name ('R')); | |
2585 | Left_Lo : constant Entity_Id := | |
2586 | Make_Defining_Identifier | |
2587 | (Loc, Chars => New_Internal_Name ('L')); | |
2588 | Left_Hi : constant Entity_Id := | |
2589 | Make_Defining_Identifier | |
2590 | (Loc, Chars => New_Internal_Name ('L')); | |
2591 | Right_Lo : constant Entity_Id := | |
2592 | Make_Defining_Identifier | |
2593 | (Loc, Chars => New_Internal_Name ('R')); | |
2594 | Right_Hi : constant Entity_Id := | |
2595 | Make_Defining_Identifier | |
2596 | (Loc, Chars => New_Internal_Name ('R')); | |
2597 | Rev : constant Entity_Id := | |
2598 | Make_Defining_Identifier | |
2599 | (Loc, Chars => New_Internal_Name ('D')); | |
2600 | Proc_Name : constant Entity_Id := | |
2601 | Make_Defining_Identifier (Loc, | |
2602 | Chars => Make_TSS_Name (Typ, TSS_Slice_Assign)); | |
2603 | ||
6e937c1c AC |
2604 | Lnn : constant Entity_Id := |
2605 | Make_Defining_Identifier (Loc, New_Internal_Name ('L')); | |
2606 | Rnn : constant Entity_Id := | |
2607 | Make_Defining_Identifier (Loc, New_Internal_Name ('R')); | |
2608 | -- Subscripts for left and right sides | |
26fd4eae | 2609 | |
6e937c1c AC |
2610 | Decls : List_Id; |
2611 | Loops : Node_Id; | |
2612 | Stats : List_Id; | |
26fd4eae AC |
2613 | |
2614 | begin | |
6e937c1c | 2615 | -- Build declarations for indices |
26fd4eae AC |
2616 | |
2617 | Decls := New_List; | |
2618 | ||
2619 | Append_To (Decls, | |
2620 | Make_Object_Declaration (Loc, | |
2621 | Defining_Identifier => Lnn, | |
2622 | Object_Definition => | |
2623 | New_Occurrence_Of (Index, Loc))); | |
2624 | ||
2625 | Append_To (Decls, | |
2626 | Make_Object_Declaration (Loc, | |
2627 | Defining_Identifier => Rnn, | |
2628 | Object_Definition => | |
2629 | New_Occurrence_Of (Index, Loc))); | |
2630 | ||
2631 | Stats := New_List; | |
2632 | ||
6e937c1c | 2633 | -- Build initializations for indices |
26fd4eae AC |
2634 | |
2635 | declare | |
2636 | F_Init : constant List_Id := New_List; | |
2637 | B_Init : constant List_Id := New_List; | |
2638 | ||
2639 | begin | |
2640 | Append_To (F_Init, | |
2641 | Make_Assignment_Statement (Loc, | |
2642 | Name => New_Occurrence_Of (Lnn, Loc), | |
2643 | Expression => New_Occurrence_Of (Left_Lo, Loc))); | |
2644 | ||
2645 | Append_To (F_Init, | |
2646 | Make_Assignment_Statement (Loc, | |
2647 | Name => New_Occurrence_Of (Rnn, Loc), | |
2648 | Expression => New_Occurrence_Of (Right_Lo, Loc))); | |
2649 | ||
2650 | Append_To (B_Init, | |
2651 | Make_Assignment_Statement (Loc, | |
2652 | Name => New_Occurrence_Of (Lnn, Loc), | |
2653 | Expression => New_Occurrence_Of (Left_Hi, Loc))); | |
2654 | ||
2655 | Append_To (B_Init, | |
2656 | Make_Assignment_Statement (Loc, | |
2657 | Name => New_Occurrence_Of (Rnn, Loc), | |
2658 | Expression => New_Occurrence_Of (Right_Hi, Loc))); | |
2659 | ||
2660 | Append_To (Stats, | |
2661 | Make_If_Statement (Loc, | |
2662 | Condition => New_Occurrence_Of (Rev, Loc), | |
2663 | Then_Statements => B_Init, | |
2664 | Else_Statements => F_Init)); | |
2665 | end; | |
2666 | ||
2667 | -- Now construct the assignment statement | |
2668 | ||
2669 | Loops := | |
2670 | Make_Loop_Statement (Loc, | |
2671 | Statements => New_List ( | |
2672 | Make_Assignment_Statement (Loc, | |
2673 | Name => | |
2674 | Make_Indexed_Component (Loc, | |
2675 | Prefix => New_Occurrence_Of (Larray, Loc), | |
2676 | Expressions => New_List (New_Occurrence_Of (Lnn, Loc))), | |
2677 | Expression => | |
2678 | Make_Indexed_Component (Loc, | |
2679 | Prefix => New_Occurrence_Of (Rarray, Loc), | |
2680 | Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))), | |
2681 | End_Label => Empty); | |
2682 | ||
a5b62485 | 2683 | -- Build exit condition |
26fd4eae AC |
2684 | |
2685 | declare | |
2686 | F_Ass : constant List_Id := New_List; | |
2687 | B_Ass : constant List_Id := New_List; | |
2688 | ||
2689 | begin | |
2690 | Append_To (F_Ass, | |
2691 | Make_Exit_Statement (Loc, | |
2692 | Condition => | |
a41ea816 | 2693 | Make_Op_Gt (Loc, |
26fd4eae AC |
2694 | Left_Opnd => New_Occurrence_Of (Lnn, Loc), |
2695 | Right_Opnd => New_Occurrence_Of (Left_Hi, Loc)))); | |
2696 | ||
2697 | Append_To (B_Ass, | |
2698 | Make_Exit_Statement (Loc, | |
2699 | Condition => | |
a41ea816 | 2700 | Make_Op_Lt (Loc, |
26fd4eae AC |
2701 | Left_Opnd => New_Occurrence_Of (Lnn, Loc), |
2702 | Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)))); | |
2703 | ||
a41ea816 AC |
2704 | Prepend_To (Statements (Loops), |
2705 | Make_If_Statement (Loc, | |
2706 | Condition => New_Occurrence_Of (Rev, Loc), | |
2707 | Then_Statements => B_Ass, | |
2708 | Else_Statements => F_Ass)); | |
2709 | end; | |
2710 | ||
2711 | -- Build the increment/decrement statements | |
2712 | ||
2713 | declare | |
2714 | F_Ass : constant List_Id := New_List; | |
2715 | B_Ass : constant List_Id := New_List; | |
2716 | ||
2717 | begin | |
26fd4eae AC |
2718 | Append_To (F_Ass, |
2719 | Make_Assignment_Statement (Loc, | |
2720 | Name => New_Occurrence_Of (Lnn, Loc), | |
2721 | Expression => | |
2722 | Make_Attribute_Reference (Loc, | |
2723 | Prefix => | |
2724 | New_Occurrence_Of (Index, Loc), | |
2725 | Attribute_Name => Name_Succ, | |
2726 | Expressions => New_List ( | |
2727 | New_Occurrence_Of (Lnn, Loc))))); | |
2728 | ||
2729 | Append_To (F_Ass, | |
2730 | Make_Assignment_Statement (Loc, | |
2731 | Name => New_Occurrence_Of (Rnn, Loc), | |
2732 | Expression => | |
2733 | Make_Attribute_Reference (Loc, | |
2734 | Prefix => | |
2735 | New_Occurrence_Of (Index, Loc), | |
2736 | Attribute_Name => Name_Succ, | |
2737 | Expressions => New_List ( | |
2738 | New_Occurrence_Of (Rnn, Loc))))); | |
2739 | ||
2740 | Append_To (B_Ass, | |
2741 | Make_Assignment_Statement (Loc, | |
2742 | Name => New_Occurrence_Of (Lnn, Loc), | |
2743 | Expression => | |
2744 | Make_Attribute_Reference (Loc, | |
2745 | Prefix => | |
2746 | New_Occurrence_Of (Index, Loc), | |
2747 | Attribute_Name => Name_Pred, | |
2748 | Expressions => New_List ( | |
2749 | New_Occurrence_Of (Lnn, Loc))))); | |
2750 | ||
2751 | Append_To (B_Ass, | |
2752 | Make_Assignment_Statement (Loc, | |
2753 | Name => New_Occurrence_Of (Rnn, Loc), | |
2754 | Expression => | |
2755 | Make_Attribute_Reference (Loc, | |
2756 | Prefix => | |
2757 | New_Occurrence_Of (Index, Loc), | |
2758 | Attribute_Name => Name_Pred, | |
2759 | Expressions => New_List ( | |
2760 | New_Occurrence_Of (Rnn, Loc))))); | |
2761 | ||
2762 | Append_To (Statements (Loops), | |
2763 | Make_If_Statement (Loc, | |
2764 | Condition => New_Occurrence_Of (Rev, Loc), | |
2765 | Then_Statements => B_Ass, | |
2766 | Else_Statements => F_Ass)); | |
2767 | end; | |
2768 | ||
2769 | Append_To (Stats, Loops); | |
2770 | ||
2771 | declare | |
6e937c1c AC |
2772 | Spec : Node_Id; |
2773 | Formals : List_Id := New_List; | |
26fd4eae AC |
2774 | |
2775 | begin | |
2776 | Formals := New_List ( | |
2777 | Make_Parameter_Specification (Loc, | |
2778 | Defining_Identifier => Larray, | |
2779 | Out_Present => True, | |
2780 | Parameter_Type => | |
2781 | New_Reference_To (Base_Type (Typ), Loc)), | |
2782 | ||
2783 | Make_Parameter_Specification (Loc, | |
2784 | Defining_Identifier => Rarray, | |
2785 | Parameter_Type => | |
2786 | New_Reference_To (Base_Type (Typ), Loc)), | |
2787 | ||
2788 | Make_Parameter_Specification (Loc, | |
2789 | Defining_Identifier => Left_Lo, | |
2790 | Parameter_Type => | |
2791 | New_Reference_To (Index, Loc)), | |
2792 | ||
2793 | Make_Parameter_Specification (Loc, | |
2794 | Defining_Identifier => Left_Hi, | |
2795 | Parameter_Type => | |
2796 | New_Reference_To (Index, Loc)), | |
2797 | ||
2798 | Make_Parameter_Specification (Loc, | |
2799 | Defining_Identifier => Right_Lo, | |
2800 | Parameter_Type => | |
2801 | New_Reference_To (Index, Loc)), | |
2802 | ||
2803 | Make_Parameter_Specification (Loc, | |
2804 | Defining_Identifier => Right_Hi, | |
2805 | Parameter_Type => | |
2806 | New_Reference_To (Index, Loc))); | |
2807 | ||
2808 | Append_To (Formals, | |
2809 | Make_Parameter_Specification (Loc, | |
2810 | Defining_Identifier => Rev, | |
2811 | Parameter_Type => | |
2812 | New_Reference_To (Standard_Boolean, Loc))); | |
2813 | ||
2814 | Spec := | |
2815 | Make_Procedure_Specification (Loc, | |
2816 | Defining_Unit_Name => Proc_Name, | |
2817 | Parameter_Specifications => Formals); | |
2818 | ||
2819 | Discard_Node ( | |
2820 | Make_Subprogram_Body (Loc, | |
2821 | Specification => Spec, | |
2822 | Declarations => Decls, | |
2823 | Handled_Statement_Sequence => | |
2824 | Make_Handled_Sequence_Of_Statements (Loc, | |
2825 | Statements => Stats))); | |
2826 | end; | |
2827 | ||
2828 | Set_TSS (Typ, Proc_Name); | |
2829 | Set_Is_Pure (Proc_Name); | |
2830 | end Build_Slice_Assignment; | |
2831 | ||
70482933 RK |
2832 | ------------------------------------ |
2833 | -- Build_Variant_Record_Equality -- | |
2834 | ------------------------------------ | |
2835 | ||
2836 | -- Generates: | |
6e937c1c | 2837 | |
70482933 RK |
2838 | -- function _Equality (X, Y : T) return Boolean is |
2839 | -- begin | |
2840 | -- -- Compare discriminants | |
2841 | ||
2842 | -- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then | |
2843 | -- return False; | |
2844 | -- end if; | |
2845 | ||
2846 | -- -- Compare components | |
2847 | ||
2848 | -- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then | |
2849 | -- return False; | |
2850 | -- end if; | |
2851 | ||
2852 | -- -- Compare variant part | |
2853 | ||
2854 | -- case X.D1 is | |
2855 | -- when V1 => | |
2856 | -- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then | |
2857 | -- return False; | |
2858 | -- end if; | |
2859 | -- ... | |
2860 | -- when Vn => | |
2861 | -- if False or else X.Cn /= Y.Cn then | |
2862 | -- return False; | |
2863 | -- end if; | |
2864 | -- end case; | |
2865 | -- return True; | |
2866 | -- end _Equality; | |
2867 | ||
fbf5a39b | 2868 | procedure Build_Variant_Record_Equality (Typ : Entity_Id) is |
70482933 | 2869 | Loc : constant Source_Ptr := Sloc (Typ); |
70482933 | 2870 | |
fbf5a39b AC |
2871 | F : constant Entity_Id := |
2872 | Make_Defining_Identifier (Loc, | |
2873 | Chars => Make_TSS_Name (Typ, TSS_Composite_Equality)); | |
2874 | ||
2875 | X : constant Entity_Id := | |
2876 | Make_Defining_Identifier (Loc, | |
2877 | Chars => Name_X); | |
2878 | ||
2879 | Y : constant Entity_Id := | |
2880 | Make_Defining_Identifier (Loc, | |
2881 | Chars => Name_Y); | |
2882 | ||
2883 | Def : constant Node_Id := Parent (Typ); | |
2884 | Comps : constant Node_Id := Component_List (Type_Definition (Def)); | |
2885 | Stmts : constant List_Id := New_List; | |
5d09245e | 2886 | Pspecs : constant List_Id := New_List; |
70482933 RK |
2887 | |
2888 | begin | |
5d09245e AC |
2889 | -- Derived Unchecked_Union types no longer inherit the equality function |
2890 | -- of their parent. | |
2891 | ||
70482933 | 2892 | if Is_Derived_Type (Typ) |
5d09245e | 2893 | and then not Is_Unchecked_Union (Typ) |
70482933 RK |
2894 | and then not Has_New_Non_Standard_Rep (Typ) |
2895 | then | |
2896 | declare | |
fbf5a39b AC |
2897 | Parent_Eq : constant Entity_Id := |
2898 | TSS (Root_Type (Typ), TSS_Composite_Equality); | |
70482933 RK |
2899 | |
2900 | begin | |
2901 | if Present (Parent_Eq) then | |
2902 | Copy_TSS (Parent_Eq, Typ); | |
2903 | return; | |
2904 | end if; | |
2905 | end; | |
2906 | end if; | |
2907 | ||
fbf5a39b | 2908 | Discard_Node ( |
70482933 RK |
2909 | Make_Subprogram_Body (Loc, |
2910 | Specification => | |
2911 | Make_Function_Specification (Loc, | |
2912 | Defining_Unit_Name => F, | |
5d09245e | 2913 | Parameter_Specifications => Pspecs, |
70482933 | 2914 | Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)), |
70482933 RK |
2915 | Declarations => New_List, |
2916 | Handled_Statement_Sequence => | |
2917 | Make_Handled_Sequence_Of_Statements (Loc, | |
fbf5a39b | 2918 | Statements => Stmts))); |
70482933 | 2919 | |
5d09245e AC |
2920 | Append_To (Pspecs, |
2921 | Make_Parameter_Specification (Loc, | |
2922 | Defining_Identifier => X, | |
2923 | Parameter_Type => New_Reference_To (Typ, Loc))); | |
2924 | ||
2925 | Append_To (Pspecs, | |
2926 | Make_Parameter_Specification (Loc, | |
2927 | Defining_Identifier => Y, | |
2928 | Parameter_Type => New_Reference_To (Typ, Loc))); | |
2929 | ||
2930 | -- Unchecked_Unions require additional machinery to support equality. | |
2931 | -- Two extra parameters (A and B) are added to the equality function | |
2932 | -- parameter list in order to capture the inferred values of the | |
2933 | -- discriminants in later calls. | |
2934 | ||
2935 | if Is_Unchecked_Union (Typ) then | |
2936 | declare | |
2937 | Discr_Type : constant Node_Id := Etype (First_Discriminant (Typ)); | |
2938 | ||
2939 | A : constant Node_Id := | |
2940 | Make_Defining_Identifier (Loc, | |
2941 | Chars => Name_A); | |
2942 | ||
2943 | B : constant Node_Id := | |
2944 | Make_Defining_Identifier (Loc, | |
2945 | Chars => Name_B); | |
2946 | ||
2947 | begin | |
2948 | -- Add A and B to the parameter list | |
2949 | ||
2950 | Append_To (Pspecs, | |
2951 | Make_Parameter_Specification (Loc, | |
2952 | Defining_Identifier => A, | |
2953 | Parameter_Type => New_Reference_To (Discr_Type, Loc))); | |
2954 | ||
2955 | Append_To (Pspecs, | |
2956 | Make_Parameter_Specification (Loc, | |
2957 | Defining_Identifier => B, | |
2958 | Parameter_Type => New_Reference_To (Discr_Type, Loc))); | |
2959 | ||
2960 | -- Generate the following header code to compare the inferred | |
2961 | -- discriminants: | |
2962 | ||
2963 | -- if a /= b then | |
2964 | -- return False; | |
2965 | -- end if; | |
2966 | ||
2967 | Append_To (Stmts, | |
2968 | Make_If_Statement (Loc, | |
2969 | Condition => | |
2970 | Make_Op_Ne (Loc, | |
2971 | Left_Opnd => New_Reference_To (A, Loc), | |
2972 | Right_Opnd => New_Reference_To (B, Loc)), | |
2973 | Then_Statements => New_List ( | |
2974 | Make_Return_Statement (Loc, | |
2975 | Expression => New_Occurrence_Of (Standard_False, Loc))))); | |
2976 | ||
2977 | -- Generate component-by-component comparison. Note that we must | |
2978 | -- propagate one of the inferred discriminant formals to act as | |
2979 | -- the case statement switch. | |
2980 | ||
2981 | Append_List_To (Stmts, | |
2982 | Make_Eq_Case (Typ, Comps, A)); | |
2983 | ||
2984 | end; | |
2985 | ||
2986 | -- Normal case (not unchecked union) | |
70482933 | 2987 | |
70482933 RK |
2988 | else |
2989 | Append_To (Stmts, | |
2990 | Make_Eq_If (Typ, | |
2991 | Discriminant_Specifications (Def))); | |
5d09245e | 2992 | |
70482933 RK |
2993 | Append_List_To (Stmts, |
2994 | Make_Eq_Case (Typ, Comps)); | |
2995 | end if; | |
2996 | ||
2997 | Append_To (Stmts, | |
2998 | Make_Return_Statement (Loc, | |
2999 | Expression => New_Reference_To (Standard_True, Loc))); | |
3000 | ||
3001 | Set_TSS (Typ, F); | |
3002 | Set_Is_Pure (F); | |
3003 | ||
3004 | if not Debug_Generated_Code then | |
3005 | Set_Debug_Info_Off (F); | |
3006 | end if; | |
3007 | end Build_Variant_Record_Equality; | |
3008 | ||
07fc65c4 GB |
3009 | ----------------------------- |
3010 | -- Check_Stream_Attributes -- | |
3011 | ----------------------------- | |
3012 | ||
3013 | procedure Check_Stream_Attributes (Typ : Entity_Id) is | |
fbf5a39b AC |
3014 | Comp : Entity_Id; |
3015 | Par : constant Entity_Id := Root_Type (Base_Type (Typ)); | |
3016 | Par_Read : constant Boolean := Present (TSS (Par, TSS_Stream_Read)); | |
3017 | Par_Write : constant Boolean := Present (TSS (Par, TSS_Stream_Write)); | |
07fc65c4 | 3018 | |
d2d3604c TQ |
3019 | procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type); |
3020 | -- Check that Comp has a user-specified Nam stream attribute | |
3021 | ||
3022 | procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is | |
3023 | begin | |
3024 | if No (TSS (Base_Type (Etype (Comp)), TSS_Nam)) then | |
3025 | Error_Msg_Name_1 := Nam; | |
3026 | Error_Msg_N | |
3027 | ("|component& in limited extension must have% attribute", Comp); | |
3028 | end if; | |
3029 | end Check_Attr; | |
3030 | ||
07fc65c4 GB |
3031 | begin |
3032 | if Par_Read or else Par_Write then | |
3033 | Comp := First_Component (Typ); | |
3034 | while Present (Comp) loop | |
3035 | if Comes_From_Source (Comp) | |
d2d3604c | 3036 | and then Original_Record_Component (Comp) = Comp |
07fc65c4 GB |
3037 | and then Is_Limited_Type (Etype (Comp)) |
3038 | then | |
d2d3604c TQ |
3039 | if Par_Read then |
3040 | Check_Attr (Name_Read, TSS_Stream_Read); | |
3041 | end if; | |
3042 | ||
3043 | if Par_Write then | |
3044 | Check_Attr (Name_Write, TSS_Stream_Write); | |
07fc65c4 GB |
3045 | end if; |
3046 | end if; | |
3047 | ||
3048 | Next_Component (Comp); | |
3049 | end loop; | |
3050 | end if; | |
3051 | end Check_Stream_Attributes; | |
3052 | ||
c885d7a1 AC |
3053 | ----------------------------- |
3054 | -- Expand_Record_Extension -- | |
3055 | ----------------------------- | |
70482933 RK |
3056 | |
3057 | -- Add a field _parent at the beginning of the record extension. This is | |
3058 | -- used to implement inheritance. Here are some examples of expansion: | |
3059 | ||
3060 | -- 1. no discriminants | |
3061 | -- type T2 is new T1 with null record; | |
3062 | -- gives | |
3063 | -- type T2 is new T1 with record | |
3064 | -- _Parent : T1; | |
3065 | -- end record; | |
3066 | ||
3067 | -- 2. renamed discriminants | |
3068 | -- type T2 (B, C : Int) is new T1 (A => B) with record | |
3069 | -- _Parent : T1 (A => B); | |
3070 | -- D : Int; | |
3071 | -- end; | |
3072 | ||
3073 | -- 3. inherited discriminants | |
3074 | -- type T2 is new T1 with record -- discriminant A inherited | |
3075 | -- _Parent : T1 (A); | |
3076 | -- D : Int; | |
3077 | -- end; | |
3078 | ||
c885d7a1 | 3079 | procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is |
70482933 RK |
3080 | Indic : constant Node_Id := Subtype_Indication (Def); |
3081 | Loc : constant Source_Ptr := Sloc (Def); | |
3082 | Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); | |
3083 | Par_Subtype : Entity_Id; | |
3084 | Comp_List : Node_Id; | |
3085 | Comp_Decl : Node_Id; | |
3086 | Parent_N : Node_Id; | |
3087 | D : Entity_Id; | |
3088 | List_Constr : constant List_Id := New_List; | |
3089 | ||
3090 | begin | |
c885d7a1 | 3091 | -- Expand_Record_Extension is called directly from the semantics, so |
70482933 RK |
3092 | -- we must check to see whether expansion is active before proceeding |
3093 | ||
3094 | if not Expander_Active then | |
3095 | return; | |
3096 | end if; | |
3097 | ||
3098 | -- This may be a derivation of an untagged private type whose full | |
3099 | -- view is tagged, in which case the Derived_Type_Definition has no | |
3100 | -- extension part. Build an empty one now. | |
3101 | ||
3102 | if No (Rec_Ext_Part) then | |
3103 | Rec_Ext_Part := | |
3104 | Make_Record_Definition (Loc, | |
3105 | End_Label => Empty, | |
3106 | Component_List => Empty, | |
3107 | Null_Present => True); | |
3108 | ||
3109 | Set_Record_Extension_Part (Def, Rec_Ext_Part); | |
3110 | Mark_Rewrite_Insertion (Rec_Ext_Part); | |
3111 | end if; | |
3112 | ||
3113 | Comp_List := Component_List (Rec_Ext_Part); | |
3114 | ||
3115 | Parent_N := Make_Defining_Identifier (Loc, Name_uParent); | |
3116 | ||
3117 | -- If the derived type inherits its discriminants the type of the | |
3118 | -- _parent field must be constrained by the inherited discriminants | |
3119 | ||
3120 | if Has_Discriminants (T) | |
3121 | and then Nkind (Indic) /= N_Subtype_Indication | |
3122 | and then not Is_Constrained (Entity (Indic)) | |
3123 | then | |
3124 | D := First_Discriminant (T); | |
fbf5a39b | 3125 | while Present (D) loop |
70482933 RK |
3126 | Append_To (List_Constr, New_Occurrence_Of (D, Loc)); |
3127 | Next_Discriminant (D); | |
3128 | end loop; | |
3129 | ||
3130 | Par_Subtype := | |
3131 | Process_Subtype ( | |
3132 | Make_Subtype_Indication (Loc, | |
3133 | Subtype_Mark => New_Reference_To (Entity (Indic), Loc), | |
3134 | Constraint => | |
3135 | Make_Index_Or_Discriminant_Constraint (Loc, | |
3136 | Constraints => List_Constr)), | |
3137 | Def); | |
3138 | ||
3139 | -- Otherwise the original subtype_indication is just what is needed | |
3140 | ||
3141 | else | |
3142 | Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); | |
3143 | end if; | |
3144 | ||
3145 | Set_Parent_Subtype (T, Par_Subtype); | |
3146 | ||
3147 | Comp_Decl := | |
3148 | Make_Component_Declaration (Loc, | |
3149 | Defining_Identifier => Parent_N, | |
a397db96 AC |
3150 | Component_Definition => |
3151 | Make_Component_Definition (Loc, | |
3152 | Aliased_Present => False, | |
3153 | Subtype_Indication => New_Reference_To (Par_Subtype, Loc))); | |
70482933 RK |
3154 | |
3155 | if Null_Present (Rec_Ext_Part) then | |
3156 | Set_Component_List (Rec_Ext_Part, | |
3157 | Make_Component_List (Loc, | |
3158 | Component_Items => New_List (Comp_Decl), | |
3159 | Variant_Part => Empty, | |
3160 | Null_Present => False)); | |
3161 | Set_Null_Present (Rec_Ext_Part, False); | |
3162 | ||
3163 | elsif Null_Present (Comp_List) | |
3164 | or else Is_Empty_List (Component_Items (Comp_List)) | |
3165 | then | |
3166 | Set_Component_Items (Comp_List, New_List (Comp_Decl)); | |
3167 | Set_Null_Present (Comp_List, False); | |
3168 | ||
3169 | else | |
3170 | Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); | |
3171 | end if; | |
3172 | ||
3173 | Analyze (Comp_Decl); | |
c885d7a1 | 3174 | end Expand_Record_Extension; |
70482933 RK |
3175 | |
3176 | ------------------------------------ | |
3177 | -- Expand_N_Full_Type_Declaration -- | |
3178 | ------------------------------------ | |
3179 | ||
3180 | procedure Expand_N_Full_Type_Declaration (N : Node_Id) is | |
3181 | Def_Id : constant Entity_Id := Defining_Identifier (N); | |
fbf5a39b | 3182 | B_Id : constant Entity_Id := Base_Type (Def_Id); |
70482933 RK |
3183 | Par_Id : Entity_Id; |
3184 | FN : Node_Id; | |
3185 | ||
3186 | begin | |
3187 | if Is_Access_Type (Def_Id) then | |
3188 | ||
3189 | -- Anonymous access types are created for the components of the | |
3190 | -- record parameter for an entry declaration. No master is created | |
3191 | -- for such a type. | |
3192 | ||
3193 | if Has_Task (Designated_Type (Def_Id)) | |
3194 | and then Comes_From_Source (N) | |
3195 | then | |
3196 | Build_Master_Entity (Def_Id); | |
3197 | Build_Master_Renaming (Parent (Def_Id), Def_Id); | |
3198 | ||
3199 | -- Create a class-wide master because a Master_Id must be generated | |
3200 | -- for access-to-limited-class-wide types, whose root may be extended | |
3201 | -- with task components. | |
3202 | ||
3203 | elsif Is_Class_Wide_Type (Designated_Type (Def_Id)) | |
3204 | and then Is_Limited_Type (Designated_Type (Def_Id)) | |
3205 | and then Tasking_Allowed | |
3206 | ||
3207 | -- Don't create a class-wide master for types whose convention is | |
3208 | -- Java since these types cannot embed Ada tasks anyway. Note that | |
3209 | -- the following test cannot catch the following case: | |
3210 | -- | |
3211 | -- package java.lang.Object is | |
3212 | -- type Typ is tagged limited private; | |
3213 | -- type Ref is access all Typ'Class; | |
3214 | -- private | |
3215 | -- type Typ is tagged limited ...; | |
3216 | -- pragma Convention (Typ, Java) | |
3217 | -- end; | |
3218 | -- | |
3219 | -- Because the convention appears after we have done the | |
3220 | -- processing for type Ref. | |
3221 | ||
3222 | and then Convention (Designated_Type (Def_Id)) /= Convention_Java | |
3223 | then | |
3224 | Build_Class_Wide_Master (Def_Id); | |
3225 | ||
3226 | elsif Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then | |
3227 | Expand_Access_Protected_Subprogram_Type (N); | |
3228 | end if; | |
3229 | ||
3230 | elsif Has_Task (Def_Id) then | |
07fc65c4 | 3231 | Expand_Previous_Access_Type (Def_Id); |
70482933 RK |
3232 | end if; |
3233 | ||
3234 | Par_Id := Etype (B_Id); | |
3235 | ||
3236 | -- The parent type is private then we need to inherit | |
3237 | -- any TSS operations from the full view. | |
3238 | ||
3239 | if Ekind (Par_Id) in Private_Kind | |
3240 | and then Present (Full_View (Par_Id)) | |
3241 | then | |
3242 | Par_Id := Base_Type (Full_View (Par_Id)); | |
3243 | end if; | |
3244 | ||
3245 | if Nkind (Type_Definition (Original_Node (N))) | |
3246 | = N_Derived_Type_Definition | |
3247 | and then not Is_Tagged_Type (Def_Id) | |
3248 | and then Present (Freeze_Node (Par_Id)) | |
3249 | and then Present (TSS_Elist (Freeze_Node (Par_Id))) | |
3250 | then | |
3251 | Ensure_Freeze_Node (B_Id); | |
3252 | FN := Freeze_Node (B_Id); | |
3253 | ||
3254 | if No (TSS_Elist (FN)) then | |
3255 | Set_TSS_Elist (FN, New_Elmt_List); | |
3256 | end if; | |
3257 | ||
3258 | declare | |
fbf5a39b | 3259 | T_E : constant Elist_Id := TSS_Elist (FN); |
70482933 RK |
3260 | Elmt : Elmt_Id; |
3261 | ||
3262 | begin | |
3263 | Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id))); | |
3264 | ||
3265 | while Present (Elmt) loop | |
3266 | if Chars (Node (Elmt)) /= Name_uInit then | |
3267 | Append_Elmt (Node (Elmt), T_E); | |
3268 | end if; | |
3269 | ||
3270 | Next_Elmt (Elmt); | |
3271 | end loop; | |
3272 | ||
6e937c1c AC |
3273 | -- If the derived type itself is private with a full view, then |
3274 | -- associate the full view with the inherited TSS_Elist as well. | |
70482933 RK |
3275 | |
3276 | if Ekind (B_Id) in Private_Kind | |
3277 | and then Present (Full_View (B_Id)) | |
3278 | then | |
3279 | Ensure_Freeze_Node (Base_Type (Full_View (B_Id))); | |
3280 | Set_TSS_Elist | |
3281 | (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN)); | |
3282 | end if; | |
3283 | end; | |
3284 | end if; | |
3285 | end Expand_N_Full_Type_Declaration; | |
3286 | ||
3287 | --------------------------------- | |
3288 | -- Expand_N_Object_Declaration -- | |
3289 | --------------------------------- | |
3290 | ||
3291 | -- First we do special processing for objects of a tagged type where this | |
3292 | -- is the point at which the type is frozen. The creation of the dispatch | |
3293 | -- table and the initialization procedure have to be deferred to this | |
3294 | -- point, since we reference previously declared primitive subprograms. | |
3295 | ||
3296 | -- For all types, we call an initialization procedure if there is one | |
3297 | ||
3298 | procedure Expand_N_Object_Declaration (N : Node_Id) is | |
3299 | Def_Id : constant Entity_Id := Defining_Identifier (N); | |
3300 | Typ : constant Entity_Id := Etype (Def_Id); | |
3301 | Loc : constant Source_Ptr := Sloc (N); | |
fbf5a39b | 3302 | Expr : constant Node_Id := Expression (N); |
70482933 RK |
3303 | New_Ref : Node_Id; |
3304 | Id_Ref : Node_Id; | |
3305 | Expr_Q : Node_Id; | |
3306 | ||
3307 | begin | |
3308 | -- Don't do anything for deferred constants. All proper actions will | |
91b1417d | 3309 | -- be expanded during the full declaration. |
70482933 | 3310 | |
fbf5a39b | 3311 | if No (Expr) and Constant_Present (N) then |
70482933 RK |
3312 | return; |
3313 | end if; | |
3314 | ||
3315 | -- Make shared memory routines for shared passive variable | |
3316 | ||
3317 | if Is_Shared_Passive (Def_Id) then | |
3318 | Make_Shared_Var_Procs (N); | |
3319 | end if; | |
3320 | ||
3321 | -- If tasks being declared, make sure we have an activation chain | |
3322 | -- defined for the tasks (has no effect if we already have one), and | |
3323 | -- also that a Master variable is established and that the appropriate | |
3324 | -- enclosing construct is established as a task master. | |
3325 | ||
3326 | if Has_Task (Typ) then | |
3327 | Build_Activation_Chain_Entity (N); | |
3328 | Build_Master_Entity (Def_Id); | |
3329 | end if; | |
3330 | ||
3331 | -- Default initialization required, and no expression present | |
3332 | ||
3333 | if No (Expr) then | |
3334 | ||
3335 | -- Expand Initialize call for controlled objects. One may wonder why | |
3336 | -- the Initialize Call is not done in the regular Init procedure | |
3337 | -- attached to the record type. That's because the init procedure is | |
3338 | -- recursively called on each component, including _Parent, thus the | |
3339 | -- Init call for a controlled object would generate not only one | |
3340 | -- Initialize call as it is required but one for each ancestor of | |
3341 | -- its type. This processing is suppressed if No_Initialization set. | |
3342 | ||
3343 | if not Controlled_Type (Typ) | |
3344 | or else No_Initialization (N) | |
3345 | then | |
3346 | null; | |
3347 | ||
3348 | elsif not Abort_Allowed | |
3349 | or else not Comes_From_Source (N) | |
3350 | then | |
3351 | Insert_Actions_After (N, | |
3352 | Make_Init_Call ( | |
3353 | Ref => New_Occurrence_Of (Def_Id, Loc), | |
3354 | Typ => Base_Type (Typ), | |
3355 | Flist_Ref => Find_Final_List (Def_Id), | |
3356 | With_Attach => Make_Integer_Literal (Loc, 1))); | |
3357 | ||
3358 | -- Abort allowed | |
3359 | ||
3360 | else | |
3361 | -- We need to protect the initialize call | |
3362 | ||
3363 | -- begin | |
3364 | -- Defer_Abort.all; | |
3365 | -- Initialize (...); | |
3366 | -- at end | |
3367 | -- Undefer_Abort.all; | |
3368 | -- end; | |
3369 | ||
3370 | -- ??? this won't protect the initialize call for controlled | |
3371 | -- components which are part of the init proc, so this block | |
3372 | -- should probably also contain the call to _init_proc but this | |
3373 | -- requires some code reorganization... | |
3374 | ||
3375 | declare | |
3376 | L : constant List_Id := | |
3377 | Make_Init_Call ( | |
3378 | Ref => New_Occurrence_Of (Def_Id, Loc), | |
3379 | Typ => Base_Type (Typ), | |
3380 | Flist_Ref => Find_Final_List (Def_Id), | |
3381 | With_Attach => Make_Integer_Literal (Loc, 1)); | |
3382 | ||
3383 | Blk : constant Node_Id := | |
3384 | Make_Block_Statement (Loc, | |
3385 | Handled_Statement_Sequence => | |
3386 | Make_Handled_Sequence_Of_Statements (Loc, L)); | |
3387 | ||
3388 | begin | |
3389 | Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer)); | |
3390 | Set_At_End_Proc (Handled_Statement_Sequence (Blk), | |
3391 | New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); | |
3392 | Insert_Actions_After (N, New_List (Blk)); | |
3393 | Expand_At_End_Handler | |
3394 | (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); | |
3395 | end; | |
3396 | end if; | |
3397 | ||
3398 | -- Call type initialization procedure if there is one. We build the | |
3399 | -- call and put it immediately after the object declaration, so that | |
3400 | -- it will be expanded in the usual manner. Note that this will | |
3401 | -- result in proper handling of defaulted discriminants. The call | |
3402 | -- to the Init_Proc is suppressed if No_Initialization is set. | |
3403 | ||
3404 | if Has_Non_Null_Base_Init_Proc (Typ) | |
3405 | and then not No_Initialization (N) | |
3406 | then | |
3407 | -- The call to the initialization procedure does NOT freeze | |
3408 | -- the object being initialized. This is because the call is | |
3409 | -- not a source level call. This works fine, because the only | |
3410 | -- possible statements depending on freeze status that can | |
3411 | -- appear after the _Init call are rep clauses which can | |
3412 | -- safely appear after actual references to the object. | |
3413 | ||
3414 | Id_Ref := New_Reference_To (Def_Id, Loc); | |
3415 | Set_Must_Not_Freeze (Id_Ref); | |
3416 | Set_Assignment_OK (Id_Ref); | |
3417 | ||
3418 | Insert_Actions_After (N, | |
3419 | Build_Initialization_Call (Loc, Id_Ref, Typ)); | |
3420 | ||
3421 | -- If simple initialization is required, then set an appropriate | |
3422 | -- simple initialization expression in place. This special | |
3423 | -- initialization is required even though No_Init_Flag is present. | |
3424 | ||
3425 | elsif Needs_Simple_Initialization (Typ) then | |
3426 | Set_No_Initialization (N, False); | |
82c80734 | 3427 | Set_Expression (N, Get_Simple_Init_Val (Typ, Loc, Esize (Def_Id))); |
70482933 RK |
3428 | Analyze_And_Resolve (Expression (N), Typ); |
3429 | end if; | |
3430 | ||
3431 | -- Explicit initialization present | |
3432 | ||
3433 | else | |
3434 | -- Obtain actual expression from qualified expression | |
3435 | ||
3436 | if Nkind (Expr) = N_Qualified_Expression then | |
3437 | Expr_Q := Expression (Expr); | |
3438 | else | |
3439 | Expr_Q := Expr; | |
3440 | end if; | |
3441 | ||
3442 | -- When we have the appropriate type of aggregate in the | |
3443 | -- expression (it has been determined during analysis of the | |
3444 | -- aggregate by setting the delay flag), let's perform in | |
91b1417d | 3445 | -- place assignment and thus avoid creating a temporary. |
70482933 RK |
3446 | |
3447 | if Is_Delayed_Aggregate (Expr_Q) then | |
3448 | Convert_Aggr_In_Object_Decl (N); | |
3449 | ||
3450 | else | |
3451 | -- In most cases, we must check that the initial value meets | |
3452 | -- any constraint imposed by the declared type. However, there | |
3453 | -- is one very important exception to this rule. If the entity | |
3454 | -- has an unconstrained nominal subtype, then it acquired its | |
3455 | -- constraints from the expression in the first place, and not | |
3456 | -- only does this mean that the constraint check is not needed, | |
3457 | -- but an attempt to perform the constraint check can | |
3458 | -- cause order of elaboration problems. | |
3459 | ||
3460 | if not Is_Constr_Subt_For_U_Nominal (Typ) then | |
3461 | ||
3462 | -- If this is an allocator for an aggregate that has been | |
3463 | -- allocated in place, delay checks until assignments are | |
3464 | -- made, because the discriminants are not initialized. | |
3465 | ||
3466 | if Nkind (Expr) = N_Allocator | |
3467 | and then No_Initialization (Expr) | |
3468 | then | |
3469 | null; | |
3470 | else | |
3471 | Apply_Constraint_Check (Expr, Typ); | |
3472 | end if; | |
3473 | end if; | |
3474 | ||
3475 | -- If the type is controlled we attach the object to the final | |
3476 | -- list and adjust the target after the copy. This | |
3477 | ||
3478 | if Controlled_Type (Typ) then | |
3479 | declare | |
3480 | Flist : Node_Id; | |
3481 | F : Entity_Id; | |
3482 | ||
3483 | begin | |
3484 | -- Attach the result to a dummy final list which will never | |
3485 | -- be finalized if Delay_Finalize_Attachis set. It is | |
3486 | -- important to attach to a dummy final list rather than | |
3487 | -- not attaching at all in order to reset the pointers | |
3488 | -- coming from the initial value. Equivalent code exists | |
3489 | -- in the sec-stack case in Exp_Ch4.Expand_N_Allocator. | |
3490 | ||
3491 | if Delay_Finalize_Attach (N) then | |
3492 | F := | |
3493 | Make_Defining_Identifier (Loc, New_Internal_Name ('F')); | |
3494 | Insert_Action (N, | |
3495 | Make_Object_Declaration (Loc, | |
3496 | Defining_Identifier => F, | |
3497 | Object_Definition => | |
3498 | New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); | |
3499 | ||
3500 | Flist := New_Reference_To (F, Loc); | |
3501 | ||
3502 | else | |
3503 | Flist := Find_Final_List (Def_Id); | |
3504 | end if; | |
3505 | ||
3506 | Insert_Actions_After (N, | |
3507 | Make_Adjust_Call ( | |
3508 | Ref => New_Reference_To (Def_Id, Loc), | |
3509 | Typ => Base_Type (Typ), | |
3510 | Flist_Ref => Flist, | |
3511 | With_Attach => Make_Integer_Literal (Loc, 1))); | |
3512 | end; | |
3513 | end if; | |
3514 | ||
a9d8907c JM |
3515 | -- For tagged types, when an init value is given, the tag has to |
3516 | -- be re-initialized separately in order to avoid the propagation | |
3517 | -- of a wrong tag coming from a view conversion unless the type | |
3518 | -- is class wide (in this case the tag comes from the init | |
3519 | -- value). Suppress the tag assignment when Java_VM because JVM | |
3520 | -- tags are represented implicitly in objects. Ditto for types | |
3521 | -- that are CPP_CLASS, and for initializations that are | |
3522 | -- aggregates, because they have to have the right tag. | |
70482933 RK |
3523 | |
3524 | if Is_Tagged_Type (Typ) | |
3525 | and then not Is_Class_Wide_Type (Typ) | |
3526 | and then not Is_CPP_Class (Typ) | |
3527 | and then not Java_VM | |
a9d8907c | 3528 | and then Nkind (Expr) /= N_Aggregate |
70482933 RK |
3529 | then |
3530 | -- The re-assignment of the tag has to be done even if | |
3531 | -- the object is a constant | |
3532 | ||
3533 | New_Ref := | |
3534 | Make_Selected_Component (Loc, | |
3535 | Prefix => New_Reference_To (Def_Id, Loc), | |
3536 | Selector_Name => | |
a9d8907c | 3537 | New_Reference_To (First_Tag_Component (Typ), Loc)); |
70482933 RK |
3538 | |
3539 | Set_Assignment_OK (New_Ref); | |
3540 | ||
3541 | Insert_After (N, | |
3542 | Make_Assignment_Statement (Loc, | |
3543 | Name => New_Ref, | |
3544 | Expression => | |
3545 | Unchecked_Convert_To (RTE (RE_Tag), | |
3546 | New_Reference_To | |
a9d8907c JM |
3547 | (Node |
3548 | (First_Elmt | |
3549 | (Access_Disp_Table (Base_Type (Typ)))), | |
3550 | Loc)))); | |
70482933 RK |
3551 | |
3552 | -- For discrete types, set the Is_Known_Valid flag if the | |
3553 | -- initializing value is known to be valid. | |
3554 | ||
3555 | elsif Is_Discrete_Type (Typ) | |
3556 | and then Expr_Known_Valid (Expr) | |
3557 | then | |
3558 | Set_Is_Known_Valid (Def_Id); | |
fbf5a39b | 3559 | |
2820d220 | 3560 | elsif Is_Access_Type (Typ) then |
fbf5a39b | 3561 | |
0ab80019 | 3562 | -- Ada 2005 (AI-231): Generate conversion to the null-excluding |
2820d220 | 3563 | -- type to force the corresponding run-time check |
fbf5a39b | 3564 | |
0ab80019 | 3565 | if Ada_Version >= Ada_05 |
2820d220 | 3566 | and then (Can_Never_Be_Null (Def_Id) |
0ab80019 | 3567 | or else Can_Never_Be_Null (Typ)) |
2820d220 | 3568 | then |
0ab80019 AC |
3569 | Rewrite |
3570 | (Expr_Q, | |
3571 | Convert_To (Etype (Def_Id), Relocate_Node (Expr_Q))); | |
2820d220 AC |
3572 | Analyze_And_Resolve (Expr_Q, Etype (Def_Id)); |
3573 | end if; | |
3574 | ||
3575 | -- For access types set the Is_Known_Non_Null flag if the | |
a9d8907c JM |
3576 | -- initializing value is known to be non-null. We can also set |
3577 | -- Can_Never_Be_Null if this is a constant. | |
2820d220 AC |
3578 | |
3579 | if Known_Non_Null (Expr) then | |
3580 | Set_Is_Known_Non_Null (Def_Id); | |
3581 | ||
3582 | if Constant_Present (N) then | |
3583 | Set_Can_Never_Be_Null (Def_Id); | |
3584 | end if; | |
fbf5a39b | 3585 | end if; |
70482933 RK |
3586 | end if; |
3587 | ||
3588 | -- If validity checking on copies, validate initial expression | |
3589 | ||
3590 | if Validity_Checks_On | |
3591 | and then Validity_Check_Copies | |
3592 | then | |
3593 | Ensure_Valid (Expr); | |
3594 | Set_Is_Known_Valid (Def_Id); | |
3595 | end if; | |
3596 | end if; | |
fbf5a39b | 3597 | |
a9d8907c JM |
3598 | -- Cases where the back end cannot handle the initialization |
3599 | -- directly. In such cases, we expand an assignment that will | |
3600 | -- be appropriately handled by Expand_N_Assignment_Statement. | |
fbf5a39b | 3601 | |
a9d8907c JM |
3602 | -- The exclusion of the unconstrained case is wrong, but for |
3603 | -- now it is too much trouble ??? | |
fbf5a39b | 3604 | |
a9d8907c JM |
3605 | if (Is_Possibly_Unaligned_Slice (Expr) |
3606 | or else (Is_Possibly_Unaligned_Object (Expr) | |
3607 | and then not Represented_As_Scalar (Etype (Expr)))) | |
3608 | ||
3609 | -- The exclusion of the unconstrained case is wrong, but for | |
3610 | -- now it is too much trouble ??? | |
3611 | ||
3612 | and then not (Is_Array_Type (Etype (Expr)) | |
3613 | and then not Is_Constrained (Etype (Expr))) | |
3614 | then | |
fbf5a39b AC |
3615 | declare |
3616 | Stat : constant Node_Id := | |
3617 | Make_Assignment_Statement (Loc, | |
a9d8907c | 3618 | Name => New_Reference_To (Def_Id, Loc), |
fbf5a39b | 3619 | Expression => Relocate_Node (Expr)); |
fbf5a39b AC |
3620 | begin |
3621 | Set_Expression (N, Empty); | |
3622 | Set_No_Initialization (N); | |
3623 | Set_Assignment_OK (Name (Stat)); | |
a9d8907c | 3624 | Set_No_Ctrl_Actions (Stat); |
fbf5a39b AC |
3625 | Insert_After (N, Stat); |
3626 | Analyze (Stat); | |
3627 | end; | |
3628 | end if; | |
70482933 RK |
3629 | end if; |
3630 | ||
3631 | -- For array type, check for size too large | |
3632 | -- We really need this for record types too??? | |
3633 | ||
3634 | if Is_Array_Type (Typ) then | |
3635 | Apply_Array_Size_Check (N, Typ); | |
3636 | end if; | |
3637 | ||
fbf5a39b AC |
3638 | exception |
3639 | when RE_Not_Available => | |
3640 | return; | |
70482933 RK |
3641 | end Expand_N_Object_Declaration; |
3642 | ||
3643 | --------------------------------- | |
3644 | -- Expand_N_Subtype_Indication -- | |
3645 | --------------------------------- | |
3646 | ||
a9d8907c JM |
3647 | -- Add a check on the range of the subtype. The static case is partially |
3648 | -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need | |
3649 | -- to check here for the static case in order to avoid generating | |
3650 | -- extraneous expanded code. | |
70482933 RK |
3651 | |
3652 | procedure Expand_N_Subtype_Indication (N : Node_Id) is | |
fbf5a39b AC |
3653 | Ran : constant Node_Id := Range_Expression (Constraint (N)); |
3654 | Typ : constant Entity_Id := Entity (Subtype_Mark (N)); | |
70482933 RK |
3655 | |
3656 | begin | |
3657 | if Nkind (Parent (N)) = N_Constrained_Array_Definition or else | |
3658 | Nkind (Parent (N)) = N_Slice | |
3659 | then | |
3660 | Resolve (Ran, Typ); | |
3661 | Apply_Range_Check (Ran, Typ); | |
3662 | end if; | |
3663 | end Expand_N_Subtype_Indication; | |
3664 | ||
3665 | --------------------------- | |
3666 | -- Expand_N_Variant_Part -- | |
3667 | --------------------------- | |
3668 | ||
a9d8907c JM |
3669 | -- If the last variant does not contain the Others choice, replace it with |
3670 | -- an N_Others_Choice node since Gigi always wants an Others. Note that we | |
3671 | -- do not bother to call Analyze on the modified variant part, since it's | |
3672 | -- only effect would be to compute the contents of the | |
3673 | -- Others_Discrete_Choices node laboriously, and of course we already know | |
3674 | -- the list of choices that corresponds to the others choice (it's the | |
3675 | -- list we are replacing!) | |
70482933 RK |
3676 | |
3677 | procedure Expand_N_Variant_Part (N : Node_Id) is | |
3678 | Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N)); | |
3679 | Others_Node : Node_Id; | |
70482933 RK |
3680 | begin |
3681 | if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then | |
3682 | Others_Node := Make_Others_Choice (Sloc (Last_Var)); | |
3683 | Set_Others_Discrete_Choices | |
3684 | (Others_Node, Discrete_Choices (Last_Var)); | |
3685 | Set_Discrete_Choices (Last_Var, New_List (Others_Node)); | |
3686 | end if; | |
3687 | end Expand_N_Variant_Part; | |
3688 | ||
3689 | --------------------------------- | |
3690 | -- Expand_Previous_Access_Type -- | |
3691 | --------------------------------- | |
3692 | ||
07fc65c4 | 3693 | procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is |
70482933 RK |
3694 | T : Entity_Id := First_Entity (Current_Scope); |
3695 | ||
3696 | begin | |
3697 | -- Find all access types declared in the current scope, whose | |
3698 | -- designated type is Def_Id. | |
3699 | ||
3700 | while Present (T) loop | |
3701 | if Is_Access_Type (T) | |
3702 | and then Designated_Type (T) = Def_Id | |
3703 | then | |
3704 | Build_Master_Entity (Def_Id); | |
3705 | Build_Master_Renaming (Parent (Def_Id), T); | |
3706 | end if; | |
3707 | ||
3708 | Next_Entity (T); | |
3709 | end loop; | |
3710 | end Expand_Previous_Access_Type; | |
3711 | ||
3712 | ------------------------------ | |
3713 | -- Expand_Record_Controller -- | |
3714 | ------------------------------ | |
3715 | ||
3716 | procedure Expand_Record_Controller (T : Entity_Id) is | |
3717 | Def : Node_Id := Type_Definition (Parent (T)); | |
3718 | Comp_List : Node_Id; | |
3719 | Comp_Decl : Node_Id; | |
3720 | Loc : Source_Ptr; | |
3721 | First_Comp : Node_Id; | |
3722 | Controller_Type : Entity_Id; | |
3723 | Ent : Entity_Id; | |
3724 | ||
3725 | begin | |
3726 | if Nkind (Def) = N_Derived_Type_Definition then | |
3727 | Def := Record_Extension_Part (Def); | |
3728 | end if; | |
3729 | ||
3730 | if Null_Present (Def) then | |
3731 | Set_Component_List (Def, | |
3732 | Make_Component_List (Sloc (Def), | |
3733 | Component_Items => Empty_List, | |
3734 | Variant_Part => Empty, | |
3735 | Null_Present => True)); | |
3736 | end if; | |
3737 | ||
3738 | Comp_List := Component_List (Def); | |
3739 | ||
3740 | if Null_Present (Comp_List) | |
3741 | or else Is_Empty_List (Component_Items (Comp_List)) | |
3742 | then | |
3743 | Loc := Sloc (Comp_List); | |
3744 | else | |
3745 | Loc := Sloc (First (Component_Items (Comp_List))); | |
3746 | end if; | |
3747 | ||
3748 | if Is_Return_By_Reference_Type (T) then | |
3749 | Controller_Type := RTE (RE_Limited_Record_Controller); | |
3750 | else | |
3751 | Controller_Type := RTE (RE_Record_Controller); | |
3752 | end if; | |
3753 | ||
3754 | Ent := Make_Defining_Identifier (Loc, Name_uController); | |
3755 | ||
3756 | Comp_Decl := | |
3757 | Make_Component_Declaration (Loc, | |
3758 | Defining_Identifier => Ent, | |
a397db96 AC |
3759 | Component_Definition => |
3760 | Make_Component_Definition (Loc, | |
3761 | Aliased_Present => False, | |
3762 | Subtype_Indication => New_Reference_To (Controller_Type, Loc))); | |
70482933 RK |
3763 | |
3764 | if Null_Present (Comp_List) | |
3765 | or else Is_Empty_List (Component_Items (Comp_List)) | |
3766 | then | |
3767 | Set_Component_Items (Comp_List, New_List (Comp_Decl)); | |
3768 | Set_Null_Present (Comp_List, False); | |
3769 | ||
3770 | else | |
a9d8907c JM |
3771 | -- The controller cannot be placed before the _Parent field since |
3772 | -- gigi lays out field in order and _parent must be first to | |
3773 | -- preserve the polymorphism of tagged types. | |
70482933 RK |
3774 | |
3775 | First_Comp := First (Component_Items (Comp_List)); | |
3776 | ||
3777 | if Chars (Defining_Identifier (First_Comp)) /= Name_uParent | |
3778 | and then Chars (Defining_Identifier (First_Comp)) /= Name_uTag | |
3779 | then | |
3780 | Insert_Before (First_Comp, Comp_Decl); | |
3781 | else | |
3782 | Insert_After (First_Comp, Comp_Decl); | |
3783 | end if; | |
3784 | end if; | |
3785 | ||
3786 | New_Scope (T); | |
3787 | Analyze (Comp_Decl); | |
3788 | Set_Ekind (Ent, E_Component); | |
3789 | Init_Component_Location (Ent); | |
3790 | ||
a9d8907c JM |
3791 | -- Move the _controller entity ahead in the list of internal entities |
3792 | -- of the enclosing record so that it is selected instead of a | |
3793 | -- potentially inherited one. | |
70482933 RK |
3794 | |
3795 | declare | |
fbf5a39b | 3796 | E : constant Entity_Id := Last_Entity (T); |
70482933 RK |
3797 | Comp : Entity_Id; |
3798 | ||
3799 | begin | |
3800 | pragma Assert (Chars (E) = Name_uController); | |
3801 | ||
3802 | Set_Next_Entity (E, First_Entity (T)); | |
3803 | Set_First_Entity (T, E); | |
3804 | ||
3805 | Comp := Next_Entity (E); | |
3806 | while Next_Entity (Comp) /= E loop | |
3807 | Next_Entity (Comp); | |
3808 | end loop; | |
3809 | ||
3810 | Set_Next_Entity (Comp, Empty); | |
3811 | Set_Last_Entity (T, Comp); | |
3812 | end; | |
3813 | ||
3814 | End_Scope; | |
fbf5a39b AC |
3815 | |
3816 | exception | |
3817 | when RE_Not_Available => | |
3818 | return; | |
70482933 RK |
3819 | end Expand_Record_Controller; |
3820 | ||
3821 | ------------------------ | |
3822 | -- Expand_Tagged_Root -- | |
3823 | ------------------------ | |
3824 | ||
3825 | procedure Expand_Tagged_Root (T : Entity_Id) is | |
3826 | Def : constant Node_Id := Type_Definition (Parent (T)); | |
3827 | Comp_List : Node_Id; | |
3828 | Comp_Decl : Node_Id; | |
3829 | Sloc_N : Source_Ptr; | |
3830 | ||
3831 | begin | |
3832 | if Null_Present (Def) then | |
3833 | Set_Component_List (Def, | |
3834 | Make_Component_List (Sloc (Def), | |
3835 | Component_Items => Empty_List, | |
3836 | Variant_Part => Empty, | |
3837 | Null_Present => True)); | |
3838 | end if; | |
3839 | ||
3840 | Comp_List := Component_List (Def); | |
3841 | ||
3842 | if Null_Present (Comp_List) | |
3843 | or else Is_Empty_List (Component_Items (Comp_List)) | |
3844 | then | |
3845 | Sloc_N := Sloc (Comp_List); | |
3846 | else | |
3847 | Sloc_N := Sloc (First (Component_Items (Comp_List))); | |
3848 | end if; | |
3849 | ||
3850 | Comp_Decl := | |
3851 | Make_Component_Declaration (Sloc_N, | |
a9d8907c | 3852 | Defining_Identifier => First_Tag_Component (T), |
a397db96 AC |
3853 | Component_Definition => |
3854 | Make_Component_Definition (Sloc_N, | |
3855 | Aliased_Present => False, | |
3856 | Subtype_Indication => New_Reference_To (RTE (RE_Tag), Sloc_N))); | |
70482933 RK |
3857 | |
3858 | if Null_Present (Comp_List) | |
3859 | or else Is_Empty_List (Component_Items (Comp_List)) | |
3860 | then | |
3861 | Set_Component_Items (Comp_List, New_List (Comp_Decl)); | |
3862 | Set_Null_Present (Comp_List, False); | |
3863 | ||
3864 | else | |
3865 | Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); | |
3866 | end if; | |
3867 | ||
3868 | -- We don't Analyze the whole expansion because the tag component has | |
a9d8907c JM |
3869 | -- already been analyzed previously. Here we just insure that the tree |
3870 | -- is coherent with the semantic decoration | |
70482933 | 3871 | |
a397db96 | 3872 | Find_Type (Subtype_Indication (Component_Definition (Comp_Decl))); |
fbf5a39b AC |
3873 | |
3874 | exception | |
3875 | when RE_Not_Available => | |
3876 | return; | |
70482933 RK |
3877 | end Expand_Tagged_Root; |
3878 | ||
3879 | ----------------------- | |
3880 | -- Freeze_Array_Type -- | |
3881 | ----------------------- | |
3882 | ||
3883 | procedure Freeze_Array_Type (N : Node_Id) is | |
3884 | Typ : constant Entity_Id := Entity (N); | |
3885 | Base : constant Entity_Id := Base_Type (Typ); | |
3886 | ||
3887 | begin | |
70482933 RK |
3888 | if not Is_Bit_Packed_Array (Typ) then |
3889 | ||
a9d8907c JM |
3890 | -- If the component contains tasks, so does the array type. This may |
3891 | -- not be indicated in the array type because the component may have | |
3892 | -- been a private type at the point of definition. Same if component | |
3893 | -- type is controlled. | |
70482933 RK |
3894 | |
3895 | Set_Has_Task (Base, Has_Task (Component_Type (Typ))); | |
3896 | Set_Has_Controlled_Component (Base, | |
3897 | Has_Controlled_Component (Component_Type (Typ)) | |
3898 | or else Is_Controlled (Component_Type (Typ))); | |
3899 | ||
3900 | if No (Init_Proc (Base)) then | |
3901 | ||
a9d8907c JM |
3902 | -- If this is an anonymous array created for a declaration with |
3903 | -- an initial value, its init_proc will never be called. The | |
3904 | -- initial value itself may have been expanded into assign- | |
70482933 RK |
3905 | -- ments, in which case the object declaration is carries the |
3906 | -- No_Initialization flag. | |
3907 | ||
3908 | if Is_Itype (Base) | |
3909 | and then Nkind (Associated_Node_For_Itype (Base)) = | |
3910 | N_Object_Declaration | |
3911 | and then (Present (Expression (Associated_Node_For_Itype (Base))) | |
3912 | or else | |
3913 | No_Initialization (Associated_Node_For_Itype (Base))) | |
3914 | then | |
3915 | null; | |
3916 | ||
82c80734 RD |
3917 | -- We do not need an init proc for string or wide [wide] string, |
3918 | -- since the only time these need initialization in normalize or | |
70482933 RK |
3919 | -- initialize scalars mode, and these types are treated specially |
3920 | -- and do not need initialization procedures. | |
3921 | ||
ecad994d AC |
3922 | elsif Root_Type (Base) = Standard_String |
3923 | or else Root_Type (Base) = Standard_Wide_String | |
82c80734 | 3924 | or else Root_Type (Base) = Standard_Wide_Wide_String |
70482933 RK |
3925 | then |
3926 | null; | |
3927 | ||
3928 | -- Otherwise we have to build an init proc for the subtype | |
3929 | ||
3930 | else | |
3931 | Build_Array_Init_Proc (Base, N); | |
3932 | end if; | |
3933 | end if; | |
3934 | ||
3935 | if Typ = Base and then Has_Controlled_Component (Base) then | |
3936 | Build_Controlling_Procs (Base); | |
26fd4eae AC |
3937 | |
3938 | if not Is_Limited_Type (Component_Type (Typ)) | |
3939 | and then Number_Dimensions (Typ) = 1 | |
3940 | then | |
3941 | Build_Slice_Assignment (Typ); | |
3942 | end if; | |
70482933 | 3943 | end if; |
fbf5a39b | 3944 | |
a9d8907c JM |
3945 | -- For packed case, there is a default initialization, except if the |
3946 | -- component type is itself a packed structure with an initialization | |
3947 | -- procedure. | |
fbf5a39b AC |
3948 | |
3949 | elsif Present (Init_Proc (Component_Type (Base))) | |
3950 | and then No (Base_Init_Proc (Base)) | |
3951 | then | |
3952 | Build_Array_Init_Proc (Base, N); | |
70482933 RK |
3953 | end if; |
3954 | end Freeze_Array_Type; | |
3955 | ||
3956 | ----------------------------- | |
3957 | -- Freeze_Enumeration_Type -- | |
3958 | ----------------------------- | |
3959 | ||
3960 | procedure Freeze_Enumeration_Type (N : Node_Id) is | |
fbf5a39b AC |
3961 | Typ : constant Entity_Id := Entity (N); |
3962 | Loc : constant Source_Ptr := Sloc (Typ); | |
3963 | Ent : Entity_Id; | |
3964 | Lst : List_Id; | |
3965 | Num : Nat; | |
3966 | Arr : Entity_Id; | |
3967 | Fent : Entity_Id; | |
3968 | Ityp : Entity_Id; | |
3969 | Is_Contiguous : Boolean; | |
3970 | Pos_Expr : Node_Id; | |
3971 | Last_Repval : Uint; | |
3972 | ||
70482933 | 3973 | Func : Entity_Id; |
fbf5a39b | 3974 | pragma Warnings (Off, Func); |
70482933 RK |
3975 | |
3976 | begin | |
a9d8907c JM |
3977 | -- Various optimization are possible if the given representation is |
3978 | -- contiguous. | |
70482933 | 3979 | |
fbf5a39b | 3980 | Is_Contiguous := True; |
70482933 | 3981 | Ent := First_Literal (Typ); |
fbf5a39b AC |
3982 | Last_Repval := Enumeration_Rep (Ent); |
3983 | Next_Literal (Ent); | |
3984 | ||
70482933 | 3985 | while Present (Ent) loop |
fbf5a39b AC |
3986 | if Enumeration_Rep (Ent) - Last_Repval /= 1 then |
3987 | Is_Contiguous := False; | |
3988 | exit; | |
3989 | else | |
3990 | Last_Repval := Enumeration_Rep (Ent); | |
3991 | end if; | |
3992 | ||
70482933 RK |
3993 | Next_Literal (Ent); |
3994 | end loop; | |
3995 | ||
fbf5a39b AC |
3996 | if Is_Contiguous then |
3997 | Set_Has_Contiguous_Rep (Typ); | |
3998 | Ent := First_Literal (Typ); | |
3999 | Num := 1; | |
4000 | Lst := New_List (New_Reference_To (Ent, Sloc (Ent))); | |
4001 | ||
4002 | else | |
4003 | -- Build list of literal references | |
4004 | ||
4005 | Lst := New_List; | |
4006 | Num := 0; | |
4007 | ||
4008 | Ent := First_Literal (Typ); | |
4009 | while Present (Ent) loop | |
4010 | Append_To (Lst, New_Reference_To (Ent, Sloc (Ent))); | |
4011 | Num := Num + 1; | |
4012 | Next_Literal (Ent); | |
4013 | end loop; | |
4014 | end if; | |
4015 | ||
a5b62485 | 4016 | -- Now build an array declaration |
70482933 RK |
4017 | |
4018 | -- typA : array (Natural range 0 .. num - 1) of ctype := | |
fbf5a39b | 4019 | -- (v, v, v, v, v, ....) |
70482933 | 4020 | |
a9d8907c JM |
4021 | -- where ctype is the corresponding integer type. If the representation |
4022 | -- is contiguous, we only keep the first literal, which provides the | |
4023 | -- offset for Pos_To_Rep computations. | |
70482933 RK |
4024 | |
4025 | Arr := | |
4026 | Make_Defining_Identifier (Loc, | |
4027 | Chars => New_External_Name (Chars (Typ), 'A')); | |
4028 | ||
4029 | Append_Freeze_Action (Typ, | |
4030 | Make_Object_Declaration (Loc, | |
4031 | Defining_Identifier => Arr, | |
4032 | Constant_Present => True, | |
4033 | ||
4034 | Object_Definition => | |
4035 | Make_Constrained_Array_Definition (Loc, | |
4036 | Discrete_Subtype_Definitions => New_List ( | |
4037 | Make_Subtype_Indication (Loc, | |
4038 | Subtype_Mark => New_Reference_To (Standard_Natural, Loc), | |
4039 | Constraint => | |
4040 | Make_Range_Constraint (Loc, | |
4041 | Range_Expression => | |
4042 | Make_Range (Loc, | |
4043 | Low_Bound => | |
4044 | Make_Integer_Literal (Loc, 0), | |
4045 | High_Bound => | |
4046 | Make_Integer_Literal (Loc, Num - 1))))), | |
4047 | ||
a397db96 AC |
4048 | Component_Definition => |
4049 | Make_Component_Definition (Loc, | |
4050 | Aliased_Present => False, | |
4051 | Subtype_Indication => New_Reference_To (Typ, Loc))), | |
70482933 RK |
4052 | |
4053 | Expression => | |
4054 | Make_Aggregate (Loc, | |
4055 | Expressions => Lst))); | |
4056 | ||
4057 | Set_Enum_Pos_To_Rep (Typ, Arr); | |
4058 | ||
4059 | -- Now we build the function that converts representation values to | |
4060 | -- position values. This function has the form: | |
4061 | ||
4062 | -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is | |
4063 | -- begin | |
4064 | -- case ityp!(A) is | |
4065 | -- when enum-lit'Enum_Rep => return posval; | |
4066 | -- when enum-lit'Enum_Rep => return posval; | |
4067 | -- ... | |
4068 | -- when others => | |
fbf5a39b | 4069 | -- [raise Constraint_Error when F "invalid data"] |
70482933 RK |
4070 | -- return -1; |
4071 | -- end case; | |
4072 | -- end; | |
4073 | ||
4074 | -- Note: the F parameter determines whether the others case (no valid | |
fbf5a39b AC |
4075 | -- representation) raises Constraint_Error or returns a unique value |
4076 | -- of minus one. The latter case is used, e.g. in 'Valid code. | |
70482933 | 4077 | |
a9d8907c JM |
4078 | -- Note: the reason we use Enum_Rep values in the case here is to avoid |
4079 | -- the code generator making inappropriate assumptions about the range | |
4080 | -- of the values in the case where the value is invalid. ityp is a | |
4081 | -- signed or unsigned integer type of appropriate width. | |
70482933 | 4082 | |
fbf5a39b AC |
4083 | -- Note: if exceptions are not supported, then we suppress the raise |
4084 | -- and return -1 unconditionally (this is an erroneous program in any | |
a9d8907c JM |
4085 | -- case and there is no obligation to raise Constraint_Error here!) We |
4086 | -- also do this if pragma Restrictions (No_Exceptions) is active. | |
70482933 | 4087 | |
fbf5a39b | 4088 | -- Representations are signed |
70482933 | 4089 | |
fbf5a39b | 4090 | if Enumeration_Rep (First_Literal (Typ)) < 0 then |
70482933 | 4091 | |
fbf5a39b | 4092 | -- The underlying type is signed. Reset the Is_Unsigned_Type |
a9d8907c | 4093 | -- explicitly, because it might have been inherited from |
fbf5a39b | 4094 | -- parent type. |
70482933 | 4095 | |
fbf5a39b | 4096 | Set_Is_Unsigned_Type (Typ, False); |
70482933 | 4097 | |
70482933 RK |
4098 | if Esize (Typ) <= Standard_Integer_Size then |
4099 | Ityp := Standard_Integer; | |
4100 | else | |
4101 | Ityp := Universal_Integer; | |
4102 | end if; | |
4103 | ||
4104 | -- Representations are unsigned | |
4105 | ||
4106 | else | |
4107 | if Esize (Typ) <= Standard_Integer_Size then | |
4108 | Ityp := RTE (RE_Unsigned); | |
4109 | else | |
4110 | Ityp := RTE (RE_Long_Long_Unsigned); | |
4111 | end if; | |
4112 | end if; | |
4113 | ||
a9d8907c JM |
4114 | -- The body of the function is a case statement. First collect case |
4115 | -- alternatives, or optimize the contiguous case. | |
fbf5a39b AC |
4116 | |
4117 | Lst := New_List; | |
4118 | ||
4119 | -- If representation is contiguous, Pos is computed by subtracting | |
4120 | -- the representation of the first literal. | |
4121 | ||
4122 | if Is_Contiguous then | |
4123 | Ent := First_Literal (Typ); | |
4124 | ||
4125 | if Enumeration_Rep (Ent) = Last_Repval then | |
4126 | ||
a5b62485 | 4127 | -- Another special case: for a single literal, Pos is zero |
fbf5a39b AC |
4128 | |
4129 | Pos_Expr := Make_Integer_Literal (Loc, Uint_0); | |
4130 | ||
4131 | else | |
4132 | Pos_Expr := | |
4133 | Convert_To (Standard_Integer, | |
4134 | Make_Op_Subtract (Loc, | |
4135 | Left_Opnd => | |
4136 | Unchecked_Convert_To (Ityp, | |
4137 | Make_Identifier (Loc, Name_uA)), | |
4138 | Right_Opnd => | |
4139 | Make_Integer_Literal (Loc, | |
4140 | Intval => | |
4141 | Enumeration_Rep (First_Literal (Typ))))); | |
4142 | end if; | |
4143 | ||
4144 | Append_To (Lst, | |
4145 | Make_Case_Statement_Alternative (Loc, | |
4146 | Discrete_Choices => New_List ( | |
4147 | Make_Range (Sloc (Enumeration_Rep_Expr (Ent)), | |
4148 | Low_Bound => | |
4149 | Make_Integer_Literal (Loc, | |
4150 | Intval => Enumeration_Rep (Ent)), | |
4151 | High_Bound => | |
4152 | Make_Integer_Literal (Loc, Intval => Last_Repval))), | |
4153 | ||
4154 | Statements => New_List ( | |
4155 | Make_Return_Statement (Loc, | |
4156 | Expression => Pos_Expr)))); | |
4157 | ||
4158 | else | |
4159 | Ent := First_Literal (Typ); | |
4160 | ||
4161 | while Present (Ent) loop | |
4162 | Append_To (Lst, | |
4163 | Make_Case_Statement_Alternative (Loc, | |
4164 | Discrete_Choices => New_List ( | |
4165 | Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)), | |
4166 | Intval => Enumeration_Rep (Ent))), | |
4167 | ||
4168 | Statements => New_List ( | |
4169 | Make_Return_Statement (Loc, | |
4170 | Expression => | |
4171 | Make_Integer_Literal (Loc, | |
4172 | Intval => Enumeration_Pos (Ent)))))); | |
4173 | ||
4174 | Next_Literal (Ent); | |
4175 | end loop; | |
4176 | end if; | |
4177 | ||
70482933 RK |
4178 | -- In normal mode, add the others clause with the test |
4179 | ||
6e937c1c | 4180 | if not Restriction_Active (No_Exception_Handlers) then |
70482933 RK |
4181 | Append_To (Lst, |
4182 | Make_Case_Statement_Alternative (Loc, | |
4183 | Discrete_Choices => New_List (Make_Others_Choice (Loc)), | |
4184 | Statements => New_List ( | |
fbf5a39b | 4185 | Make_Raise_Constraint_Error (Loc, |
07fc65c4 | 4186 | Condition => Make_Identifier (Loc, Name_uF), |
fbf5a39b | 4187 | Reason => CE_Invalid_Data), |
70482933 RK |
4188 | Make_Return_Statement (Loc, |
4189 | Expression => | |
4190 | Make_Integer_Literal (Loc, -1))))); | |
4191 | ||
fbf5a39b AC |
4192 | -- If Restriction (No_Exceptions_Handlers) is active then we always |
4193 | -- return -1 (since we cannot usefully raise Constraint_Error in | |
4194 | -- this case). See description above for further details. | |
70482933 RK |
4195 | |
4196 | else | |
4197 | Append_To (Lst, | |
4198 | Make_Case_Statement_Alternative (Loc, | |
4199 | Discrete_Choices => New_List (Make_Others_Choice (Loc)), | |
4200 | Statements => New_List ( | |
4201 | Make_Return_Statement (Loc, | |
4202 | Expression => | |
4203 | Make_Integer_Literal (Loc, -1))))); | |
4204 | end if; | |
4205 | ||
4206 | -- Now we can build the function body | |
4207 | ||
4208 | Fent := | |
fbf5a39b | 4209 | Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos)); |
70482933 RK |
4210 | |
4211 | Func := | |
4212 | Make_Subprogram_Body (Loc, | |
4213 | Specification => | |
4214 | Make_Function_Specification (Loc, | |
4215 | Defining_Unit_Name => Fent, | |
4216 | Parameter_Specifications => New_List ( | |
4217 | Make_Parameter_Specification (Loc, | |
4218 | Defining_Identifier => | |
4219 | Make_Defining_Identifier (Loc, Name_uA), | |
4220 | Parameter_Type => New_Reference_To (Typ, Loc)), | |
4221 | Make_Parameter_Specification (Loc, | |
4222 | Defining_Identifier => | |
4223 | Make_Defining_Identifier (Loc, Name_uF), | |
4224 | Parameter_Type => New_Reference_To (Standard_Boolean, Loc))), | |
4225 | ||
4226 | Subtype_Mark => New_Reference_To (Standard_Integer, Loc)), | |
4227 | ||
4228 | Declarations => Empty_List, | |
4229 | ||
4230 | Handled_Statement_Sequence => | |
4231 | Make_Handled_Sequence_Of_Statements (Loc, | |
4232 | Statements => New_List ( | |
4233 | Make_Case_Statement (Loc, | |
4234 | Expression => | |
4235 | Unchecked_Convert_To (Ityp, | |
4236 | Make_Identifier (Loc, Name_uA)), | |
4237 | Alternatives => Lst)))); | |
4238 | ||
4239 | Set_TSS (Typ, Fent); | |
4240 | Set_Is_Pure (Fent); | |
4241 | ||
4242 | if not Debug_Generated_Code then | |
4243 | Set_Debug_Info_Off (Fent); | |
4244 | end if; | |
fbf5a39b AC |
4245 | |
4246 | exception | |
4247 | when RE_Not_Available => | |
4248 | return; | |
70482933 RK |
4249 | end Freeze_Enumeration_Type; |
4250 | ||
4251 | ------------------------ | |
4252 | -- Freeze_Record_Type -- | |
4253 | ------------------------ | |
4254 | ||
4255 | procedure Freeze_Record_Type (N : Node_Id) is | |
4256 | Def_Id : constant Node_Id := Entity (N); | |
4257 | Comp : Entity_Id; | |
4258 | Type_Decl : constant Node_Id := Parent (Def_Id); | |
4259 | Predef_List : List_Id; | |
4260 | ||
4261 | Renamed_Eq : Node_Id := Empty; | |
4262 | -- Could use some comments ??? | |
4263 | ||
4264 | begin | |
4265 | -- Build discriminant checking functions if not a derived type (for | |
4266 | -- derived types that are not tagged types, we always use the | |
4267 | -- discriminant checking functions of the parent type). However, for | |
4268 | -- untagged types the derivation may have taken place before the | |
4269 | -- parent was frozen, so we copy explicitly the discriminant checking | |
4270 | -- functions from the parent into the components of the derived type. | |
4271 | ||
4272 | if not Is_Derived_Type (Def_Id) | |
4273 | or else Has_New_Non_Standard_Rep (Def_Id) | |
4274 | or else Is_Tagged_Type (Def_Id) | |
4275 | then | |
4276 | Build_Discr_Checking_Funcs (Type_Decl); | |
4277 | ||
4278 | elsif Is_Derived_Type (Def_Id) | |
4279 | and then not Is_Tagged_Type (Def_Id) | |
5d09245e AC |
4280 | |
4281 | -- If we have a derived Unchecked_Union, we do not inherit the | |
4282 | -- discriminant checking functions from the parent type since the | |
4283 | -- discriminants are non existent. | |
4284 | ||
4285 | and then not Is_Unchecked_Union (Def_Id) | |
70482933 RK |
4286 | and then Has_Discriminants (Def_Id) |
4287 | then | |
4288 | declare | |
4289 | Old_Comp : Entity_Id; | |
4290 | ||
4291 | begin | |
4292 | Old_Comp := | |
4293 | First_Component (Base_Type (Underlying_Type (Etype (Def_Id)))); | |
4294 | Comp := First_Component (Def_Id); | |
70482933 RK |
4295 | while Present (Comp) loop |
4296 | if Ekind (Comp) = E_Component | |
4297 | and then Chars (Comp) = Chars (Old_Comp) | |
4298 | then | |
4299 | Set_Discriminant_Checking_Func (Comp, | |
4300 | Discriminant_Checking_Func (Old_Comp)); | |
4301 | end if; | |
4302 | ||
4303 | Next_Component (Old_Comp); | |
4304 | Next_Component (Comp); | |
4305 | end loop; | |
4306 | end; | |
4307 | end if; | |
4308 | ||
07fc65c4 GB |
4309 | if Is_Derived_Type (Def_Id) |
4310 | and then Is_Limited_Type (Def_Id) | |
4311 | and then Is_Tagged_Type (Def_Id) | |
4312 | then | |
4313 | Check_Stream_Attributes (Def_Id); | |
4314 | end if; | |
4315 | ||
70482933 RK |
4316 | -- Update task and controlled component flags, because some of the |
4317 | -- component types may have been private at the point of the record | |
4318 | -- declaration. | |
4319 | ||
4320 | Comp := First_Component (Def_Id); | |
4321 | ||
4322 | while Present (Comp) loop | |
4323 | if Has_Task (Etype (Comp)) then | |
4324 | Set_Has_Task (Def_Id); | |
4325 | ||
4326 | elsif Has_Controlled_Component (Etype (Comp)) | |
4327 | or else (Chars (Comp) /= Name_uParent | |
4328 | and then Is_Controlled (Etype (Comp))) | |
4329 | then | |
4330 | Set_Has_Controlled_Component (Def_Id); | |
4331 | end if; | |
4332 | ||
4333 | Next_Component (Comp); | |
4334 | end loop; | |
4335 | ||
4336 | -- Creation of the Dispatch Table. Note that a Dispatch Table is | |
a9d8907c JM |
4337 | -- created for regular tagged types as well as for Ada types deriving |
4338 | -- from a C++ Class, but not for tagged types directly corresponding to | |
4339 | -- the C++ classes. In the later case we assume that the Vtable is | |
4340 | -- created in the C++ side and we just use it. | |
70482933 RK |
4341 | |
4342 | if Is_Tagged_Type (Def_Id) then | |
70482933 RK |
4343 | if Is_CPP_Class (Def_Id) then |
4344 | Set_All_DT_Position (Def_Id); | |
4345 | Set_Default_Constructor (Def_Id); | |
4346 | ||
4347 | else | |
a9d8907c JM |
4348 | -- Usually inherited primitives are not delayed but the first Ada |
4349 | -- extension of a CPP_Class is an exception since the address of | |
4350 | -- the inherited subprogram has to be inserted in the new Ada | |
4351 | -- Dispatch Table and this is a freezing action (usually the | |
4352 | -- inherited primitive address is inserted in the DT by | |
4353 | -- Inherit_DT) | |
4354 | ||
4355 | -- Similarly, if this is an inherited operation whose parent is | |
4356 | -- not frozen yet, it is not in the DT of the parent, and we | |
4357 | -- generate an explicit freeze node for the inherited operation, | |
4358 | -- so that it is properly inserted in the DT of the current type. | |
70482933 | 4359 | |
e6f69614 AC |
4360 | declare |
4361 | Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id)); | |
4362 | Subp : Entity_Id; | |
4363 | ||
4364 | begin | |
4365 | while Present (Elmt) loop | |
4366 | Subp := Node (Elmt); | |
4367 | ||
4368 | if Present (Alias (Subp)) then | |
4369 | if Is_CPP_Class (Etype (Def_Id)) then | |
4370 | Set_Has_Delayed_Freeze (Subp); | |
70482933 | 4371 | |
e6f69614 AC |
4372 | elsif Has_Delayed_Freeze (Alias (Subp)) |
4373 | and then not Is_Frozen (Alias (Subp)) | |
4374 | then | |
4375 | Set_Is_Frozen (Subp, False); | |
70482933 RK |
4376 | Set_Has_Delayed_Freeze (Subp); |
4377 | end if; | |
e6f69614 | 4378 | end if; |
70482933 | 4379 | |
e6f69614 AC |
4380 | Next_Elmt (Elmt); |
4381 | end loop; | |
4382 | end; | |
70482933 RK |
4383 | |
4384 | if Underlying_Type (Etype (Def_Id)) = Def_Id then | |
4385 | Expand_Tagged_Root (Def_Id); | |
4386 | end if; | |
4387 | ||
a9d8907c JM |
4388 | -- Unfreeze momentarily the type to add the predefined primitives |
4389 | -- operations. The reason we unfreeze is so that these predefined | |
4390 | -- operations will indeed end up as primitive operations (which | |
4391 | -- must be before the freeze point). | |
70482933 RK |
4392 | |
4393 | Set_Is_Frozen (Def_Id, False); | |
4394 | Make_Predefined_Primitive_Specs | |
4395 | (Def_Id, Predef_List, Renamed_Eq); | |
4396 | Insert_List_Before_And_Analyze (N, Predef_List); | |
4397 | Set_Is_Frozen (Def_Id, True); | |
4398 | Set_All_DT_Position (Def_Id); | |
4399 | ||
4400 | -- Add the controlled component before the freezing actions | |
a9d8907c | 4401 | -- referenced in those actions. |
70482933 RK |
4402 | |
4403 | if Has_New_Controlled_Component (Def_Id) then | |
4404 | Expand_Record_Controller (Def_Id); | |
4405 | end if; | |
4406 | ||
a9d8907c JM |
4407 | -- Suppress creation of a dispatch table when Java_VM because the |
4408 | -- dispatching mechanism is handled internally by the JVM. | |
70482933 RK |
4409 | |
4410 | if not Java_VM then | |
4411 | Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); | |
4412 | end if; | |
4413 | ||
a9d8907c JM |
4414 | -- Make sure that the primitives Initialize, Adjust and Finalize |
4415 | -- are Frozen before other TSS subprograms. We don't want them | |
4416 | -- Frozen inside. | |
70482933 RK |
4417 | |
4418 | if Is_Controlled (Def_Id) then | |
4419 | if not Is_Limited_Type (Def_Id) then | |
4420 | Append_Freeze_Actions (Def_Id, | |
4421 | Freeze_Entity | |
4422 | (Find_Prim_Op (Def_Id, Name_Adjust), Sloc (Def_Id))); | |
4423 | end if; | |
4424 | ||
4425 | Append_Freeze_Actions (Def_Id, | |
4426 | Freeze_Entity | |
4427 | (Find_Prim_Op (Def_Id, Name_Initialize), Sloc (Def_Id))); | |
4428 | ||
4429 | Append_Freeze_Actions (Def_Id, | |
4430 | Freeze_Entity | |
4431 | (Find_Prim_Op (Def_Id, Name_Finalize), Sloc (Def_Id))); | |
4432 | end if; | |
4433 | ||
4434 | -- Freeze rest of primitive operations | |
4435 | ||
4436 | Append_Freeze_Actions | |
4437 | (Def_Id, Predefined_Primitive_Freeze (Def_Id)); | |
4438 | end if; | |
4439 | ||
a9d8907c JM |
4440 | -- In the non-tagged case, an equality function is provided only for |
4441 | -- variant records (that are not unchecked unions). | |
70482933 RK |
4442 | |
4443 | elsif Has_Discriminants (Def_Id) | |
4444 | and then not Is_Limited_Type (Def_Id) | |
4445 | then | |
4446 | declare | |
4447 | Comps : constant Node_Id := | |
4448 | Component_List (Type_Definition (Type_Decl)); | |
4449 | ||
4450 | begin | |
4451 | if Present (Comps) | |
4452 | and then Present (Variant_Part (Comps)) | |
70482933 RK |
4453 | then |
4454 | Build_Variant_Record_Equality (Def_Id); | |
4455 | end if; | |
4456 | end; | |
4457 | end if; | |
4458 | ||
4459 | -- Before building the record initialization procedure, if we are | |
a9d8907c JM |
4460 | -- dealing with a concurrent record value type, then we must go through |
4461 | -- the discriminants, exchanging discriminals between the concurrent | |
4462 | -- type and the concurrent record value type. See the section "Handling | |
4463 | -- of Discriminants" in the Einfo spec for details. | |
70482933 RK |
4464 | |
4465 | if Is_Concurrent_Record_Type (Def_Id) | |
4466 | and then Has_Discriminants (Def_Id) | |
4467 | then | |
4468 | declare | |
4469 | Ctyp : constant Entity_Id := | |
4470 | Corresponding_Concurrent_Type (Def_Id); | |
4471 | Conc_Discr : Entity_Id; | |
4472 | Rec_Discr : Entity_Id; | |
4473 | Temp : Entity_Id; | |
4474 | ||
4475 | begin | |
4476 | Conc_Discr := First_Discriminant (Ctyp); | |
4477 | Rec_Discr := First_Discriminant (Def_Id); | |
4478 | ||
4479 | while Present (Conc_Discr) loop | |
4480 | Temp := Discriminal (Conc_Discr); | |
4481 | Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); | |
4482 | Set_Discriminal (Rec_Discr, Temp); | |
4483 | ||
4484 | Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); | |
4485 | Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); | |
4486 | ||
4487 | Next_Discriminant (Conc_Discr); | |
4488 | Next_Discriminant (Rec_Discr); | |
4489 | end loop; | |
4490 | end; | |
4491 | end if; | |
4492 | ||
4493 | if Has_Controlled_Component (Def_Id) then | |
4494 | if No (Controller_Component (Def_Id)) then | |
4495 | Expand_Record_Controller (Def_Id); | |
4496 | end if; | |
4497 | ||
4498 | Build_Controlling_Procs (Def_Id); | |
4499 | end if; | |
4500 | ||
4501 | Adjust_Discriminants (Def_Id); | |
4502 | Build_Record_Init_Proc (Type_Decl, Def_Id); | |
4503 | ||
a9d8907c JM |
4504 | -- For tagged type, build bodies of primitive operations. Note that we |
4505 | -- do this after building the record initialization experiment, since | |
4506 | -- the primitive operations may need the initialization routine | |
70482933 RK |
4507 | |
4508 | if Is_Tagged_Type (Def_Id) then | |
4509 | Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); | |
4510 | Append_Freeze_Actions (Def_Id, Predef_List); | |
4511 | end if; | |
4512 | ||
4513 | end Freeze_Record_Type; | |
4514 | ||
07fc65c4 GB |
4515 | ------------------------------ |
4516 | -- Freeze_Stream_Operations -- | |
4517 | ------------------------------ | |
4518 | ||
4519 | procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is | |
fbf5a39b AC |
4520 | Names : constant array (1 .. 4) of TSS_Name_Type := |
4521 | (TSS_Stream_Input, | |
4522 | TSS_Stream_Output, | |
4523 | TSS_Stream_Read, | |
4524 | TSS_Stream_Write); | |
07fc65c4 GB |
4525 | Stream_Op : Entity_Id; |
4526 | ||
4527 | begin | |
4528 | -- Primitive operations of tagged types are frozen when the dispatch | |
4529 | -- table is constructed. | |
4530 | ||
4531 | if not Comes_From_Source (Typ) | |
4532 | or else Is_Tagged_Type (Typ) | |
4533 | then | |
4534 | return; | |
4535 | end if; | |
4536 | ||
4537 | for J in Names'Range loop | |
4538 | Stream_Op := TSS (Typ, Names (J)); | |
4539 | ||
4540 | if Present (Stream_Op) | |
4541 | and then Is_Subprogram (Stream_Op) | |
4542 | and then Nkind (Unit_Declaration_Node (Stream_Op)) = | |
4543 | N_Subprogram_Declaration | |
4544 | and then not Is_Frozen (Stream_Op) | |
4545 | then | |
4546 | Append_Freeze_Actions | |
4547 | (Typ, Freeze_Entity (Stream_Op, Sloc (N))); | |
4548 | end if; | |
4549 | end loop; | |
4550 | end Freeze_Stream_Operations; | |
4551 | ||
70482933 RK |
4552 | ----------------- |
4553 | -- Freeze_Type -- | |
4554 | ----------------- | |
4555 | ||
a9d8907c JM |
4556 | -- Full type declarations are expanded at the point at which the type is |
4557 | -- frozen. The formal N is the Freeze_Node for the type. Any statements or | |
4558 | -- declarations generated by the freezing (e.g. the procedure generated | |
70482933 RK |
4559 | -- for initialization) are chained in the Acions field list of the freeze |
4560 | -- node using Append_Freeze_Actions. | |
4561 | ||
a9d8907c | 4562 | function Freeze_Type (N : Node_Id) return Boolean is |
fbf5a39b AC |
4563 | Def_Id : constant Entity_Id := Entity (N); |
4564 | RACW_Seen : Boolean := False; | |
a9d8907c | 4565 | Result : Boolean := False; |
70482933 RK |
4566 | |
4567 | begin | |
4568 | -- Process associated access types needing special processing | |
4569 | ||
4570 | if Present (Access_Types_To_Process (N)) then | |
4571 | declare | |
4572 | E : Elmt_Id := First_Elmt (Access_Types_To_Process (N)); | |
4573 | begin | |
4574 | while Present (E) loop | |
4575 | ||
70482933 | 4576 | if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then |
fbf5a39b | 4577 | RACW_Seen := True; |
70482933 RK |
4578 | end if; |
4579 | ||
4580 | E := Next_Elmt (E); | |
4581 | end loop; | |
4582 | end; | |
fbf5a39b AC |
4583 | |
4584 | if RACW_Seen then | |
4585 | ||
a5b62485 | 4586 | -- If there are RACWs designating this type, make stubs now |
fbf5a39b AC |
4587 | |
4588 | Remote_Types_Tagged_Full_View_Encountered (Def_Id); | |
4589 | end if; | |
70482933 RK |
4590 | end if; |
4591 | ||
4592 | -- Freeze processing for record types | |
4593 | ||
4594 | if Is_Record_Type (Def_Id) then | |
4595 | if Ekind (Def_Id) = E_Record_Type then | |
4596 | Freeze_Record_Type (N); | |
4597 | ||
a9d8907c JM |
4598 | -- The subtype may have been declared before the type was frozen. If |
4599 | -- the type has controlled components it is necessary to create the | |
4600 | -- entity for the controller explicitly because it did not exist at | |
4601 | -- the point of the subtype declaration. Only the entity is needed, | |
4602 | -- the back-end will obtain the layout from the type. This is only | |
4603 | -- necessary if this is constrained subtype whose component list is | |
4604 | -- not shared with the base type. | |
70482933 RK |
4605 | |
4606 | elsif Ekind (Def_Id) = E_Record_Subtype | |
4607 | and then Has_Discriminants (Def_Id) | |
4608 | and then Last_Entity (Def_Id) /= Last_Entity (Base_Type (Def_Id)) | |
4609 | and then Present (Controller_Component (Def_Id)) | |
4610 | then | |
4611 | declare | |
fbf5a39b | 4612 | Old_C : constant Entity_Id := Controller_Component (Def_Id); |
70482933 RK |
4613 | New_C : Entity_Id; |
4614 | ||
4615 | begin | |
4616 | if Scope (Old_C) = Base_Type (Def_Id) then | |
4617 | ||
a5b62485 | 4618 | -- The entity is the one in the parent. Create new one |
70482933 RK |
4619 | |
4620 | New_C := New_Copy (Old_C); | |
4621 | Set_Parent (New_C, Parent (Old_C)); | |
4622 | New_Scope (Def_Id); | |
4623 | Enter_Name (New_C); | |
4624 | End_Scope; | |
4625 | end if; | |
4626 | end; | |
fbf5a39b | 4627 | |
a9d8907c JM |
4628 | if Is_Itype (Def_Id) |
4629 | and then Is_Record_Type (Underlying_Type (Scope (Def_Id))) | |
4630 | then | |
4631 | -- The freeze node is only used to introduce the controller, | |
4632 | -- the back-end has no use for it for a discriminated | |
4633 | -- component. | |
4634 | ||
4635 | Set_Freeze_Node (Def_Id, Empty); | |
4636 | Set_Has_Delayed_Freeze (Def_Id, False); | |
4637 | Result := True; | |
4638 | end if; | |
4639 | ||
4640 | -- Similar process if the controller of the subtype is not present | |
4641 | -- but the parent has it. This can happen with constrained | |
fbf5a39b AC |
4642 | -- record components where the subtype is an itype. |
4643 | ||
4644 | elsif Ekind (Def_Id) = E_Record_Subtype | |
4645 | and then Is_Itype (Def_Id) | |
4646 | and then No (Controller_Component (Def_Id)) | |
4647 | and then Present (Controller_Component (Etype (Def_Id))) | |
4648 | then | |
4649 | declare | |
4650 | Old_C : constant Entity_Id := | |
4651 | Controller_Component (Etype (Def_Id)); | |
4652 | New_C : constant Entity_Id := New_Copy (Old_C); | |
4653 | ||
4654 | begin | |
4655 | Set_Next_Entity (New_C, First_Entity (Def_Id)); | |
4656 | Set_First_Entity (Def_Id, New_C); | |
4657 | ||
4658 | -- The freeze node is only used to introduce the controller, | |
4659 | -- the back-end has no use for it for a discriminated | |
4660 | -- component. | |
4661 | ||
4662 | Set_Freeze_Node (Def_Id, Empty); | |
4663 | Set_Has_Delayed_Freeze (Def_Id, False); | |
a9d8907c | 4664 | Result := True; |
fbf5a39b | 4665 | end; |
70482933 RK |
4666 | end if; |
4667 | ||
4668 | -- Freeze processing for array types | |
4669 | ||
4670 | elsif Is_Array_Type (Def_Id) then | |
4671 | Freeze_Array_Type (N); | |
4672 | ||
4673 | -- Freeze processing for access types | |
4674 | ||
4675 | -- For pool-specific access types, find out the pool object used for | |
4676 | -- this type, needs actual expansion of it in some cases. Here are the | |
4677 | -- different cases : | |
4678 | ||
4679 | -- 1. Rep Clause "for Def_Id'Storage_Size use 0;" | |
4680 | -- ---> don't use any storage pool | |
4681 | ||
4682 | -- 2. Rep Clause : for Def_Id'Storage_Size use Expr. | |
4683 | -- Expand: | |
4684 | -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment); | |
4685 | ||
4686 | -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" | |
4687 | -- ---> Storage Pool is the specified one | |
4688 | ||
4689 | -- See GNAT Pool packages in the Run-Time for more details | |
4690 | ||
4691 | elsif Ekind (Def_Id) = E_Access_Type | |
4692 | or else Ekind (Def_Id) = E_General_Access_Type | |
4693 | then | |
4694 | declare | |
4695 | Loc : constant Source_Ptr := Sloc (N); | |
4696 | Desig_Type : constant Entity_Id := Designated_Type (Def_Id); | |
4697 | Pool_Object : Entity_Id; | |
4698 | Siz_Exp : Node_Id; | |
4699 | ||
4700 | Freeze_Action_Typ : Entity_Id; | |
4701 | ||
4702 | begin | |
4703 | if Has_Storage_Size_Clause (Def_Id) then | |
4704 | Siz_Exp := Expression (Parent (Storage_Size_Variable (Def_Id))); | |
4705 | else | |
4706 | Siz_Exp := Empty; | |
4707 | end if; | |
4708 | ||
4709 | -- Case 1 | |
4710 | ||
4711 | -- Rep Clause "for Def_Id'Storage_Size use 0;" | |
4712 | -- ---> don't use any storage pool | |
4713 | ||
4714 | if Has_Storage_Size_Clause (Def_Id) | |
4715 | and then Compile_Time_Known_Value (Siz_Exp) | |
4716 | and then Expr_Value (Siz_Exp) = 0 | |
4717 | then | |
4718 | null; | |
4719 | ||
4720 | -- Case 2 | |
4721 | ||
4722 | -- Rep Clause : for Def_Id'Storage_Size use Expr. | |
4723 | -- ---> Expand: | |
4724 | -- Def_Id__Pool : Stack_Bounded_Pool | |
4725 | -- (Expr, DT'Size, DT'Alignment); | |
4726 | ||
4727 | elsif Has_Storage_Size_Clause (Def_Id) then | |
4728 | declare | |
4729 | DT_Size : Node_Id; | |
4730 | DT_Align : Node_Id; | |
4731 | ||
4732 | begin | |
a9d8907c JM |
4733 | -- For unconstrained composite types we give a size of zero |
4734 | -- so that the pool knows that it needs a special algorithm | |
4735 | -- for variable size object allocation. | |
70482933 RK |
4736 | |
4737 | if Is_Composite_Type (Desig_Type) | |
4738 | and then not Is_Constrained (Desig_Type) | |
4739 | then | |
4740 | DT_Size := | |
4741 | Make_Integer_Literal (Loc, 0); | |
4742 | ||
4743 | DT_Align := | |
4744 | Make_Integer_Literal (Loc, Maximum_Alignment); | |
4745 | ||
4746 | else | |
4747 | DT_Size := | |
4748 | Make_Attribute_Reference (Loc, | |
4749 | Prefix => New_Reference_To (Desig_Type, Loc), | |
4750 | Attribute_Name => Name_Max_Size_In_Storage_Elements); | |
4751 | ||
4752 | DT_Align := | |
4753 | Make_Attribute_Reference (Loc, | |
4754 | Prefix => New_Reference_To (Desig_Type, Loc), | |
4755 | Attribute_Name => Name_Alignment); | |
4756 | end if; | |
4757 | ||
4758 | Pool_Object := | |
4759 | Make_Defining_Identifier (Loc, | |
4760 | Chars => New_External_Name (Chars (Def_Id), 'P')); | |
4761 | ||
a9d8907c JM |
4762 | -- We put the code associated with the pools in the entity |
4763 | -- that has the later freeze node, usually the acces type | |
4764 | -- but it can also be the designated_type; because the pool | |
4765 | -- code requires both those types to be frozen | |
70482933 RK |
4766 | |
4767 | if Is_Frozen (Desig_Type) | |
4768 | and then (not Present (Freeze_Node (Desig_Type)) | |
4769 | or else Analyzed (Freeze_Node (Desig_Type))) | |
4770 | then | |
4771 | Freeze_Action_Typ := Def_Id; | |
4772 | ||
4773 | -- A Taft amendment type cannot get the freeze actions | |
4774 | -- since the full view is not there. | |
4775 | ||
4776 | elsif Is_Incomplete_Or_Private_Type (Desig_Type) | |
4777 | and then No (Full_View (Desig_Type)) | |
4778 | then | |
4779 | Freeze_Action_Typ := Def_Id; | |
4780 | ||
4781 | else | |
4782 | Freeze_Action_Typ := Desig_Type; | |
4783 | end if; | |
4784 | ||
4785 | Append_Freeze_Action (Freeze_Action_Typ, | |
4786 | Make_Object_Declaration (Loc, | |
4787 | Defining_Identifier => Pool_Object, | |
4788 | Object_Definition => | |
4789 | Make_Subtype_Indication (Loc, | |
4790 | Subtype_Mark => | |
4791 | New_Reference_To | |
4792 | (RTE (RE_Stack_Bounded_Pool), Loc), | |
4793 | ||
4794 | Constraint => | |
4795 | Make_Index_Or_Discriminant_Constraint (Loc, | |
4796 | Constraints => New_List ( | |
4797 | ||
4798 | -- First discriminant is the Pool Size | |
4799 | ||
4800 | New_Reference_To ( | |
4801 | Storage_Size_Variable (Def_Id), Loc), | |
4802 | ||
4803 | -- Second discriminant is the element size | |
4804 | ||
4805 | DT_Size, | |
4806 | ||
4807 | -- Third discriminant is the alignment | |
4808 | ||
4809 | DT_Align))))); | |
70482933 RK |
4810 | end; |
4811 | ||
4812 | Set_Associated_Storage_Pool (Def_Id, Pool_Object); | |
4813 | ||
4814 | -- Case 3 | |
4815 | ||
4816 | -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" | |
4817 | -- ---> Storage Pool is the specified one | |
4818 | ||
4819 | elsif Present (Associated_Storage_Pool (Def_Id)) then | |
4820 | ||
4821 | -- Nothing to do the associated storage pool has been attached | |
4822 | -- when analyzing the rep. clause | |
4823 | ||
4824 | null; | |
70482933 RK |
4825 | end if; |
4826 | ||
a9d8907c JM |
4827 | -- For access-to-controlled types (including class-wide types and |
4828 | -- Taft-amendment types which potentially have controlled | |
4829 | -- components), expand the list controller object that will store | |
4830 | -- the dynamically allocated objects. Do not do this | |
70482933 RK |
4831 | -- transformation for expander-generated access types, but do it |
4832 | -- for types that are the full view of types derived from other | |
4833 | -- private types. Also suppress the list controller in the case | |
4834 | -- of a designated type with convention Java, since this is used | |
a9d8907c JM |
4835 | -- when binding to Java API specs, where there's no equivalent of |
4836 | -- a finalization list and we don't want to pull in the | |
70482933 RK |
4837 | -- finalization support if not needed. |
4838 | ||
4839 | if not Comes_From_Source (Def_Id) | |
4840 | and then not Has_Private_Declaration (Def_Id) | |
4841 | then | |
4842 | null; | |
4843 | ||
4844 | elsif (Controlled_Type (Desig_Type) | |
4845 | and then Convention (Desig_Type) /= Convention_Java) | |
fbf5a39b AC |
4846 | or else |
4847 | (Is_Incomplete_Or_Private_Type (Desig_Type) | |
4848 | and then No (Full_View (Desig_Type)) | |
70482933 | 4849 | |
6e937c1c AC |
4850 | -- An exception is made for types defined in the run-time |
4851 | -- because Ada.Tags.Tag itself is such a type and cannot | |
4852 | -- afford this unnecessary overhead that would generates a | |
4853 | -- loop in the expansion scheme... | |
70482933 | 4854 | |
6e937c1c | 4855 | and then not In_Runtime (Def_Id) |
fbf5a39b | 4856 | |
6e937c1c AC |
4857 | -- Another exception is if Restrictions (No_Finalization) |
4858 | -- is active, since then we know nothing is controlled. | |
fbf5a39b | 4859 | |
6e937c1c | 4860 | and then not Restriction_Active (No_Finalization)) |
70482933 RK |
4861 | |
4862 | -- If the designated type is not frozen yet, its controlled | |
4863 | -- status must be retrieved explicitly. | |
4864 | ||
4865 | or else (Is_Array_Type (Desig_Type) | |
4866 | and then not Is_Frozen (Desig_Type) | |
4867 | and then Controlled_Type (Component_Type (Desig_Type))) | |
4868 | then | |
4869 | Set_Associated_Final_Chain (Def_Id, | |
4870 | Make_Defining_Identifier (Loc, | |
4871 | New_External_Name (Chars (Def_Id), 'L'))); | |
4872 | ||
4873 | Append_Freeze_Action (Def_Id, | |
4874 | Make_Object_Declaration (Loc, | |
4875 | Defining_Identifier => Associated_Final_Chain (Def_Id), | |
4876 | Object_Definition => | |
4877 | New_Reference_To (RTE (RE_List_Controller), Loc))); | |
4878 | end if; | |
4879 | end; | |
4880 | ||
4881 | -- Freeze processing for enumeration types | |
4882 | ||
4883 | elsif Ekind (Def_Id) = E_Enumeration_Type then | |
4884 | ||
4885 | -- We only have something to do if we have a non-standard | |
4886 | -- representation (i.e. at least one literal whose pos value | |
4887 | -- is not the same as its representation) | |
4888 | ||
4889 | if Has_Non_Standard_Rep (Def_Id) then | |
4890 | Freeze_Enumeration_Type (N); | |
4891 | end if; | |
4892 | ||
fbf5a39b | 4893 | -- Private types that are completed by a derivation from a private |
70482933 RK |
4894 | -- type have an internally generated full view, that needs to be |
4895 | -- frozen. This must be done explicitly because the two views share | |
4896 | -- the freeze node, and the underlying full view is not visible when | |
4897 | -- the freeze node is analyzed. | |
4898 | ||
4899 | elsif Is_Private_Type (Def_Id) | |
4900 | and then Is_Derived_Type (Def_Id) | |
4901 | and then Present (Full_View (Def_Id)) | |
4902 | and then Is_Itype (Full_View (Def_Id)) | |
4903 | and then Has_Private_Declaration (Full_View (Def_Id)) | |
4904 | and then Freeze_Node (Full_View (Def_Id)) = N | |
4905 | then | |
4906 | Set_Entity (N, Full_View (Def_Id)); | |
a9d8907c | 4907 | Result := Freeze_Type (N); |
70482933 RK |
4908 | Set_Entity (N, Def_Id); |
4909 | ||
a9d8907c JM |
4910 | -- All other types require no expander action. There are such cases |
4911 | -- (e.g. task types and protected types). In such cases, the freeze | |
4912 | -- nodes are there for use by Gigi. | |
70482933 RK |
4913 | |
4914 | end if; | |
07fc65c4 GB |
4915 | |
4916 | Freeze_Stream_Operations (N, Def_Id); | |
a9d8907c | 4917 | return Result; |
fbf5a39b AC |
4918 | |
4919 | exception | |
4920 | when RE_Not_Available => | |
a9d8907c | 4921 | return False; |
70482933 RK |
4922 | end Freeze_Type; |
4923 | ||
4924 | ------------------------- | |
4925 | -- Get_Simple_Init_Val -- | |
4926 | ------------------------- | |
4927 | ||
4928 | function Get_Simple_Init_Val | |
82c80734 RD |
4929 | (T : Entity_Id; |
4930 | Loc : Source_Ptr; | |
4931 | Size : Uint := No_Uint) return Node_Id | |
70482933 RK |
4932 | is |
4933 | Val : Node_Id; | |
70482933 RK |
4934 | Result : Node_Id; |
4935 | Val_RE : RE_Id; | |
4936 | ||
82c80734 RD |
4937 | Size_To_Use : Uint; |
4938 | -- This is the size to be used for computation of the appropriate | |
4939 | -- initial value for the Normalize_Scalars and Initialize_Scalars case. | |
4940 | ||
4941 | Lo_Bound : Uint; | |
4942 | Hi_Bound : Uint; | |
4943 | -- These are the values computed by the procedure Check_Subtype_Bounds | |
4944 | ||
4945 | procedure Check_Subtype_Bounds; | |
a9d8907c JM |
4946 | -- This procedure examines the subtype T, and its ancestor subtypes and |
4947 | -- derived types to determine the best known information about the | |
4948 | -- bounds of the subtype. After the call Lo_Bound is set either to | |
4949 | -- No_Uint if no information can be determined, or to a value which | |
82c80734 RD |
4950 | -- represents a known low bound, i.e. a valid value of the subtype can |
4951 | -- not be less than this value. Hi_Bound is similarly set to a known | |
4952 | -- high bound (valid value cannot be greater than this). | |
4953 | ||
4954 | -------------------------- | |
4955 | -- Check_Subtype_Bounds -- | |
4956 | -------------------------- | |
4957 | ||
4958 | procedure Check_Subtype_Bounds is | |
4959 | ST1 : Entity_Id; | |
4960 | ST2 : Entity_Id; | |
4961 | Lo : Node_Id; | |
4962 | Hi : Node_Id; | |
4963 | Loval : Uint; | |
4964 | Hival : Uint; | |
4965 | ||
4966 | begin | |
4967 | Lo_Bound := No_Uint; | |
4968 | Hi_Bound := No_Uint; | |
4969 | ||
4970 | -- Loop to climb ancestor subtypes and derived types | |
4971 | ||
4972 | ST1 := T; | |
4973 | loop | |
4974 | if not Is_Discrete_Type (ST1) then | |
4975 | return; | |
4976 | end if; | |
4977 | ||
4978 | Lo := Type_Low_Bound (ST1); | |
4979 | Hi := Type_High_Bound (ST1); | |
4980 | ||
4981 | if Compile_Time_Known_Value (Lo) then | |
4982 | Loval := Expr_Value (Lo); | |
4983 | ||
4984 | if Lo_Bound = No_Uint or else Lo_Bound < Loval then | |
4985 | Lo_Bound := Loval; | |
4986 | end if; | |
4987 | end if; | |
4988 | ||
4989 | if Compile_Time_Known_Value (Hi) then | |
4990 | Hival := Expr_Value (Hi); | |
4991 | ||
4992 | if Hi_Bound = No_Uint or else Hi_Bound > Hival then | |
4993 | Hi_Bound := Hival; | |
4994 | end if; | |
4995 | end if; | |
4996 | ||
4997 | ST2 := Ancestor_Subtype (ST1); | |
4998 | ||
4999 | if No (ST2) then | |
5000 | ST2 := Etype (ST1); | |
5001 | end if; | |
5002 | ||
5003 | exit when ST1 = ST2; | |
5004 | ST1 := ST2; | |
5005 | end loop; | |
5006 | end Check_Subtype_Bounds; | |
5007 | ||
5008 | -- Start of processing for Get_Simple_Init_Val | |
5009 | ||
70482933 | 5010 | begin |
07fc65c4 GB |
5011 | -- For a private type, we should always have an underlying type |
5012 | -- (because this was already checked in Needs_Simple_Initialization). | |
a9d8907c JM |
5013 | -- What we do is to get the value for the underlying type and then do |
5014 | -- an Unchecked_Convert to the private type. | |
07fc65c4 GB |
5015 | |
5016 | if Is_Private_Type (T) then | |
82c80734 | 5017 | Val := Get_Simple_Init_Val (Underlying_Type (T), Loc, Size); |
07fc65c4 | 5018 | |
a9d8907c JM |
5019 | -- A special case, if the underlying value is null, then qualify it |
5020 | -- with the underlying type, so that the null is properly typed | |
5021 | -- Similarly, if it is an aggregate it must be qualified, because an | |
5022 | -- unchecked conversion does not provide a context for it. | |
07fc65c4 GB |
5023 | |
5024 | if Nkind (Val) = N_Null | |
5025 | or else Nkind (Val) = N_Aggregate | |
5026 | then | |
5027 | Val := | |
5028 | Make_Qualified_Expression (Loc, | |
5029 | Subtype_Mark => | |
5030 | New_Occurrence_Of (Underlying_Type (T), Loc), | |
5031 | Expression => Val); | |
5032 | end if; | |
5033 | ||
fbf5a39b AC |
5034 | Result := Unchecked_Convert_To (T, Val); |
5035 | ||
5036 | -- Don't truncate result (important for Initialize/Normalize_Scalars) | |
5037 | ||
5038 | if Nkind (Result) = N_Unchecked_Type_Conversion | |
5039 | and then Is_Scalar_Type (Underlying_Type (T)) | |
5040 | then | |
5041 | Set_No_Truncation (Result); | |
5042 | end if; | |
5043 | ||
5044 | return Result; | |
07fc65c4 | 5045 | |
70482933 RK |
5046 | -- For scalars, we must have normalize/initialize scalars case |
5047 | ||
07fc65c4 | 5048 | elsif Is_Scalar_Type (T) then |
70482933 RK |
5049 | pragma Assert (Init_Or_Norm_Scalars); |
5050 | ||
a9d8907c JM |
5051 | -- Compute size of object. If it is given by the caller, we can use |
5052 | -- it directly, otherwise we use Esize (T) as an estimate. As far as | |
5053 | -- we know this covers all cases correctly. | |
82c80734 RD |
5054 | |
5055 | if Size = No_Uint or else Size <= Uint_0 then | |
5056 | Size_To_Use := UI_Max (Uint_1, Esize (T)); | |
5057 | else | |
5058 | Size_To_Use := Size; | |
5059 | end if; | |
5060 | ||
5061 | -- Maximum size to use is 64 bits, since we will create values | |
5062 | -- of type Unsigned_64 and the range must fit this type. | |
5063 | ||
5064 | if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then | |
5065 | Size_To_Use := Uint_64; | |
5066 | end if; | |
5067 | ||
5068 | -- Check known bounds of subtype | |
5069 | ||
5070 | Check_Subtype_Bounds; | |
5071 | ||
70482933 RK |
5072 | -- Processing for Normalize_Scalars case |
5073 | ||
5074 | if Normalize_Scalars then | |
5075 | ||
82c80734 RD |
5076 | -- If zero is invalid, it is a convenient value to use that is |
5077 | -- for sure an appropriate invalid value in all situations. | |
5078 | ||
5079 | if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then | |
5080 | Val := Make_Integer_Literal (Loc, 0); | |
5081 | ||
5082 | -- Cases where all one bits is the appropriate invalid value | |
5083 | ||
5084 | -- For modular types, all 1 bits is either invalid or valid. If | |
5085 | -- it is valid, then there is nothing that can be done since there | |
5086 | -- are no invalid values (we ruled out zero already). | |
5087 | ||
5088 | -- For signed integer types that have no negative values, either | |
5089 | -- there is room for negative values, or there is not. If there | |
5090 | -- is, then all 1 bits may be interpretecd as minus one, which is | |
5091 | -- certainly invalid. Alternatively it is treated as the largest | |
5092 | -- positive value, in which case the observation for modular types | |
5093 | -- still applies. | |
5094 | ||
5095 | -- For float types, all 1-bits is a NaN (not a number), which is | |
5096 | -- certainly an appropriately invalid value. | |
70482933 | 5097 | |
82c80734 RD |
5098 | elsif Is_Unsigned_Type (T) |
5099 | or else Is_Floating_Point_Type (T) | |
5100 | or else Is_Enumeration_Type (T) | |
5101 | then | |
5102 | Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1); | |
5103 | ||
5104 | -- Resolve as Unsigned_64, because the largest number we | |
5105 | -- can generate is out of range of universal integer. | |
5106 | ||
5107 | Analyze_And_Resolve (Val, RTE (RE_Unsigned_64)); | |
70482933 | 5108 | |
82c80734 | 5109 | -- Case of signed types |
70482933 RK |
5110 | |
5111 | else | |
82c80734 RD |
5112 | declare |
5113 | Signed_Size : constant Uint := | |
5114 | UI_Min (Uint_63, Size_To_Use - 1); | |
5115 | ||
5116 | begin | |
5117 | -- Normally we like to use the most negative number. The | |
a9d8907c JM |
5118 | -- one exception is when this number is in the known |
5119 | -- subtype range and the largest positive number is not in | |
5120 | -- the known subtype range. | |
82c80734 RD |
5121 | |
5122 | -- For this exceptional case, use largest positive value | |
70482933 | 5123 | |
82c80734 RD |
5124 | if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint |
5125 | and then Lo_Bound <= (-(2 ** Signed_Size)) | |
5126 | and then Hi_Bound < 2 ** Signed_Size | |
5127 | then | |
5128 | Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1); | |
5129 | ||
5130 | -- Normal case of largest negative value | |
5131 | ||
5132 | else | |
5133 | Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size)); | |
5134 | end if; | |
5135 | end; | |
70482933 RK |
5136 | end if; |
5137 | ||
5138 | -- Here for Initialize_Scalars case | |
5139 | ||
5140 | else | |
82c80734 RD |
5141 | -- For float types, use float values from System.Scalar_Values |
5142 | ||
70482933 RK |
5143 | if Is_Floating_Point_Type (T) then |
5144 | if Root_Type (T) = Standard_Short_Float then | |
5145 | Val_RE := RE_IS_Isf; | |
5146 | elsif Root_Type (T) = Standard_Float then | |
5147 | Val_RE := RE_IS_Ifl; | |
fbf5a39b | 5148 | elsif Root_Type (T) = Standard_Long_Float then |
70482933 | 5149 | Val_RE := RE_IS_Ilf; |
70482933 RK |
5150 | else pragma Assert (Root_Type (T) = Standard_Long_Long_Float); |
5151 | Val_RE := RE_IS_Ill; | |
5152 | end if; | |
5153 | ||
82c80734 RD |
5154 | -- If zero is invalid, use zero values from System.Scalar_Values |
5155 | ||
5156 | elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then | |
5157 | if Size_To_Use <= 8 then | |
5158 | Val_RE := RE_IS_Iz1; | |
5159 | elsif Size_To_Use <= 16 then | |
5160 | Val_RE := RE_IS_Iz2; | |
5161 | elsif Size_To_Use <= 32 then | |
5162 | Val_RE := RE_IS_Iz4; | |
5163 | else | |
5164 | Val_RE := RE_IS_Iz8; | |
5165 | end if; | |
5166 | ||
5167 | -- For unsigned, use unsigned values from System.Scalar_Values | |
5168 | ||
5169 | elsif Is_Unsigned_Type (T) then | |
5170 | if Size_To_Use <= 8 then | |
70482933 | 5171 | Val_RE := RE_IS_Iu1; |
82c80734 | 5172 | elsif Size_To_Use <= 16 then |
70482933 | 5173 | Val_RE := RE_IS_Iu2; |
82c80734 | 5174 | elsif Size_To_Use <= 32 then |
70482933 | 5175 | Val_RE := RE_IS_Iu4; |
82c80734 | 5176 | else |
70482933 RK |
5177 | Val_RE := RE_IS_Iu8; |
5178 | end if; | |
5179 | ||
82c80734 RD |
5180 | -- For signed, use signed values from System.Scalar_Values |
5181 | ||
5182 | else | |
5183 | if Size_To_Use <= 8 then | |
70482933 | 5184 | Val_RE := RE_IS_Is1; |
82c80734 | 5185 | elsif Size_To_Use <= 16 then |
70482933 | 5186 | Val_RE := RE_IS_Is2; |
82c80734 | 5187 | elsif Size_To_Use <= 32 then |
70482933 | 5188 | Val_RE := RE_IS_Is4; |
82c80734 | 5189 | else |
70482933 RK |
5190 | Val_RE := RE_IS_Is8; |
5191 | end if; | |
5192 | end if; | |
5193 | ||
5194 | Val := New_Occurrence_Of (RTE (Val_RE), Loc); | |
5195 | end if; | |
5196 | ||
82c80734 RD |
5197 | -- The final expression is obtained by doing an unchecked conversion |
5198 | -- of this result to the base type of the required subtype. We use | |
5199 | -- the base type to avoid the unchecked conversion from chopping | |
5200 | -- bits, and then we set Kill_Range_Check to preserve the "bad" | |
5201 | -- value. | |
70482933 RK |
5202 | |
5203 | Result := Unchecked_Convert_To (Base_Type (T), Val); | |
5204 | ||
fbf5a39b AC |
5205 | -- Ensure result is not truncated, since we want the "bad" bits |
5206 | -- and also kill range check on result. | |
5207 | ||
70482933 | 5208 | if Nkind (Result) = N_Unchecked_Type_Conversion then |
fbf5a39b | 5209 | Set_No_Truncation (Result); |
70482933 RK |
5210 | Set_Kill_Range_Check (Result, True); |
5211 | end if; | |
5212 | ||
5213 | return Result; | |
5214 | ||
82c80734 | 5215 | -- String or Wide_[Wide]_String (must have Initialize_Scalars set) |
70482933 RK |
5216 | |
5217 | elsif Root_Type (T) = Standard_String | |
5218 | or else | |
5219 | Root_Type (T) = Standard_Wide_String | |
82c80734 RD |
5220 | or else |
5221 | Root_Type (T) = Standard_Wide_Wide_String | |
70482933 RK |
5222 | then |
5223 | pragma Assert (Init_Or_Norm_Scalars); | |
5224 | ||
70482933 | 5225 | return |
c84700e7 ES |
5226 | Make_Aggregate (Loc, |
5227 | Component_Associations => New_List ( | |
5228 | Make_Component_Association (Loc, | |
5229 | Choices => New_List ( | |
5230 | Make_Others_Choice (Loc)), | |
5231 | Expression => | |
82c80734 RD |
5232 | Get_Simple_Init_Val |
5233 | (Component_Type (T), Loc, Esize (Root_Type (T)))))); | |
70482933 RK |
5234 | |
5235 | -- Access type is initialized to null | |
5236 | ||
5237 | elsif Is_Access_Type (T) then | |
5238 | return | |
5239 | Make_Null (Loc); | |
5240 | ||
07fc65c4 GB |
5241 | -- No other possibilities should arise, since we should only be |
5242 | -- calling Get_Simple_Init_Val if Needs_Simple_Initialization | |
5243 | -- returned True, indicating one of the above cases held. | |
70482933 RK |
5244 | |
5245 | else | |
07fc65c4 | 5246 | raise Program_Error; |
70482933 | 5247 | end if; |
fbf5a39b AC |
5248 | |
5249 | exception | |
5250 | when RE_Not_Available => | |
5251 | return Empty; | |
70482933 RK |
5252 | end Get_Simple_Init_Val; |
5253 | ||
5254 | ------------------------------ | |
5255 | -- Has_New_Non_Standard_Rep -- | |
5256 | ------------------------------ | |
5257 | ||
5258 | function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is | |
5259 | begin | |
5260 | if not Is_Derived_Type (T) then | |
5261 | return Has_Non_Standard_Rep (T) | |
5262 | or else Has_Non_Standard_Rep (Root_Type (T)); | |
5263 | ||
5264 | -- If Has_Non_Standard_Rep is not set on the derived type, the | |
5265 | -- representation is fully inherited. | |
5266 | ||
5267 | elsif not Has_Non_Standard_Rep (T) then | |
5268 | return False; | |
5269 | ||
5270 | else | |
5271 | return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T)); | |
5272 | ||
5273 | -- May need a more precise check here: the First_Rep_Item may | |
5274 | -- be a stream attribute, which does not affect the representation | |
5275 | -- of the type ??? | |
5276 | end if; | |
5277 | end Has_New_Non_Standard_Rep; | |
5278 | ||
5279 | ---------------- | |
5280 | -- In_Runtime -- | |
5281 | ---------------- | |
5282 | ||
5283 | function In_Runtime (E : Entity_Id) return Boolean is | |
5284 | S1 : Entity_Id := Scope (E); | |
5285 | ||
5286 | begin | |
5287 | while Scope (S1) /= Standard_Standard loop | |
5288 | S1 := Scope (S1); | |
5289 | end loop; | |
5290 | ||
5291 | return Chars (S1) = Name_System or else Chars (S1) = Name_Ada; | |
5292 | end In_Runtime; | |
5293 | ||
5294 | ------------------ | |
5295 | -- Init_Formals -- | |
5296 | ------------------ | |
5297 | ||
5298 | function Init_Formals (Typ : Entity_Id) return List_Id is | |
5299 | Loc : constant Source_Ptr := Sloc (Typ); | |
5300 | Formals : List_Id; | |
5301 | ||
5302 | begin | |
5303 | -- First parameter is always _Init : in out typ. Note that we need | |
5304 | -- this to be in/out because in the case of the task record value, | |
5305 | -- there are default record fields (_Priority, _Size, -Task_Info) | |
5306 | -- that may be referenced in the generated initialization routine. | |
5307 | ||
5308 | Formals := New_List ( | |
5309 | Make_Parameter_Specification (Loc, | |
5310 | Defining_Identifier => | |
5311 | Make_Defining_Identifier (Loc, Name_uInit), | |
5312 | In_Present => True, | |
5313 | Out_Present => True, | |
5314 | Parameter_Type => New_Reference_To (Typ, Loc))); | |
5315 | ||
5316 | -- For task record value, or type that contains tasks, add two more | |
5317 | -- formals, _Master : Master_Id and _Chain : in out Activation_Chain | |
5318 | -- We also add these parameters for the task record type case. | |
5319 | ||
5320 | if Has_Task (Typ) | |
5321 | or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ)) | |
5322 | then | |
5323 | Append_To (Formals, | |
5324 | Make_Parameter_Specification (Loc, | |
5325 | Defining_Identifier => | |
5326 | Make_Defining_Identifier (Loc, Name_uMaster), | |
5327 | Parameter_Type => New_Reference_To (RTE (RE_Master_Id), Loc))); | |
5328 | ||
5329 | Append_To (Formals, | |
5330 | Make_Parameter_Specification (Loc, | |
5331 | Defining_Identifier => | |
5332 | Make_Defining_Identifier (Loc, Name_uChain), | |
5333 | In_Present => True, | |
5334 | Out_Present => True, | |
5335 | Parameter_Type => | |
5336 | New_Reference_To (RTE (RE_Activation_Chain), Loc))); | |
5337 | ||
5338 | Append_To (Formals, | |
5339 | Make_Parameter_Specification (Loc, | |
5340 | Defining_Identifier => | |
fbf5a39b | 5341 | Make_Defining_Identifier (Loc, Name_uTask_Name), |
70482933 RK |
5342 | In_Present => True, |
5343 | Parameter_Type => | |
fbf5a39b | 5344 | New_Reference_To (Standard_String, Loc))); |
70482933 RK |
5345 | end if; |
5346 | ||
5347 | return Formals; | |
fbf5a39b AC |
5348 | |
5349 | exception | |
5350 | when RE_Not_Available => | |
5351 | return Empty_List; | |
70482933 RK |
5352 | end Init_Formals; |
5353 | ||
5354 | ------------------ | |
5355 | -- Make_Eq_Case -- | |
5356 | ------------------ | |
5357 | ||
5358 | -- <Make_Eq_if shared components> | |
5359 | -- case X.D1 is | |
5360 | -- when V1 => <Make_Eq_Case> on subcomponents | |
5361 | -- ... | |
5362 | -- when Vn => <Make_Eq_Case> on subcomponents | |
5363 | -- end case; | |
5364 | ||
5d09245e AC |
5365 | function Make_Eq_Case |
5366 | (E : Entity_Id; | |
5367 | CL : Node_Id; | |
5368 | Discr : Entity_Id := Empty) return List_Id | |
5369 | is | |
5370 | Loc : constant Source_Ptr := Sloc (E); | |
fbf5a39b | 5371 | Result : constant List_Id := New_List; |
70482933 RK |
5372 | Variant : Node_Id; |
5373 | Alt_List : List_Id; | |
70482933 RK |
5374 | |
5375 | begin | |
5d09245e | 5376 | Append_To (Result, Make_Eq_If (E, Component_Items (CL))); |
70482933 RK |
5377 | |
5378 | if No (Variant_Part (CL)) then | |
5379 | return Result; | |
5380 | end if; | |
5381 | ||
5382 | Variant := First_Non_Pragma (Variants (Variant_Part (CL))); | |
5383 | ||
5384 | if No (Variant) then | |
5385 | return Result; | |
5386 | end if; | |
5387 | ||
5388 | Alt_List := New_List; | |
5389 | ||
5390 | while Present (Variant) loop | |
5391 | Append_To (Alt_List, | |
5392 | Make_Case_Statement_Alternative (Loc, | |
5393 | Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)), | |
5d09245e | 5394 | Statements => Make_Eq_Case (E, Component_List (Variant)))); |
70482933 RK |
5395 | |
5396 | Next_Non_Pragma (Variant); | |
5397 | end loop; | |
5398 | ||
5d09245e AC |
5399 | -- If we have an Unchecked_Union, use one of the parameters that |
5400 | -- captures the discriminants. | |
5401 | ||
5402 | if Is_Unchecked_Union (E) then | |
5403 | Append_To (Result, | |
5404 | Make_Case_Statement (Loc, | |
5405 | Expression => New_Reference_To (Discr, Loc), | |
5406 | Alternatives => Alt_List)); | |
5407 | ||
5408 | else | |
5409 | Append_To (Result, | |
5410 | Make_Case_Statement (Loc, | |
5411 | Expression => | |
5412 | Make_Selected_Component (Loc, | |
5413 | Prefix => Make_Identifier (Loc, Name_X), | |
5414 | Selector_Name => New_Copy (Name (Variant_Part (CL)))), | |
5415 | Alternatives => Alt_List)); | |
5416 | end if; | |
70482933 RK |
5417 | |
5418 | return Result; | |
5419 | end Make_Eq_Case; | |
5420 | ||
5421 | ---------------- | |
5422 | -- Make_Eq_If -- | |
5423 | ---------------- | |
5424 | ||
5425 | -- Generates: | |
5426 | ||
5427 | -- if | |
5428 | -- X.C1 /= Y.C1 | |
5429 | -- or else | |
5430 | -- X.C2 /= Y.C2 | |
5431 | -- ... | |
5432 | -- then | |
5433 | -- return False; | |
5434 | -- end if; | |
5435 | ||
5436 | -- or a null statement if the list L is empty | |
5437 | ||
5d09245e AC |
5438 | function Make_Eq_If |
5439 | (E : Entity_Id; | |
5440 | L : List_Id) return Node_Id | |
5441 | is | |
5442 | Loc : constant Source_Ptr := Sloc (E); | |
70482933 RK |
5443 | C : Node_Id; |
5444 | Field_Name : Name_Id; | |
5445 | Cond : Node_Id; | |
5446 | ||
5447 | begin | |
5448 | if No (L) then | |
5449 | return Make_Null_Statement (Loc); | |
5450 | ||
5451 | else | |
5452 | Cond := Empty; | |
5453 | ||
5454 | C := First_Non_Pragma (L); | |
5455 | while Present (C) loop | |
5456 | Field_Name := Chars (Defining_Identifier (C)); | |
5457 | ||
5458 | -- The tags must not be compared they are not part of the value. | |
5459 | -- Note also that in the following, we use Make_Identifier for | |
5460 | -- the component names. Use of New_Reference_To to identify the | |
5461 | -- components would be incorrect because the wrong entities for | |
5462 | -- discriminants could be picked up in the private type case. | |
5463 | ||
5464 | if Field_Name /= Name_uTag then | |
5465 | Evolve_Or_Else (Cond, | |
5466 | Make_Op_Ne (Loc, | |
5467 | Left_Opnd => | |
5468 | Make_Selected_Component (Loc, | |
5469 | Prefix => Make_Identifier (Loc, Name_X), | |
5470 | Selector_Name => | |
5471 | Make_Identifier (Loc, Field_Name)), | |
5472 | ||
5473 | Right_Opnd => | |
5474 | Make_Selected_Component (Loc, | |
5475 | Prefix => Make_Identifier (Loc, Name_Y), | |
5476 | Selector_Name => | |
5477 | Make_Identifier (Loc, Field_Name)))); | |
5478 | end if; | |
5479 | ||
5480 | Next_Non_Pragma (C); | |
5481 | end loop; | |
5482 | ||
5483 | if No (Cond) then | |
5484 | return Make_Null_Statement (Loc); | |
5485 | ||
5486 | else | |
5487 | return | |
5d09245e | 5488 | Make_Implicit_If_Statement (E, |
70482933 RK |
5489 | Condition => Cond, |
5490 | Then_Statements => New_List ( | |
5491 | Make_Return_Statement (Loc, | |
5492 | Expression => New_Occurrence_Of (Standard_False, Loc)))); | |
5493 | end if; | |
5494 | end if; | |
5495 | end Make_Eq_If; | |
5496 | ||
5497 | ------------------------------------- | |
5498 | -- Make_Predefined_Primitive_Specs -- | |
5499 | ------------------------------------- | |
5500 | ||
5501 | procedure Make_Predefined_Primitive_Specs | |
5502 | (Tag_Typ : Entity_Id; | |
5503 | Predef_List : out List_Id; | |
5504 | Renamed_Eq : out Node_Id) | |
5505 | is | |
5506 | Loc : constant Source_Ptr := Sloc (Tag_Typ); | |
fbf5a39b | 5507 | Res : constant List_Id := New_List; |
70482933 RK |
5508 | Prim : Elmt_Id; |
5509 | Eq_Needed : Boolean; | |
5510 | Eq_Spec : Node_Id; | |
5511 | Eq_Name : Name_Id := Name_Op_Eq; | |
5512 | ||
5513 | function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean; | |
5514 | -- Returns true if Prim is a renaming of an unresolved predefined | |
5515 | -- equality operation. | |
5516 | ||
fbf5a39b AC |
5517 | ------------------------------- |
5518 | -- Is_Predefined_Eq_Renaming -- | |
5519 | ------------------------------- | |
5520 | ||
70482933 RK |
5521 | function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is |
5522 | begin | |
5523 | return Chars (Prim) /= Name_Op_Eq | |
5524 | and then Present (Alias (Prim)) | |
5525 | and then Comes_From_Source (Prim) | |
5526 | and then Is_Intrinsic_Subprogram (Alias (Prim)) | |
5527 | and then Chars (Alias (Prim)) = Name_Op_Eq; | |
5528 | end Is_Predefined_Eq_Renaming; | |
5529 | ||
5530 | -- Start of processing for Make_Predefined_Primitive_Specs | |
5531 | ||
5532 | begin | |
5533 | Renamed_Eq := Empty; | |
5534 | ||
a9d8907c | 5535 | -- Spec of _Size |
fbf5a39b AC |
5536 | |
5537 | Append_To (Res, Predef_Spec_Or_Body (Loc, | |
5538 | Tag_Typ => Tag_Typ, | |
a9d8907c | 5539 | Name => Name_uSize, |
fbf5a39b AC |
5540 | Profile => New_List ( |
5541 | Make_Parameter_Specification (Loc, | |
5542 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
5543 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))), | |
5544 | ||
a9d8907c | 5545 | Ret_Type => Standard_Long_Long_Integer)); |
fbf5a39b | 5546 | |
a9d8907c | 5547 | -- Spec of _Alignment |
70482933 RK |
5548 | |
5549 | Append_To (Res, Predef_Spec_Or_Body (Loc, | |
5550 | Tag_Typ => Tag_Typ, | |
a9d8907c | 5551 | Name => Name_uAlignment, |
70482933 RK |
5552 | Profile => New_List ( |
5553 | Make_Parameter_Specification (Loc, | |
5554 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
5555 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))), | |
5556 | ||
a9d8907c | 5557 | Ret_Type => Standard_Integer)); |
70482933 | 5558 | |
d2d3604c TQ |
5559 | -- Specs for dispatching stream attributes. |
5560 | ||
5561 | declare | |
5562 | Stream_Op_TSS_Names : | |
5563 | constant array (Integer range <>) of TSS_Name_Type := | |
5564 | (TSS_Stream_Read, | |
5565 | TSS_Stream_Write, | |
5566 | TSS_Stream_Input, | |
5567 | TSS_Stream_Output); | |
5568 | begin | |
5569 | for Op in Stream_Op_TSS_Names'Range loop | |
5570 | if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then | |
5571 | Append_To (Res, | |
5572 | Predef_Stream_Attr_Spec (Loc, Tag_Typ, | |
5573 | Stream_Op_TSS_Names (Op))); | |
5574 | end if; | |
5575 | end loop; | |
5576 | end; | |
70482933 | 5577 | |
fbf5a39b AC |
5578 | -- Spec of "=" if expanded if the type is not limited and if a |
5579 | -- user defined "=" was not already declared for the non-full | |
5580 | -- view of a private extension | |
70482933 | 5581 | |
fbf5a39b | 5582 | if not Is_Limited_Type (Tag_Typ) then |
70482933 RK |
5583 | Eq_Needed := True; |
5584 | ||
5585 | Prim := First_Elmt (Primitive_Operations (Tag_Typ)); | |
5586 | while Present (Prim) loop | |
fbf5a39b | 5587 | |
70482933 RK |
5588 | -- If a primitive is encountered that renames the predefined |
5589 | -- equality operator before reaching any explicit equality | |
5590 | -- primitive, then we still need to create a predefined | |
5591 | -- equality function, because calls to it can occur via | |
5592 | -- the renaming. A new name is created for the equality | |
5593 | -- to avoid conflicting with any user-defined equality. | |
5594 | -- (Note that this doesn't account for renamings of | |
5595 | -- equality nested within subpackages???) | |
5596 | ||
5597 | if Is_Predefined_Eq_Renaming (Node (Prim)) then | |
5598 | Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); | |
5599 | ||
5600 | elsif Chars (Node (Prim)) = Name_Op_Eq | |
5601 | and then (No (Alias (Node (Prim))) | |
5602 | or else Nkind (Unit_Declaration_Node (Node (Prim))) = | |
5603 | N_Subprogram_Renaming_Declaration) | |
5604 | and then Etype (First_Formal (Node (Prim))) = | |
5605 | Etype (Next_Formal (First_Formal (Node (Prim)))) | |
e6f69614 | 5606 | and then Base_Type (Etype (Node (Prim))) = Standard_Boolean |
70482933 RK |
5607 | |
5608 | then | |
5609 | Eq_Needed := False; | |
5610 | exit; | |
5611 | ||
5612 | -- If the parent equality is abstract, the inherited equality is | |
5613 | -- abstract as well, and no body can be created for for it. | |
5614 | ||
5615 | elsif Chars (Node (Prim)) = Name_Op_Eq | |
5616 | and then Present (Alias (Node (Prim))) | |
5617 | and then Is_Abstract (Alias (Node (Prim))) | |
5618 | then | |
5619 | Eq_Needed := False; | |
5620 | exit; | |
5621 | end if; | |
5622 | ||
5623 | Next_Elmt (Prim); | |
5624 | end loop; | |
5625 | ||
5626 | -- If a renaming of predefined equality was found | |
5627 | -- but there was no user-defined equality (so Eq_Needed | |
5628 | -- is still true), then set the name back to Name_Op_Eq. | |
5629 | -- But in the case where a user-defined equality was | |
5630 | -- located after such a renaming, then the predefined | |
5631 | -- equality function is still needed, so Eq_Needed must | |
5632 | -- be set back to True. | |
5633 | ||
5634 | if Eq_Name /= Name_Op_Eq then | |
5635 | if Eq_Needed then | |
5636 | Eq_Name := Name_Op_Eq; | |
5637 | else | |
5638 | Eq_Needed := True; | |
5639 | end if; | |
5640 | end if; | |
5641 | ||
5642 | if Eq_Needed then | |
5643 | Eq_Spec := Predef_Spec_Or_Body (Loc, | |
5644 | Tag_Typ => Tag_Typ, | |
5645 | Name => Eq_Name, | |
5646 | Profile => New_List ( | |
5647 | Make_Parameter_Specification (Loc, | |
5648 | Defining_Identifier => | |
5649 | Make_Defining_Identifier (Loc, Name_X), | |
5650 | Parameter_Type => New_Reference_To (Tag_Typ, Loc)), | |
5651 | Make_Parameter_Specification (Loc, | |
5652 | Defining_Identifier => | |
5653 | Make_Defining_Identifier (Loc, Name_Y), | |
5654 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))), | |
5655 | Ret_Type => Standard_Boolean); | |
5656 | Append_To (Res, Eq_Spec); | |
5657 | ||
5658 | if Eq_Name /= Name_Op_Eq then | |
5659 | Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec)); | |
5660 | ||
5661 | Prim := First_Elmt (Primitive_Operations (Tag_Typ)); | |
5662 | while Present (Prim) loop | |
5663 | ||
5664 | -- Any renamings of equality that appeared before an | |
5665 | -- overriding equality must be updated to refer to | |
5666 | -- the entity for the predefined equality, otherwise | |
5667 | -- calls via the renaming would get incorrectly | |
5668 | -- resolved to call the user-defined equality function. | |
5669 | ||
5670 | if Is_Predefined_Eq_Renaming (Node (Prim)) then | |
5671 | Set_Alias (Node (Prim), Renamed_Eq); | |
5672 | ||
5673 | -- Exit upon encountering a user-defined equality | |
5674 | ||
5675 | elsif Chars (Node (Prim)) = Name_Op_Eq | |
5676 | and then No (Alias (Node (Prim))) | |
5677 | then | |
5678 | exit; | |
5679 | end if; | |
5680 | ||
5681 | Next_Elmt (Prim); | |
5682 | end loop; | |
5683 | end if; | |
5684 | end if; | |
5685 | ||
5686 | -- Spec for dispatching assignment | |
5687 | ||
5688 | Append_To (Res, Predef_Spec_Or_Body (Loc, | |
5689 | Tag_Typ => Tag_Typ, | |
5690 | Name => Name_uAssign, | |
5691 | Profile => New_List ( | |
5692 | Make_Parameter_Specification (Loc, | |
5693 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
5694 | Out_Present => True, | |
5695 | Parameter_Type => New_Reference_To (Tag_Typ, Loc)), | |
5696 | ||
5697 | Make_Parameter_Specification (Loc, | |
5698 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), | |
5699 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))))); | |
5700 | end if; | |
5701 | ||
5702 | -- Specs for finalization actions that may be required in case a | |
5703 | -- future extension contain a controlled element. We generate those | |
5704 | -- only for root tagged types where they will get dummy bodies or | |
5705 | -- when the type has controlled components and their body must be | |
5706 | -- generated. It is also impossible to provide those for tagged | |
5707 | -- types defined within s-finimp since it would involve circularity | |
5708 | -- problems | |
5709 | ||
5710 | if In_Finalization_Root (Tag_Typ) then | |
5711 | null; | |
5712 | ||
fbf5a39b | 5713 | -- We also skip these if finalization is not available |
70482933 | 5714 | |
6e937c1c | 5715 | elsif Restriction_Active (No_Finalization) then |
70482933 RK |
5716 | null; |
5717 | ||
5718 | elsif Etype (Tag_Typ) = Tag_Typ or else Controlled_Type (Tag_Typ) then | |
70482933 RK |
5719 | if not Is_Limited_Type (Tag_Typ) then |
5720 | Append_To (Res, | |
fbf5a39b | 5721 | Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust)); |
70482933 RK |
5722 | end if; |
5723 | ||
fbf5a39b | 5724 | Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize)); |
70482933 RK |
5725 | end if; |
5726 | ||
5727 | Predef_List := Res; | |
5728 | end Make_Predefined_Primitive_Specs; | |
5729 | ||
5730 | --------------------------------- | |
5731 | -- Needs_Simple_Initialization -- | |
5732 | --------------------------------- | |
5733 | ||
5734 | function Needs_Simple_Initialization (T : Entity_Id) return Boolean is | |
5735 | begin | |
07fc65c4 GB |
5736 | -- Check for private type, in which case test applies to the |
5737 | -- underlying type of the private type. | |
5738 | ||
5739 | if Is_Private_Type (T) then | |
5740 | declare | |
5741 | RT : constant Entity_Id := Underlying_Type (T); | |
5742 | ||
5743 | begin | |
5744 | if Present (RT) then | |
5745 | return Needs_Simple_Initialization (RT); | |
5746 | else | |
5747 | return False; | |
5748 | end if; | |
5749 | end; | |
5750 | ||
70482933 RK |
5751 | -- Cases needing simple initialization are access types, and, if pragma |
5752 | -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar | |
5753 | -- types. | |
5754 | ||
07fc65c4 | 5755 | elsif Is_Access_Type (T) |
70482933 | 5756 | or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T))) |
70482933 RK |
5757 | then |
5758 | return True; | |
5759 | ||
5760 | -- If Initialize/Normalize_Scalars is in effect, string objects also | |
5761 | -- need initialization, unless they are created in the course of | |
5762 | -- expanding an aggregate (since in the latter case they will be | |
5763 | -- filled with appropriate initializing values before they are used). | |
5764 | ||
5765 | elsif Init_Or_Norm_Scalars | |
5766 | and then | |
5767 | (Root_Type (T) = Standard_String | |
82c80734 RD |
5768 | or else Root_Type (T) = Standard_Wide_String |
5769 | or else Root_Type (T) = Standard_Wide_Wide_String) | |
70482933 RK |
5770 | and then |
5771 | (not Is_Itype (T) | |
5772 | or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate) | |
5773 | then | |
5774 | return True; | |
5775 | ||
70482933 RK |
5776 | else |
5777 | return False; | |
5778 | end if; | |
5779 | end Needs_Simple_Initialization; | |
5780 | ||
5781 | ---------------------- | |
5782 | -- Predef_Deep_Spec -- | |
5783 | ---------------------- | |
5784 | ||
5785 | function Predef_Deep_Spec | |
5786 | (Loc : Source_Ptr; | |
5787 | Tag_Typ : Entity_Id; | |
fbf5a39b | 5788 | Name : TSS_Name_Type; |
2e071734 | 5789 | For_Body : Boolean := False) return Node_Id |
70482933 RK |
5790 | is |
5791 | Prof : List_Id; | |
5792 | Type_B : Entity_Id; | |
5793 | ||
5794 | begin | |
fbf5a39b | 5795 | if Name = TSS_Deep_Finalize then |
70482933 RK |
5796 | Prof := New_List; |
5797 | Type_B := Standard_Boolean; | |
5798 | ||
5799 | else | |
5800 | Prof := New_List ( | |
5801 | Make_Parameter_Specification (Loc, | |
5802 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_L), | |
5803 | In_Present => True, | |
5804 | Out_Present => True, | |
5805 | Parameter_Type => | |
5806 | New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); | |
5807 | Type_B := Standard_Short_Short_Integer; | |
5808 | end if; | |
5809 | ||
5810 | Append_To (Prof, | |
5811 | Make_Parameter_Specification (Loc, | |
5812 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), | |
5813 | In_Present => True, | |
5814 | Out_Present => True, | |
5815 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))); | |
5816 | ||
5817 | Append_To (Prof, | |
5818 | Make_Parameter_Specification (Loc, | |
5819 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_B), | |
5820 | Parameter_Type => New_Reference_To (Type_B, Loc))); | |
5821 | ||
5822 | return Predef_Spec_Or_Body (Loc, | |
fbf5a39b | 5823 | Name => Make_TSS_Name (Tag_Typ, Name), |
70482933 RK |
5824 | Tag_Typ => Tag_Typ, |
5825 | Profile => Prof, | |
5826 | For_Body => For_Body); | |
fbf5a39b AC |
5827 | |
5828 | exception | |
5829 | when RE_Not_Available => | |
5830 | return Empty; | |
70482933 RK |
5831 | end Predef_Deep_Spec; |
5832 | ||
5833 | ------------------------- | |
5834 | -- Predef_Spec_Or_Body -- | |
5835 | ------------------------- | |
5836 | ||
5837 | function Predef_Spec_Or_Body | |
5838 | (Loc : Source_Ptr; | |
5839 | Tag_Typ : Entity_Id; | |
5840 | Name : Name_Id; | |
5841 | Profile : List_Id; | |
5842 | Ret_Type : Entity_Id := Empty; | |
2e071734 | 5843 | For_Body : Boolean := False) return Node_Id |
70482933 | 5844 | is |
fbf5a39b | 5845 | Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name); |
70482933 RK |
5846 | Spec : Node_Id; |
5847 | ||
5848 | begin | |
5849 | Set_Is_Public (Id, Is_Public (Tag_Typ)); | |
5850 | ||
5851 | -- The internal flag is set to mark these declarations because | |
5852 | -- they have specific properties. First they are primitives even | |
5853 | -- if they are not defined in the type scope (the freezing point | |
5854 | -- is not necessarily in the same scope), furthermore the | |
5855 | -- predefined equality can be overridden by a user-defined | |
5856 | -- equality, no body will be generated in this case. | |
5857 | ||
5858 | Set_Is_Internal (Id); | |
5859 | ||
5860 | if not Debug_Generated_Code then | |
5861 | Set_Debug_Info_Off (Id); | |
5862 | end if; | |
5863 | ||
5864 | if No (Ret_Type) then | |
5865 | Spec := | |
5866 | Make_Procedure_Specification (Loc, | |
5867 | Defining_Unit_Name => Id, | |
5868 | Parameter_Specifications => Profile); | |
5869 | else | |
5870 | Spec := | |
5871 | Make_Function_Specification (Loc, | |
5872 | Defining_Unit_Name => Id, | |
5873 | Parameter_Specifications => Profile, | |
5874 | Subtype_Mark => | |
5875 | New_Reference_To (Ret_Type, Loc)); | |
5876 | end if; | |
5877 | ||
5878 | -- If body case, return empty subprogram body. Note that this is | |
5879 | -- ill-formed, because there is not even a null statement, and | |
5880 | -- certainly not a return in the function case. The caller is | |
5881 | -- expected to do surgery on the body to add the appropriate stuff. | |
5882 | ||
5883 | if For_Body then | |
5884 | return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty); | |
5885 | ||
fbf5a39b | 5886 | -- For the case of Input/Output attributes applied to an abstract type, |
70482933 RK |
5887 | -- generate abstract specifications. These will never be called, |
5888 | -- but we need the slots allocated in the dispatching table so | |
5889 | -- that typ'Class'Input and typ'Class'Output will work properly. | |
5890 | ||
fbf5a39b AC |
5891 | elsif (Is_TSS (Name, TSS_Stream_Input) |
5892 | or else | |
5893 | Is_TSS (Name, TSS_Stream_Output)) | |
70482933 RK |
5894 | and then Is_Abstract (Tag_Typ) |
5895 | then | |
5896 | return Make_Abstract_Subprogram_Declaration (Loc, Spec); | |
5897 | ||
5898 | -- Normal spec case, where we return a subprogram declaration | |
5899 | ||
5900 | else | |
5901 | return Make_Subprogram_Declaration (Loc, Spec); | |
5902 | end if; | |
5903 | end Predef_Spec_Or_Body; | |
5904 | ||
5905 | ----------------------------- | |
5906 | -- Predef_Stream_Attr_Spec -- | |
5907 | ----------------------------- | |
5908 | ||
5909 | function Predef_Stream_Attr_Spec | |
5910 | (Loc : Source_Ptr; | |
5911 | Tag_Typ : Entity_Id; | |
fbf5a39b | 5912 | Name : TSS_Name_Type; |
2e071734 | 5913 | For_Body : Boolean := False) return Node_Id |
70482933 RK |
5914 | is |
5915 | Ret_Type : Entity_Id; | |
5916 | ||
5917 | begin | |
fbf5a39b | 5918 | if Name = TSS_Stream_Input then |
70482933 RK |
5919 | Ret_Type := Tag_Typ; |
5920 | else | |
5921 | Ret_Type := Empty; | |
5922 | end if; | |
5923 | ||
5924 | return Predef_Spec_Or_Body (Loc, | |
fbf5a39b | 5925 | Name => Make_TSS_Name (Tag_Typ, Name), |
70482933 RK |
5926 | Tag_Typ => Tag_Typ, |
5927 | Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name), | |
5928 | Ret_Type => Ret_Type, | |
5929 | For_Body => For_Body); | |
5930 | end Predef_Stream_Attr_Spec; | |
5931 | ||
5932 | --------------------------------- | |
5933 | -- Predefined_Primitive_Bodies -- | |
5934 | --------------------------------- | |
5935 | ||
5936 | function Predefined_Primitive_Bodies | |
5937 | (Tag_Typ : Entity_Id; | |
2e071734 | 5938 | Renamed_Eq : Node_Id) return List_Id |
70482933 RK |
5939 | is |
5940 | Loc : constant Source_Ptr := Sloc (Tag_Typ); | |
fbf5a39b | 5941 | Res : constant List_Id := New_List; |
70482933 | 5942 | Decl : Node_Id; |
70482933 RK |
5943 | Prim : Elmt_Id; |
5944 | Eq_Needed : Boolean; | |
5945 | Eq_Name : Name_Id; | |
5946 | Ent : Entity_Id; | |
5947 | ||
5948 | begin | |
5949 | -- See if we have a predefined "=" operator | |
5950 | ||
5951 | if Present (Renamed_Eq) then | |
5952 | Eq_Needed := True; | |
5953 | Eq_Name := Chars (Renamed_Eq); | |
5954 | ||
5955 | else | |
5956 | Eq_Needed := False; | |
5957 | Eq_Name := No_Name; | |
5958 | ||
5959 | Prim := First_Elmt (Primitive_Operations (Tag_Typ)); | |
5960 | while Present (Prim) loop | |
5961 | if Chars (Node (Prim)) = Name_Op_Eq | |
5962 | and then Is_Internal (Node (Prim)) | |
5963 | then | |
5964 | Eq_Needed := True; | |
5965 | Eq_Name := Name_Op_Eq; | |
5966 | end if; | |
5967 | ||
5968 | Next_Elmt (Prim); | |
5969 | end loop; | |
5970 | end if; | |
5971 | ||
fbf5a39b AC |
5972 | -- Body of _Alignment |
5973 | ||
5974 | Decl := Predef_Spec_Or_Body (Loc, | |
5975 | Tag_Typ => Tag_Typ, | |
5976 | Name => Name_uAlignment, | |
5977 | Profile => New_List ( | |
5978 | Make_Parameter_Specification (Loc, | |
5979 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
5980 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))), | |
5981 | ||
5982 | Ret_Type => Standard_Integer, | |
5983 | For_Body => True); | |
5984 | ||
5985 | Set_Handled_Statement_Sequence (Decl, | |
5986 | Make_Handled_Sequence_Of_Statements (Loc, New_List ( | |
5987 | Make_Return_Statement (Loc, | |
5988 | Expression => | |
5989 | Make_Attribute_Reference (Loc, | |
5990 | Prefix => Make_Identifier (Loc, Name_X), | |
5991 | Attribute_Name => Name_Alignment))))); | |
5992 | ||
5993 | Append_To (Res, Decl); | |
5994 | ||
70482933 RK |
5995 | -- Body of _Size |
5996 | ||
5997 | Decl := Predef_Spec_Or_Body (Loc, | |
5998 | Tag_Typ => Tag_Typ, | |
5999 | Name => Name_uSize, | |
6000 | Profile => New_List ( | |
6001 | Make_Parameter_Specification (Loc, | |
6002 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
6003 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))), | |
6004 | ||
6005 | Ret_Type => Standard_Long_Long_Integer, | |
6006 | For_Body => True); | |
6007 | ||
6008 | Set_Handled_Statement_Sequence (Decl, | |
6009 | Make_Handled_Sequence_Of_Statements (Loc, New_List ( | |
6010 | Make_Return_Statement (Loc, | |
6011 | Expression => | |
6012 | Make_Attribute_Reference (Loc, | |
6013 | Prefix => Make_Identifier (Loc, Name_X), | |
6014 | Attribute_Name => Name_Size))))); | |
6015 | ||
6016 | Append_To (Res, Decl); | |
6017 | ||
6018 | -- Bodies for Dispatching stream IO routines. We need these only for | |
6019 | -- non-limited types (in the limited case there is no dispatching). | |
a778d033 | 6020 | -- We also skip them if dispatching or finalization are not available. |
70482933 | 6021 | |
d2d3604c TQ |
6022 | if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read) |
6023 | and then No (TSS (Tag_Typ, TSS_Stream_Read)) | |
6024 | then | |
6025 | Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent); | |
6026 | Append_To (Res, Decl); | |
6027 | end if; | |
70482933 | 6028 | |
d2d3604c TQ |
6029 | if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write) |
6030 | and then No (TSS (Tag_Typ, TSS_Stream_Write)) | |
6031 | then | |
6032 | Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent); | |
6033 | Append_To (Res, Decl); | |
6034 | end if; | |
70482933 | 6035 | |
d2d3604c TQ |
6036 | -- Skip bodies of _Input and _Output for the abstract case, since |
6037 | -- the corresponding specs are abstract (see Predef_Spec_Or_Body) | |
70482933 | 6038 | |
d2d3604c TQ |
6039 | if not Is_Abstract (Tag_Typ) then |
6040 | if Stream_Operation_OK (Tag_Typ, TSS_Stream_Input) | |
6041 | and then No (TSS (Tag_Typ, TSS_Stream_Input)) | |
6042 | then | |
6043 | Build_Record_Or_Elementary_Input_Function | |
6044 | (Loc, Tag_Typ, Decl, Ent); | |
6045 | Append_To (Res, Decl); | |
6046 | end if; | |
70482933 | 6047 | |
d2d3604c TQ |
6048 | if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output) |
6049 | and then No (TSS (Tag_Typ, TSS_Stream_Output)) | |
6050 | then | |
6051 | Build_Record_Or_Elementary_Output_Procedure | |
6052 | (Loc, Tag_Typ, Decl, Ent); | |
6053 | Append_To (Res, Decl); | |
70482933 RK |
6054 | end if; |
6055 | end if; | |
6056 | ||
6057 | if not Is_Limited_Type (Tag_Typ) then | |
6058 | ||
6059 | -- Body for equality | |
6060 | ||
6061 | if Eq_Needed then | |
6062 | ||
6063 | Decl := Predef_Spec_Or_Body (Loc, | |
6064 | Tag_Typ => Tag_Typ, | |
6065 | Name => Eq_Name, | |
6066 | Profile => New_List ( | |
6067 | Make_Parameter_Specification (Loc, | |
6068 | Defining_Identifier => | |
6069 | Make_Defining_Identifier (Loc, Name_X), | |
6070 | Parameter_Type => New_Reference_To (Tag_Typ, Loc)), | |
6071 | ||
6072 | Make_Parameter_Specification (Loc, | |
6073 | Defining_Identifier => | |
6074 | Make_Defining_Identifier (Loc, Name_Y), | |
6075 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))), | |
6076 | ||
6077 | Ret_Type => Standard_Boolean, | |
6078 | For_Body => True); | |
6079 | ||
6080 | declare | |
6081 | Def : constant Node_Id := Parent (Tag_Typ); | |
fbf5a39b | 6082 | Stmts : constant List_Id := New_List; |
70482933 RK |
6083 | Variant_Case : Boolean := Has_Discriminants (Tag_Typ); |
6084 | Comps : Node_Id := Empty; | |
6085 | Typ_Def : Node_Id := Type_Definition (Def); | |
70482933 RK |
6086 | |
6087 | begin | |
6088 | if Variant_Case then | |
6089 | if Nkind (Typ_Def) = N_Derived_Type_Definition then | |
6090 | Typ_Def := Record_Extension_Part (Typ_Def); | |
6091 | end if; | |
6092 | ||
6093 | if Present (Typ_Def) then | |
6094 | Comps := Component_List (Typ_Def); | |
6095 | end if; | |
6096 | ||
6097 | Variant_Case := Present (Comps) | |
6098 | and then Present (Variant_Part (Comps)); | |
6099 | end if; | |
6100 | ||
6101 | if Variant_Case then | |
6102 | Append_To (Stmts, | |
6103 | Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def))); | |
6104 | Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps)); | |
6105 | Append_To (Stmts, | |
6106 | Make_Return_Statement (Loc, | |
6107 | Expression => New_Reference_To (Standard_True, Loc))); | |
6108 | ||
6109 | else | |
6110 | Append_To (Stmts, | |
6111 | Make_Return_Statement (Loc, | |
6112 | Expression => | |
6113 | Expand_Record_Equality (Tag_Typ, | |
6114 | Typ => Tag_Typ, | |
6115 | Lhs => Make_Identifier (Loc, Name_X), | |
6116 | Rhs => Make_Identifier (Loc, Name_Y), | |
6117 | Bodies => Declarations (Decl)))); | |
6118 | end if; | |
6119 | ||
6120 | Set_Handled_Statement_Sequence (Decl, | |
6121 | Make_Handled_Sequence_Of_Statements (Loc, Stmts)); | |
6122 | end; | |
6123 | Append_To (Res, Decl); | |
6124 | end if; | |
6125 | ||
6126 | -- Body for dispatching assignment | |
6127 | ||
6128 | Decl := Predef_Spec_Or_Body (Loc, | |
6129 | Tag_Typ => Tag_Typ, | |
6130 | Name => Name_uAssign, | |
6131 | Profile => New_List ( | |
6132 | Make_Parameter_Specification (Loc, | |
6133 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), | |
6134 | Out_Present => True, | |
6135 | Parameter_Type => New_Reference_To (Tag_Typ, Loc)), | |
6136 | ||
6137 | Make_Parameter_Specification (Loc, | |
6138 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), | |
6139 | Parameter_Type => New_Reference_To (Tag_Typ, Loc))), | |
6140 | For_Body => True); | |
6141 | ||
6142 | Set_Handled_Statement_Sequence (Decl, | |
6143 | Make_Handled_Sequence_Of_Statements (Loc, New_List ( | |
6144 | Make_Assignment_Statement (Loc, | |
6145 | Name => Make_Identifier (Loc, Name_X), | |
6146 | Expression => Make_Identifier (Loc, Name_Y))))); | |
6147 | ||
6148 | Append_To (Res, Decl); | |
6149 | end if; | |
6150 | ||
6151 | -- Generate dummy bodies for finalization actions of types that have | |
6152 | -- no controlled components. | |
6153 | ||
6154 | -- Skip this processing if we are in the finalization routine in the | |
6155 | -- runtime itself, otherwise we get hopelessly circularly confused! | |
6156 | ||
6157 | if In_Finalization_Root (Tag_Typ) then | |
6158 | null; | |
6159 | ||
fbf5a39b | 6160 | -- Skip this if finalization is not available |
70482933 | 6161 | |
6e937c1c | 6162 | elsif Restriction_Active (No_Finalization) then |
70482933 RK |
6163 | null; |
6164 | ||
6165 | elsif (Etype (Tag_Typ) = Tag_Typ or else Is_Controlled (Tag_Typ)) | |
6166 | and then not Has_Controlled_Component (Tag_Typ) | |
6167 | then | |
6168 | if not Is_Limited_Type (Tag_Typ) then | |
fbf5a39b | 6169 | Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True); |
70482933 RK |
6170 | |
6171 | if Is_Controlled (Tag_Typ) then | |
6172 | Set_Handled_Statement_Sequence (Decl, | |
6173 | Make_Handled_Sequence_Of_Statements (Loc, | |
6174 | Make_Adjust_Call ( | |
6175 | Ref => Make_Identifier (Loc, Name_V), | |
6176 | Typ => Tag_Typ, | |
6177 | Flist_Ref => Make_Identifier (Loc, Name_L), | |
6178 | With_Attach => Make_Identifier (Loc, Name_B)))); | |
6179 | ||
6180 | else | |
6181 | Set_Handled_Statement_Sequence (Decl, | |
6182 | Make_Handled_Sequence_Of_Statements (Loc, New_List ( | |
6183 | Make_Null_Statement (Loc)))); | |
6184 | end if; | |
6185 | ||
6186 | Append_To (Res, Decl); | |
6187 | end if; | |
6188 | ||
fbf5a39b | 6189 | Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True); |
70482933 RK |
6190 | |
6191 | if Is_Controlled (Tag_Typ) then | |
6192 | Set_Handled_Statement_Sequence (Decl, | |
6193 | Make_Handled_Sequence_Of_Statements (Loc, | |
6194 | Make_Final_Call ( | |
6195 | Ref => Make_Identifier (Loc, Name_V), | |
6196 | Typ => Tag_Typ, | |
6197 | With_Detach => Make_Identifier (Loc, Name_B)))); | |
6198 | ||
6199 | else | |
6200 | Set_Handled_Statement_Sequence (Decl, | |
6201 | Make_Handled_Sequence_Of_Statements (Loc, New_List ( | |
6202 | Make_Null_Statement (Loc)))); | |
6203 | end if; | |
6204 | ||
6205 | Append_To (Res, Decl); | |
6206 | end if; | |
6207 | ||
6208 | return Res; | |
6209 | end Predefined_Primitive_Bodies; | |
6210 | ||
6211 | --------------------------------- | |
6212 | -- Predefined_Primitive_Freeze -- | |
6213 | --------------------------------- | |
6214 | ||
6215 | function Predefined_Primitive_Freeze | |
fbf5a39b | 6216 | (Tag_Typ : Entity_Id) return List_Id |
70482933 RK |
6217 | is |
6218 | Loc : constant Source_Ptr := Sloc (Tag_Typ); | |
fbf5a39b | 6219 | Res : constant List_Id := New_List; |
70482933 RK |
6220 | Prim : Elmt_Id; |
6221 | Frnodes : List_Id; | |
6222 | ||
6223 | begin | |
6224 | Prim := First_Elmt (Primitive_Operations (Tag_Typ)); | |
6225 | while Present (Prim) loop | |
6226 | if Is_Internal (Node (Prim)) then | |
6227 | Frnodes := Freeze_Entity (Node (Prim), Loc); | |
6228 | ||
6229 | if Present (Frnodes) then | |
6230 | Append_List_To (Res, Frnodes); | |
6231 | end if; | |
6232 | end if; | |
6233 | ||
6234 | Next_Elmt (Prim); | |
6235 | end loop; | |
6236 | ||
6237 | return Res; | |
6238 | end Predefined_Primitive_Freeze; | |
a778d033 | 6239 | |
d2d3604c TQ |
6240 | ------------------------- |
6241 | -- Stream_Operation_OK -- | |
6242 | ------------------------- | |
6243 | ||
6244 | function Stream_Operation_OK | |
6245 | (Typ : Entity_Id; | |
6246 | Operation : TSS_Name_Type) return Boolean | |
6247 | is | |
6248 | Has_Inheritable_Stream_Attribute : Boolean := False; | |
a778d033 | 6249 | |
a778d033 | 6250 | begin |
d2d3604c TQ |
6251 | if Is_Limited_Type (Typ) |
6252 | and then Is_Tagged_Type (Typ) | |
6253 | and then Is_Derived_Type (Typ) | |
6254 | then | |
6255 | -- Special case of a limited type extension: a default implementation | |
6256 | -- of the stream attributes Read and Write exists if the attribute | |
6257 | -- has been specified for an ancestor type. | |
6258 | ||
6259 | Has_Inheritable_Stream_Attribute := | |
6260 | Present (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation)); | |
6261 | end if; | |
6262 | ||
a778d033 | 6263 | return |
d2d3604c TQ |
6264 | not (Is_Limited_Type (Typ) |
6265 | and then not Has_Inheritable_Stream_Attribute) | |
a778d033 AC |
6266 | and then RTE_Available (RE_Tag) |
6267 | and then RTE_Available (RE_Root_Stream_Type) | |
6268 | and then not Restriction_Active (No_Dispatch) | |
6269 | and then not Restriction_Active (No_Streams); | |
d2d3604c | 6270 | end Stream_Operation_OK; |
70482933 | 6271 | end Exp_Ch3; |