]>
Commit | Line | Data |
---|---|---|
70482933 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- E X P _ D I S P -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
fbf5a39b | 9 | -- Copyright (C) 1992-2003 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; | |
31 | with Errout; use Errout; | |
32 | with Exp_Ch7; use Exp_Ch7; | |
33 | with Exp_Tss; use Exp_Tss; | |
34 | with Exp_Util; use Exp_Util; | |
35 | with Fname; use Fname; | |
36 | with Itypes; use Itypes; | |
37 | with Lib; use Lib; | |
38 | with Nlists; use Nlists; | |
39 | with Nmake; use Nmake; | |
40 | with Opt; use Opt; | |
41 | with Rtsfind; use Rtsfind; | |
42 | with Sem_Disp; use Sem_Disp; | |
43 | with Sem_Res; use Sem_Res; | |
44 | with Sem_Util; use Sem_Util; | |
45 | with Sinfo; use Sinfo; | |
46 | with Snames; use Snames; | |
47 | with Stand; use Stand; | |
48 | with Tbuild; use Tbuild; | |
49 | with Uintp; use Uintp; | |
50 | ||
51 | package body Exp_Disp is | |
52 | ||
53 | Ada_Actions : constant array (DT_Access_Action) of RE_Id := | |
54 | (CW_Membership => RE_CW_Membership, | |
55 | DT_Entry_Size => RE_DT_Entry_Size, | |
56 | DT_Prologue_Size => RE_DT_Prologue_Size, | |
57 | Get_Expanded_Name => RE_Get_Expanded_Name, | |
58 | Get_External_Tag => RE_Get_External_Tag, | |
59 | Get_Prim_Op_Address => RE_Get_Prim_Op_Address, | |
60 | Get_RC_Offset => RE_Get_RC_Offset, | |
61 | Get_Remotely_Callable => RE_Get_Remotely_Callable, | |
62 | Get_TSD => RE_Get_TSD, | |
63 | Inherit_DT => RE_Inherit_DT, | |
64 | Inherit_TSD => RE_Inherit_TSD, | |
65 | Register_Tag => RE_Register_Tag, | |
66 | Set_Expanded_Name => RE_Set_Expanded_Name, | |
67 | Set_External_Tag => RE_Set_External_Tag, | |
68 | Set_Prim_Op_Address => RE_Set_Prim_Op_Address, | |
69 | Set_RC_Offset => RE_Set_RC_Offset, | |
70 | Set_Remotely_Callable => RE_Set_Remotely_Callable, | |
71 | Set_TSD => RE_Set_TSD, | |
72 | TSD_Entry_Size => RE_TSD_Entry_Size, | |
73 | TSD_Prologue_Size => RE_TSD_Prologue_Size); | |
74 | ||
75 | CPP_Actions : constant array (DT_Access_Action) of RE_Id := | |
76 | (CW_Membership => RE_CPP_CW_Membership, | |
77 | DT_Entry_Size => RE_CPP_DT_Entry_Size, | |
78 | DT_Prologue_Size => RE_CPP_DT_Prologue_Size, | |
79 | Get_Expanded_Name => RE_CPP_Get_Expanded_Name, | |
80 | Get_External_Tag => RE_CPP_Get_External_Tag, | |
81 | Get_Prim_Op_Address => RE_CPP_Get_Prim_Op_Address, | |
82 | Get_RC_Offset => RE_CPP_Get_RC_Offset, | |
83 | Get_Remotely_Callable => RE_CPP_Get_Remotely_Callable, | |
84 | Get_TSD => RE_CPP_Get_TSD, | |
85 | Inherit_DT => RE_CPP_Inherit_DT, | |
86 | Inherit_TSD => RE_CPP_Inherit_TSD, | |
87 | Register_Tag => RE_CPP_Register_Tag, | |
88 | Set_Expanded_Name => RE_CPP_Set_Expanded_Name, | |
89 | Set_External_Tag => RE_CPP_Set_External_Tag, | |
90 | Set_Prim_Op_Address => RE_CPP_Set_Prim_Op_Address, | |
91 | Set_RC_Offset => RE_CPP_Set_RC_Offset, | |
92 | Set_Remotely_Callable => RE_CPP_Set_Remotely_Callable, | |
93 | Set_TSD => RE_CPP_Set_TSD, | |
94 | TSD_Entry_Size => RE_CPP_TSD_Entry_Size, | |
95 | TSD_Prologue_Size => RE_CPP_TSD_Prologue_Size); | |
96 | ||
97 | Action_Is_Proc : constant array (DT_Access_Action) of Boolean := | |
98 | (CW_Membership => False, | |
99 | DT_Entry_Size => False, | |
100 | DT_Prologue_Size => False, | |
101 | Get_Expanded_Name => False, | |
102 | Get_External_Tag => False, | |
103 | Get_Prim_Op_Address => False, | |
104 | Get_Remotely_Callable => False, | |
105 | Get_RC_Offset => False, | |
106 | Get_TSD => False, | |
107 | Inherit_DT => True, | |
108 | Inherit_TSD => True, | |
109 | Register_Tag => True, | |
110 | Set_Expanded_Name => True, | |
111 | Set_External_Tag => True, | |
112 | Set_Prim_Op_Address => True, | |
113 | Set_RC_Offset => True, | |
114 | Set_Remotely_Callable => True, | |
115 | Set_TSD => True, | |
116 | TSD_Entry_Size => False, | |
117 | TSD_Prologue_Size => False); | |
118 | ||
119 | Action_Nb_Arg : constant array (DT_Access_Action) of Int := | |
120 | (CW_Membership => 2, | |
121 | DT_Entry_Size => 0, | |
122 | DT_Prologue_Size => 0, | |
123 | Get_Expanded_Name => 1, | |
124 | Get_External_Tag => 1, | |
125 | Get_Prim_Op_Address => 2, | |
126 | Get_RC_Offset => 1, | |
127 | Get_Remotely_Callable => 1, | |
128 | Get_TSD => 1, | |
129 | Inherit_DT => 3, | |
130 | Inherit_TSD => 2, | |
131 | Register_Tag => 1, | |
132 | Set_Expanded_Name => 2, | |
133 | Set_External_Tag => 2, | |
134 | Set_Prim_Op_Address => 3, | |
135 | Set_RC_Offset => 2, | |
136 | Set_Remotely_Callable => 2, | |
137 | Set_TSD => 2, | |
138 | TSD_Entry_Size => 0, | |
139 | TSD_Prologue_Size => 0); | |
140 | ||
141 | function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; | |
142 | -- Check if the type has a private view or if the public view appears | |
143 | -- in the visible part of a package spec. | |
144 | ||
145 | -------------------------- | |
146 | -- Expand_Dispatch_Call -- | |
147 | -------------------------- | |
148 | ||
149 | procedure Expand_Dispatch_Call (Call_Node : Node_Id) is | |
150 | Loc : constant Source_Ptr := Sloc (Call_Node); | |
151 | Call_Typ : constant Entity_Id := Etype (Call_Node); | |
152 | ||
153 | Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); | |
154 | Param_List : constant List_Id := Parameter_Associations (Call_Node); | |
155 | Subp : Entity_Id := Entity (Name (Call_Node)); | |
156 | ||
157 | CW_Typ : Entity_Id; | |
158 | New_Call : Node_Id; | |
159 | New_Call_Name : Node_Id; | |
160 | New_Params : List_Id := No_List; | |
161 | Param : Node_Id; | |
162 | Res_Typ : Entity_Id; | |
163 | Subp_Ptr_Typ : Entity_Id; | |
164 | Subp_Typ : Entity_Id; | |
165 | Typ : Entity_Id; | |
166 | Eq_Prim_Op : Entity_Id := Empty; | |
167 | ||
168 | function New_Value (From : Node_Id) return Node_Id; | |
fbf5a39b AC |
169 | -- From is the original Expression. New_Value is equivalent to a call |
170 | -- to Duplicate_Subexpr with an explicit dereference when From is an | |
70482933 RK |
171 | -- access parameter |
172 | ||
fbf5a39b AC |
173 | --------------- |
174 | -- New_Value -- | |
175 | --------------- | |
176 | ||
70482933 RK |
177 | function New_Value (From : Node_Id) return Node_Id is |
178 | Res : constant Node_Id := Duplicate_Subexpr (From); | |
179 | ||
180 | begin | |
181 | if Is_Access_Type (Etype (From)) then | |
182 | return Make_Explicit_Dereference (Sloc (From), Res); | |
183 | else | |
184 | return Res; | |
185 | end if; | |
186 | end New_Value; | |
187 | ||
188 | -- Start of processing for Expand_Dispatch_Call | |
189 | ||
190 | begin | |
191 | -- If this is an inherited operation that was overriden, the body | |
192 | -- that is being called is its alias. | |
193 | ||
194 | if Present (Alias (Subp)) | |
195 | and then Is_Inherited_Operation (Subp) | |
196 | and then No (DTC_Entity (Subp)) | |
197 | then | |
198 | Subp := Alias (Subp); | |
199 | end if; | |
200 | ||
201 | -- Expand_Dispatch is called directly from the semantics, so we need | |
202 | -- a check to see whether expansion is active before proceeding | |
203 | ||
204 | if not Expander_Active then | |
205 | return; | |
206 | end if; | |
207 | ||
208 | -- Definition of the ClassWide Type and the Tagged type | |
209 | ||
210 | if Is_Access_Type (Etype (Ctrl_Arg)) then | |
211 | CW_Typ := Designated_Type (Etype (Ctrl_Arg)); | |
212 | else | |
213 | CW_Typ := Etype (Ctrl_Arg); | |
214 | end if; | |
215 | ||
216 | Typ := Root_Type (CW_Typ); | |
217 | ||
218 | if not Is_Limited_Type (Typ) then | |
219 | Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); | |
220 | end if; | |
221 | ||
222 | if Is_CPP_Class (Root_Type (Typ)) then | |
223 | ||
224 | -- Create a new parameter list with the displaced 'this' | |
225 | ||
226 | New_Params := New_List; | |
227 | Param := First_Actual (Call_Node); | |
228 | while Present (Param) loop | |
229 | ||
230 | -- We assume that dispatching through the main dispatch table | |
231 | -- (referenced by Tag_Component) doesn't require a displacement | |
232 | -- so the expansion below is only done when dispatching on | |
233 | -- another vtable pointer, in which case the first argument | |
234 | -- is expanded into : | |
235 | ||
236 | -- typ!(Displaced_This (Address!(Param))) | |
237 | ||
238 | if Param = Ctrl_Arg | |
239 | and then DTC_Entity (Subp) /= Tag_Component (Typ) | |
240 | then | |
241 | Append_To (New_Params, | |
242 | ||
243 | Unchecked_Convert_To (Etype (Param), | |
244 | Make_Function_Call (Loc, | |
245 | Name => New_Reference_To (RTE (RE_Displaced_This), Loc), | |
246 | Parameter_Associations => New_List ( | |
247 | ||
248 | -- Current_This | |
249 | ||
250 | Make_Unchecked_Type_Conversion (Loc, | |
251 | Subtype_Mark => | |
252 | New_Reference_To (RTE (RE_Address), Loc), | |
253 | Expression => Relocate_Node (Param)), | |
254 | ||
255 | -- Vptr | |
256 | ||
257 | Make_Selected_Component (Loc, | |
258 | Prefix => Duplicate_Subexpr (Ctrl_Arg), | |
259 | Selector_Name => | |
260 | New_Reference_To (DTC_Entity (Subp), Loc)), | |
261 | ||
262 | -- Position | |
263 | ||
264 | Make_Integer_Literal (Loc, DT_Position (Subp)))))); | |
265 | ||
266 | else | |
267 | Append_To (New_Params, Relocate_Node (Param)); | |
268 | end if; | |
269 | ||
270 | Next_Actual (Param); | |
271 | end loop; | |
272 | ||
273 | elsif Present (Param_List) then | |
274 | ||
275 | -- Generate the Tag checks when appropriate | |
276 | ||
277 | New_Params := New_List; | |
278 | ||
279 | Param := First_Actual (Call_Node); | |
280 | while Present (Param) loop | |
281 | ||
282 | -- No tag check with itself | |
283 | ||
284 | if Param = Ctrl_Arg then | |
fbf5a39b AC |
285 | Append_To (New_Params, |
286 | Duplicate_Subexpr_Move_Checks (Param)); | |
70482933 RK |
287 | |
288 | -- No tag check for parameter whose type is neither tagged nor | |
289 | -- access to tagged (for access parameters) | |
290 | ||
291 | elsif No (Find_Controlling_Arg (Param)) then | |
292 | Append_To (New_Params, Relocate_Node (Param)); | |
293 | ||
294 | -- No tag check for function dispatching on result it the | |
295 | -- Tag given by the context is this one | |
296 | ||
297 | elsif Find_Controlling_Arg (Param) = Ctrl_Arg then | |
298 | Append_To (New_Params, Relocate_Node (Param)); | |
299 | ||
300 | -- "=" is the only dispatching operation allowed to get | |
301 | -- operands with incompatible tags (it just returns false). | |
fbf5a39b AC |
302 | -- We use Duplicate_Subexpr_Move_Checks instead of calling |
303 | -- Relocate_Node because the value will be duplicated to | |
304 | -- check the tags. | |
70482933 RK |
305 | |
306 | elsif Subp = Eq_Prim_Op then | |
fbf5a39b AC |
307 | Append_To (New_Params, |
308 | Duplicate_Subexpr_Move_Checks (Param)); | |
70482933 RK |
309 | |
310 | -- No check in presence of suppress flags | |
311 | ||
312 | elsif Tag_Checks_Suppressed (Etype (Param)) | |
313 | or else (Is_Access_Type (Etype (Param)) | |
314 | and then Tag_Checks_Suppressed | |
315 | (Designated_Type (Etype (Param)))) | |
316 | then | |
317 | Append_To (New_Params, Relocate_Node (Param)); | |
318 | ||
319 | -- Optimization: no tag checks if the parameters are identical | |
320 | ||
321 | elsif Is_Entity_Name (Param) | |
322 | and then Is_Entity_Name (Ctrl_Arg) | |
323 | and then Entity (Param) = Entity (Ctrl_Arg) | |
324 | then | |
325 | Append_To (New_Params, Relocate_Node (Param)); | |
326 | ||
327 | -- Now we need to generate the Tag check | |
328 | ||
329 | else | |
330 | -- Generate code for tag equality check | |
331 | -- Perhaps should have Checks.Apply_Tag_Equality_Check??? | |
332 | ||
333 | Insert_Action (Ctrl_Arg, | |
334 | Make_Implicit_If_Statement (Call_Node, | |
335 | Condition => | |
336 | Make_Op_Ne (Loc, | |
337 | Left_Opnd => | |
338 | Make_Selected_Component (Loc, | |
339 | Prefix => New_Value (Ctrl_Arg), | |
340 | Selector_Name => | |
341 | New_Reference_To (Tag_Component (Typ), Loc)), | |
342 | ||
343 | Right_Opnd => | |
344 | Make_Selected_Component (Loc, | |
345 | Prefix => | |
346 | Unchecked_Convert_To (Typ, New_Value (Param)), | |
347 | Selector_Name => | |
348 | New_Reference_To (Tag_Component (Typ), Loc))), | |
349 | ||
350 | Then_Statements => | |
351 | New_List (New_Constraint_Error (Loc)))); | |
352 | ||
353 | Append_To (New_Params, Relocate_Node (Param)); | |
354 | end if; | |
355 | ||
356 | Next_Actual (Param); | |
357 | end loop; | |
358 | end if; | |
359 | ||
360 | -- Generate the appropriate subprogram pointer type | |
361 | ||
362 | if Etype (Subp) = Typ then | |
363 | Res_Typ := CW_Typ; | |
364 | else | |
365 | Res_Typ := Etype (Subp); | |
366 | end if; | |
367 | ||
368 | Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node); | |
369 | Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node); | |
370 | Set_Etype (Subp_Typ, Res_Typ); | |
371 | Init_Size_Align (Subp_Ptr_Typ); | |
372 | Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); | |
373 | ||
374 | -- Create a new list of parameters which is a copy of the old formal | |
375 | -- list including the creation of a new set of matching entities. | |
376 | ||
377 | declare | |
378 | Old_Formal : Entity_Id := First_Formal (Subp); | |
379 | New_Formal : Entity_Id; | |
380 | Extra : Entity_Id; | |
381 | ||
382 | begin | |
383 | if Present (Old_Formal) then | |
384 | New_Formal := New_Copy (Old_Formal); | |
385 | Set_First_Entity (Subp_Typ, New_Formal); | |
386 | Param := First_Actual (Call_Node); | |
387 | ||
388 | loop | |
389 | Set_Scope (New_Formal, Subp_Typ); | |
390 | ||
391 | -- Change all the controlling argument types to be class-wide | |
392 | -- to avoid a recursion in dispatching | |
393 | ||
394 | if Is_Controlling_Actual (Param) then | |
395 | Set_Etype (New_Formal, Etype (Param)); | |
396 | end if; | |
397 | ||
398 | if Is_Itype (Etype (New_Formal)) then | |
399 | Extra := New_Copy (Etype (New_Formal)); | |
400 | ||
401 | if Ekind (Extra) = E_Record_Subtype | |
402 | or else Ekind (Extra) = E_Class_Wide_Subtype | |
403 | then | |
404 | Set_Cloned_Subtype (Extra, Etype (New_Formal)); | |
405 | end if; | |
406 | ||
407 | Set_Etype (New_Formal, Extra); | |
408 | Set_Scope (Etype (New_Formal), Subp_Typ); | |
409 | end if; | |
410 | ||
411 | Extra := New_Formal; | |
412 | Next_Formal (Old_Formal); | |
413 | exit when No (Old_Formal); | |
414 | ||
415 | Set_Next_Entity (New_Formal, New_Copy (Old_Formal)); | |
416 | Next_Entity (New_Formal); | |
417 | Next_Actual (Param); | |
418 | end loop; | |
419 | Set_Last_Entity (Subp_Typ, Extra); | |
420 | ||
421 | -- Copy extra formals | |
422 | ||
423 | New_Formal := First_Entity (Subp_Typ); | |
424 | while Present (New_Formal) loop | |
425 | if Present (Extra_Constrained (New_Formal)) then | |
426 | Set_Extra_Formal (Extra, | |
427 | New_Copy (Extra_Constrained (New_Formal))); | |
428 | Extra := Extra_Formal (Extra); | |
429 | Set_Extra_Constrained (New_Formal, Extra); | |
430 | ||
431 | elsif Present (Extra_Accessibility (New_Formal)) then | |
432 | Set_Extra_Formal (Extra, | |
433 | New_Copy (Extra_Accessibility (New_Formal))); | |
434 | Extra := Extra_Formal (Extra); | |
435 | Set_Extra_Accessibility (New_Formal, Extra); | |
436 | end if; | |
437 | ||
438 | Next_Formal (New_Formal); | |
439 | end loop; | |
440 | end if; | |
441 | end; | |
442 | ||
443 | Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); | |
444 | Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ); | |
445 | ||
446 | -- Generate: | |
447 | -- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos)); | |
448 | ||
449 | New_Call_Name := | |
450 | Unchecked_Convert_To (Subp_Ptr_Typ, | |
451 | Make_DT_Access_Action (Typ, | |
452 | Action => Get_Prim_Op_Address, | |
453 | Args => New_List ( | |
454 | ||
455 | -- Vptr | |
456 | ||
457 | Make_Selected_Component (Loc, | |
fbf5a39b | 458 | Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg), |
70482933 RK |
459 | Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc)), |
460 | ||
461 | -- Position | |
462 | ||
463 | Make_Integer_Literal (Loc, DT_Position (Subp))))); | |
464 | ||
465 | if Nkind (Call_Node) = N_Function_Call then | |
466 | New_Call := | |
467 | Make_Function_Call (Loc, | |
468 | Name => New_Call_Name, | |
469 | Parameter_Associations => New_Params); | |
470 | ||
471 | -- if this is a dispatching "=", we must first compare the tags so | |
472 | -- we generate: x.tag = y.tag and then x = y | |
473 | ||
474 | if Subp = Eq_Prim_Op then | |
475 | ||
476 | Param := First_Actual (Call_Node); | |
477 | New_Call := | |
478 | Make_And_Then (Loc, | |
479 | Left_Opnd => | |
480 | Make_Op_Eq (Loc, | |
481 | Left_Opnd => | |
482 | Make_Selected_Component (Loc, | |
483 | Prefix => New_Value (Param), | |
484 | Selector_Name => | |
485 | New_Reference_To (Tag_Component (Typ), Loc)), | |
486 | ||
487 | Right_Opnd => | |
488 | Make_Selected_Component (Loc, | |
489 | Prefix => | |
490 | Unchecked_Convert_To (Typ, | |
491 | New_Value (Next_Actual (Param))), | |
492 | Selector_Name => | |
493 | New_Reference_To (Tag_Component (Typ), Loc))), | |
494 | ||
495 | Right_Opnd => New_Call); | |
496 | end if; | |
497 | ||
498 | else | |
499 | New_Call := | |
500 | Make_Procedure_Call_Statement (Loc, | |
501 | Name => New_Call_Name, | |
502 | Parameter_Associations => New_Params); | |
503 | end if; | |
504 | ||
505 | Rewrite (Call_Node, New_Call); | |
506 | Analyze_And_Resolve (Call_Node, Call_Typ); | |
507 | end Expand_Dispatch_Call; | |
508 | ||
509 | ------------- | |
510 | -- Fill_DT -- | |
511 | ------------- | |
512 | ||
513 | function Fill_DT_Entry | |
514 | (Loc : Source_Ptr; | |
515 | Prim : Entity_Id) | |
516 | return Node_Id | |
517 | is | |
518 | Typ : constant Entity_Id := Scope (DTC_Entity (Prim)); | |
519 | DT_Ptr : constant Entity_Id := Access_Disp_Table (Typ); | |
520 | ||
521 | begin | |
522 | return | |
523 | Make_DT_Access_Action (Typ, | |
524 | Action => Set_Prim_Op_Address, | |
525 | Args => New_List ( | |
526 | New_Reference_To (DT_Ptr, Loc), -- DTptr | |
527 | ||
528 | Make_Integer_Literal (Loc, DT_Position (Prim)), -- Position | |
529 | ||
530 | Make_Attribute_Reference (Loc, -- Value | |
531 | Prefix => New_Reference_To (Prim, Loc), | |
532 | Attribute_Name => Name_Address))); | |
533 | end Fill_DT_Entry; | |
534 | ||
535 | --------------------------- | |
536 | -- Get_Remotely_Callable -- | |
537 | --------------------------- | |
538 | ||
539 | function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is | |
540 | Loc : constant Source_Ptr := Sloc (Obj); | |
541 | ||
542 | begin | |
543 | return Make_DT_Access_Action | |
544 | (Typ => Etype (Obj), | |
545 | Action => Get_Remotely_Callable, | |
546 | Args => New_List ( | |
547 | Make_Selected_Component (Loc, | |
548 | Prefix => Obj, | |
549 | Selector_Name => Make_Identifier (Loc, Name_uTag)))); | |
550 | end Get_Remotely_Callable; | |
551 | ||
552 | ------------- | |
553 | -- Make_DT -- | |
554 | ------------- | |
555 | ||
556 | function Make_DT (Typ : Entity_Id) return List_Id is | |
557 | Loc : constant Source_Ptr := Sloc (Typ); | |
558 | ||
559 | Result : constant List_Id := New_List; | |
560 | Elab_Code : constant List_Id := New_List; | |
561 | ||
562 | Tname : constant Name_Id := Chars (Typ); | |
563 | Name_DT : constant Name_Id := New_External_Name (Tname, 'T'); | |
564 | Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P'); | |
565 | Name_TSD : constant Name_Id := New_External_Name (Tname, 'B'); | |
566 | Name_Exname : constant Name_Id := New_External_Name (Tname, 'E'); | |
567 | Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F'); | |
568 | ||
569 | DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT); | |
570 | DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr); | |
571 | TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD); | |
572 | Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname); | |
573 | No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg); | |
574 | ||
575 | I_Depth : Int; | |
576 | Generalized_Tag : Entity_Id; | |
577 | Size_Expr_Node : Node_Id; | |
578 | Old_Tag : Node_Id; | |
579 | Old_TSD : Node_Id; | |
580 | ||
581 | begin | |
fbf5a39b AC |
582 | if not RTE_Available (RE_Tag) then |
583 | Error_Msg_CRT ("tagged types", Typ); | |
584 | return New_List; | |
585 | end if; | |
586 | ||
70482933 RK |
587 | if Is_CPP_Class (Root_Type (Typ)) then |
588 | Generalized_Tag := RTE (RE_Vtable_Ptr); | |
589 | else | |
590 | Generalized_Tag := RTE (RE_Tag); | |
591 | end if; | |
592 | ||
593 | -- Dispatch table and related entities are allocated statically | |
594 | ||
595 | Set_Ekind (DT, E_Variable); | |
596 | Set_Is_Statically_Allocated (DT); | |
597 | ||
598 | Set_Ekind (DT_Ptr, E_Variable); | |
599 | Set_Is_Statically_Allocated (DT_Ptr); | |
600 | ||
601 | Set_Ekind (TSD, E_Variable); | |
602 | Set_Is_Statically_Allocated (TSD); | |
603 | ||
604 | Set_Ekind (Exname, E_Variable); | |
605 | Set_Is_Statically_Allocated (Exname); | |
606 | ||
607 | Set_Ekind (No_Reg, E_Variable); | |
608 | Set_Is_Statically_Allocated (No_Reg); | |
609 | ||
610 | -- Generate code to create the storage for the Dispatch_Table object: | |
611 | ||
612 | -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size); | |
613 | -- for DT'Alignment use Address'Alignment | |
614 | ||
615 | Size_Expr_Node := | |
616 | Make_Op_Add (Loc, | |
617 | Left_Opnd => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List), | |
618 | Right_Opnd => | |
619 | Make_Op_Multiply (Loc, | |
620 | Left_Opnd => | |
621 | Make_DT_Access_Action (Typ, DT_Entry_Size, No_List), | |
622 | Right_Opnd => | |
623 | Make_Integer_Literal (Loc, | |
624 | DT_Entry_Count (Tag_Component (Typ))))); | |
625 | ||
626 | Append_To (Result, | |
627 | Make_Object_Declaration (Loc, | |
628 | Defining_Identifier => DT, | |
629 | Aliased_Present => True, | |
630 | Object_Definition => | |
631 | Make_Subtype_Indication (Loc, | |
632 | Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), | |
633 | Constraint => Make_Index_Or_Discriminant_Constraint (Loc, | |
634 | Constraints => New_List ( | |
635 | Make_Range (Loc, | |
636 | Low_Bound => Make_Integer_Literal (Loc, 1), | |
637 | High_Bound => Size_Expr_Node)))))); | |
638 | ||
639 | Append_To (Result, | |
640 | Make_Attribute_Definition_Clause (Loc, | |
641 | Name => New_Reference_To (DT, Loc), | |
642 | Chars => Name_Alignment, | |
643 | Expression => | |
644 | Make_Attribute_Reference (Loc, | |
645 | Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), | |
646 | Attribute_Name => Name_Alignment))); | |
647 | ||
648 | -- Generate code to create the pointer to the dispatch table | |
649 | ||
650 | -- DT_Ptr : Tag := Tag!(DT'Address); Ada case | |
651 | -- or | |
652 | -- DT_Ptr : Vtable_Ptr := Vtable_Ptr!(DT'Address); CPP case | |
653 | ||
654 | Append_To (Result, | |
655 | Make_Object_Declaration (Loc, | |
656 | Defining_Identifier => DT_Ptr, | |
657 | Constant_Present => True, | |
658 | Object_Definition => New_Reference_To (Generalized_Tag, Loc), | |
659 | Expression => | |
660 | Unchecked_Convert_To (Generalized_Tag, | |
661 | Make_Attribute_Reference (Loc, | |
662 | Prefix => New_Reference_To (DT, Loc), | |
663 | Attribute_Name => Name_Address)))); | |
664 | ||
665 | -- Generate code to define the boolean that controls registration, in | |
666 | -- order to avoid multiple registrations for tagged types defined in | |
667 | -- multiple-called scopes | |
668 | ||
669 | Append_To (Result, | |
670 | Make_Object_Declaration (Loc, | |
671 | Defining_Identifier => No_Reg, | |
672 | Object_Definition => New_Reference_To (Standard_Boolean, Loc), | |
673 | Expression => New_Reference_To (Standard_True, Loc))); | |
674 | ||
675 | -- Set Access_Disp_Table field to be the dispatch table pointer | |
676 | ||
677 | Set_Access_Disp_Table (Typ, DT_Ptr); | |
678 | ||
679 | -- Count ancestors to compute the inheritance depth. For private | |
680 | -- extensions, always go to the full view in order to compute the real | |
681 | -- inheritance depth. | |
682 | ||
683 | declare | |
684 | Parent_Type : Entity_Id := Typ; | |
685 | P : Entity_Id; | |
686 | ||
687 | begin | |
688 | I_Depth := 0; | |
689 | ||
690 | loop | |
691 | P := Etype (Parent_Type); | |
692 | ||
693 | if Is_Private_Type (P) then | |
694 | P := Full_View (Base_Type (P)); | |
695 | end if; | |
696 | ||
697 | exit when P = Parent_Type; | |
698 | ||
699 | I_Depth := I_Depth + 1; | |
700 | Parent_Type := P; | |
701 | end loop; | |
702 | end; | |
703 | ||
704 | -- Generate code to create the storage for the type specific data object | |
705 | ||
706 | -- TSD: Storage_Array (1..TSD_Prologue_Size+(1+Idepth)*TSD_Entry_Size); | |
707 | -- for TSD'Alignment use Address'Alignment | |
708 | ||
709 | Size_Expr_Node := | |
710 | Make_Op_Add (Loc, | |
711 | Left_Opnd => | |
712 | Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List), | |
713 | Right_Opnd => | |
714 | Make_Op_Multiply (Loc, | |
715 | Left_Opnd => | |
716 | Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List), | |
717 | Right_Opnd => | |
718 | Make_Op_Add (Loc, | |
719 | Left_Opnd => Make_Integer_Literal (Loc, 1), | |
720 | Right_Opnd => | |
721 | Make_Integer_Literal (Loc, I_Depth)))); | |
722 | ||
723 | Append_To (Result, | |
724 | Make_Object_Declaration (Loc, | |
725 | Defining_Identifier => TSD, | |
726 | Aliased_Present => True, | |
727 | Object_Definition => | |
728 | Make_Subtype_Indication (Loc, | |
729 | Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), | |
730 | Constraint => Make_Index_Or_Discriminant_Constraint (Loc, | |
731 | Constraints => New_List ( | |
732 | Make_Range (Loc, | |
733 | Low_Bound => Make_Integer_Literal (Loc, 1), | |
734 | High_Bound => Size_Expr_Node)))))); | |
735 | ||
736 | Append_To (Result, | |
737 | Make_Attribute_Definition_Clause (Loc, | |
738 | Name => New_Reference_To (TSD, Loc), | |
739 | Chars => Name_Alignment, | |
740 | Expression => | |
741 | Make_Attribute_Reference (Loc, | |
742 | Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), | |
743 | Attribute_Name => Name_Alignment))); | |
744 | ||
745 | -- Generate code to put the Address of the TSD in the dispatch table | |
746 | -- Set_TSD (DT_Ptr, TSD); | |
747 | ||
748 | Append_To (Elab_Code, | |
749 | Make_DT_Access_Action (Typ, | |
750 | Action => Set_TSD, | |
751 | Args => New_List ( | |
752 | New_Reference_To (DT_Ptr, Loc), -- DTptr | |
753 | Make_Attribute_Reference (Loc, -- Value | |
754 | Prefix => New_Reference_To (TSD, Loc), | |
755 | Attribute_Name => Name_Address)))); | |
756 | ||
757 | if Typ = Etype (Typ) | |
758 | or else Is_CPP_Class (Etype (Typ)) | |
759 | then | |
760 | Old_Tag := | |
761 | Unchecked_Convert_To (Generalized_Tag, | |
762 | Make_Integer_Literal (Loc, 0)); | |
763 | ||
764 | Old_TSD := | |
765 | Unchecked_Convert_To (RTE (RE_Address), | |
766 | Make_Integer_Literal (Loc, 0)); | |
767 | ||
768 | else | |
769 | Old_Tag := New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc); | |
770 | Old_TSD := | |
771 | Make_DT_Access_Action (Typ, | |
772 | Action => Get_TSD, | |
773 | Args => New_List ( | |
774 | New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc))); | |
775 | end if; | |
776 | ||
777 | -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent); | |
778 | ||
779 | Append_To (Elab_Code, | |
780 | Make_DT_Access_Action (Typ, | |
781 | Action => Inherit_DT, | |
782 | Args => New_List ( | |
783 | Node1 => Old_Tag, | |
784 | Node2 => New_Reference_To (DT_Ptr, Loc), | |
785 | Node3 => Make_Integer_Literal (Loc, | |
786 | DT_Entry_Count (Tag_Component (Etype (Typ))))))); | |
787 | ||
788 | -- Generate: Inherit_TSD (Get_TSD (parent), DT_Ptr); | |
789 | ||
790 | Append_To (Elab_Code, | |
791 | Make_DT_Access_Action (Typ, | |
792 | Action => Inherit_TSD, | |
793 | Args => New_List ( | |
794 | Node1 => Old_TSD, | |
795 | Node2 => New_Reference_To (DT_Ptr, Loc)))); | |
796 | ||
797 | -- Generate: Exname : constant String := full_qualified_name (typ); | |
798 | -- The type itself may be an anonymous parent type, so use the first | |
799 | -- subtype to have a user-recognizable name. | |
800 | ||
801 | Append_To (Result, | |
802 | Make_Object_Declaration (Loc, | |
803 | Defining_Identifier => Exname, | |
804 | Constant_Present => True, | |
805 | Object_Definition => New_Reference_To (Standard_String, Loc), | |
806 | Expression => | |
807 | Make_String_Literal (Loc, | |
808 | Full_Qualified_Name (First_Subtype (Typ))))); | |
809 | ||
810 | -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address); | |
811 | ||
812 | Append_To (Elab_Code, | |
813 | Make_DT_Access_Action (Typ, | |
814 | Action => Set_Expanded_Name, | |
815 | Args => New_List ( | |
816 | Node1 => New_Reference_To (DT_Ptr, Loc), | |
817 | Node2 => | |
818 | Make_Attribute_Reference (Loc, | |
819 | Prefix => New_Reference_To (Exname, Loc), | |
820 | Attribute_Name => Name_Address)))); | |
821 | ||
822 | -- for types with no controlled components | |
823 | -- Generate: Set_RC_Offset (DT_Ptr, 0); | |
824 | -- for simple types with controlled components | |
825 | -- Generate: Set_RC_Offset (DT_Ptr, type._record_controller'position); | |
826 | -- for complex types with controlled components where the position | |
fbf5a39b AC |
827 | -- of the record controller is not statically computable, if there are |
828 | -- controlled components at this level | |
70482933 | 829 | -- Generate: Set_RC_Offset (DT_Ptr, -1); |
fbf5a39b AC |
830 | -- to indicate that the _controller field is right after the _parent or |
831 | -- if there are no controlled components at this level, | |
832 | -- Generate: Set_RC_Offset (DT_Ptr, -2); | |
833 | -- to indicate that we need to get the position from the parent. | |
70482933 RK |
834 | |
835 | declare | |
836 | Position : Node_Id; | |
837 | ||
838 | begin | |
839 | if not Has_Controlled_Component (Typ) then | |
840 | Position := Make_Integer_Literal (Loc, 0); | |
841 | ||
842 | elsif Etype (Typ) /= Typ and then Has_Discriminants (Etype (Typ)) then | |
fbf5a39b AC |
843 | if Has_New_Controlled_Component (Typ) then |
844 | Position := Make_Integer_Literal (Loc, -1); | |
845 | else | |
846 | Position := Make_Integer_Literal (Loc, -2); | |
847 | end if; | |
70482933 RK |
848 | else |
849 | Position := | |
850 | Make_Attribute_Reference (Loc, | |
851 | Prefix => | |
852 | Make_Selected_Component (Loc, | |
853 | Prefix => New_Reference_To (Typ, Loc), | |
854 | Selector_Name => | |
855 | New_Reference_To (Controller_Component (Typ), Loc)), | |
856 | Attribute_Name => Name_Position); | |
857 | ||
fbf5a39b | 858 | -- This is not proper Ada code to use the attribute 'Position |
70482933 RK |
859 | -- on something else than an object but this is supported by |
860 | -- the back end (see comment on the Bit_Component attribute in | |
861 | -- sem_attr). So we avoid semantic checking here. | |
862 | ||
863 | Set_Analyzed (Position); | |
864 | Set_Etype (Prefix (Position), RTE (RE_Record_Controller)); | |
865 | Set_Etype (Prefix (Prefix (Position)), Typ); | |
866 | Set_Etype (Selector_Name (Prefix (Position)), | |
867 | RTE (RE_Record_Controller)); | |
868 | Set_Etype (Position, RTE (RE_Storage_Offset)); | |
70482933 RK |
869 | end if; |
870 | ||
871 | Append_To (Elab_Code, | |
872 | Make_DT_Access_Action (Typ, | |
873 | Action => Set_RC_Offset, | |
874 | Args => New_List ( | |
875 | Node1 => New_Reference_To (DT_Ptr, Loc), | |
876 | Node2 => Position))); | |
877 | end; | |
878 | ||
879 | -- Generate: Set_Remotely_Callable (DT_Ptr, status); | |
880 | -- where status is described in E.4 (18) | |
881 | ||
882 | declare | |
883 | Status : Entity_Id; | |
884 | ||
885 | begin | |
886 | if Is_Pure (Typ) | |
887 | or else Is_Shared_Passive (Typ) | |
888 | or else | |
889 | ((Is_Remote_Types (Typ) or else Is_Remote_Call_Interface (Typ)) | |
890 | and then Original_View_In_Visible_Part (Typ)) | |
891 | or else not Comes_From_Source (Typ) | |
892 | then | |
893 | Status := Standard_True; | |
894 | else | |
895 | Status := Standard_False; | |
896 | end if; | |
897 | ||
898 | Append_To (Elab_Code, | |
899 | Make_DT_Access_Action (Typ, | |
900 | Action => Set_Remotely_Callable, | |
901 | Args => New_List ( | |
902 | New_Occurrence_Of (DT_Ptr, Loc), | |
903 | New_Occurrence_Of (Status, Loc)))); | |
904 | end; | |
905 | ||
906 | -- Generate: Set_External_Tag (DT_Ptr, exname'Address); | |
907 | -- Should be the external name not the qualified name??? | |
908 | ||
909 | if not Has_External_Tag_Rep_Clause (Typ) then | |
910 | Append_To (Elab_Code, | |
911 | Make_DT_Access_Action (Typ, | |
912 | Action => Set_External_Tag, | |
913 | Args => New_List ( | |
914 | Node1 => New_Reference_To (DT_Ptr, Loc), | |
915 | Node2 => | |
916 | Make_Attribute_Reference (Loc, | |
917 | Prefix => New_Reference_To (Exname, Loc), | |
918 | Attribute_Name => Name_Address)))); | |
919 | ||
920 | -- Generate code to register the Tag in the External_Tag hash | |
fbf5a39b | 921 | -- table for the pure Ada type only. |
70482933 RK |
922 | |
923 | -- Register_Tag (Dt_Ptr); | |
924 | ||
fbf5a39b AC |
925 | -- Skip this if routine not available, or in No_Run_Time mode |
926 | ||
927 | if RTE_Available (RE_Register_Tag) | |
928 | and then Is_RTE (Generalized_Tag, RE_Tag) | |
929 | and then not No_Run_Time_Mode | |
70482933 RK |
930 | then |
931 | Append_To (Elab_Code, | |
932 | Make_Procedure_Call_Statement (Loc, | |
933 | Name => New_Reference_To (RTE (RE_Register_Tag), Loc), | |
934 | Parameter_Associations => | |
935 | New_List (New_Reference_To (DT_Ptr, Loc)))); | |
936 | end if; | |
937 | end if; | |
938 | ||
939 | -- Generate: | |
940 | -- if No_Reg then | |
941 | -- <elab_code> | |
942 | -- No_Reg := False; | |
943 | -- end if; | |
944 | ||
945 | Append_To (Elab_Code, | |
946 | Make_Assignment_Statement (Loc, | |
947 | Name => New_Reference_To (No_Reg, Loc), | |
948 | Expression => New_Reference_To (Standard_False, Loc))); | |
949 | ||
950 | Append_To (Result, | |
951 | Make_Implicit_If_Statement (Typ, | |
952 | Condition => New_Reference_To (No_Reg, Loc), | |
953 | Then_Statements => Elab_Code)); | |
954 | ||
955 | return Result; | |
956 | end Make_DT; | |
957 | ||
958 | --------------------------- | |
959 | -- Make_DT_Access_Action -- | |
960 | --------------------------- | |
961 | ||
962 | function Make_DT_Access_Action | |
963 | (Typ : Entity_Id; | |
964 | Action : DT_Access_Action; | |
965 | Args : List_Id) | |
966 | return Node_Id | |
967 | is | |
968 | Action_Name : Entity_Id; | |
969 | Loc : Source_Ptr; | |
970 | ||
971 | begin | |
972 | if Is_CPP_Class (Root_Type (Typ)) then | |
973 | Action_Name := RTE (CPP_Actions (Action)); | |
974 | else | |
975 | Action_Name := RTE (Ada_Actions (Action)); | |
976 | end if; | |
977 | ||
978 | if No (Args) then | |
979 | ||
980 | -- This is a constant | |
981 | ||
982 | return New_Reference_To (Action_Name, Sloc (Typ)); | |
983 | end if; | |
984 | ||
985 | pragma Assert (List_Length (Args) = Action_Nb_Arg (Action)); | |
986 | ||
987 | Loc := Sloc (First (Args)); | |
988 | ||
989 | if Action_Is_Proc (Action) then | |
990 | return | |
991 | Make_Procedure_Call_Statement (Loc, | |
992 | Name => New_Reference_To (Action_Name, Loc), | |
993 | Parameter_Associations => Args); | |
994 | ||
995 | else | |
996 | return | |
997 | Make_Function_Call (Loc, | |
998 | Name => New_Reference_To (Action_Name, Loc), | |
999 | Parameter_Associations => Args); | |
1000 | end if; | |
1001 | end Make_DT_Access_Action; | |
1002 | ||
1003 | ----------------------------------- | |
1004 | -- Original_View_In_Visible_Part -- | |
1005 | ----------------------------------- | |
1006 | ||
1007 | function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is | |
1008 | Scop : constant Entity_Id := Scope (Typ); | |
1009 | ||
1010 | begin | |
1011 | -- The scope must be a package | |
1012 | ||
1013 | if Ekind (Scop) /= E_Package | |
1014 | and then Ekind (Scop) /= E_Generic_Package | |
1015 | then | |
1016 | return False; | |
1017 | end if; | |
1018 | ||
1019 | -- A type with a private declaration has a private view declared in | |
1020 | -- the visible part. | |
1021 | ||
1022 | if Has_Private_Declaration (Typ) then | |
1023 | return True; | |
1024 | end if; | |
1025 | ||
1026 | return List_Containing (Parent (Typ)) = | |
1027 | Visible_Declarations (Specification (Unit_Declaration_Node (Scop))); | |
1028 | end Original_View_In_Visible_Part; | |
1029 | ||
1030 | ------------------------- | |
1031 | -- Set_All_DT_Position -- | |
1032 | ------------------------- | |
1033 | ||
1034 | procedure Set_All_DT_Position (Typ : Entity_Id) is | |
1035 | Parent_Typ : constant Entity_Id := Etype (Typ); | |
1036 | Root_Typ : constant Entity_Id := Root_Type (Typ); | |
1037 | First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ)); | |
1038 | The_Tag : constant Entity_Id := Tag_Component (Typ); | |
1039 | Adjusted : Boolean := False; | |
1040 | Finalized : Boolean := False; | |
1041 | Parent_EC : Int; | |
1042 | Nb_Prim : Int; | |
1043 | Prim : Entity_Id; | |
1044 | Prim_Elmt : Elmt_Id; | |
1045 | ||
1046 | begin | |
1047 | ||
1048 | -- Get Entry_Count of the parent | |
1049 | ||
1050 | if Parent_Typ /= Typ | |
1051 | and then DT_Entry_Count (Tag_Component (Parent_Typ)) /= No_Uint | |
1052 | then | |
1053 | Parent_EC := UI_To_Int (DT_Entry_Count (Tag_Component (Parent_Typ))); | |
1054 | else | |
1055 | Parent_EC := 0; | |
1056 | end if; | |
1057 | ||
1058 | -- C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable | |
1059 | -- give a coherent set of information | |
1060 | ||
1061 | if Is_CPP_Class (Root_Typ) then | |
1062 | ||
1063 | -- Compute the number of primitive operations in the main Vtable | |
1064 | -- Set their position: | |
1065 | -- - where it was set if overriden or inherited | |
1066 | -- - after the end of the parent vtable otherwise | |
1067 | ||
1068 | Prim_Elmt := First_Prim; | |
1069 | Nb_Prim := 0; | |
1070 | while Present (Prim_Elmt) loop | |
1071 | Prim := Node (Prim_Elmt); | |
1072 | ||
1073 | if not Is_CPP_Class (Typ) then | |
1074 | Set_DTC_Entity (Prim, The_Tag); | |
1075 | ||
1076 | elsif Present (Alias (Prim)) then | |
1077 | Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim))); | |
1078 | Set_DT_Position (Prim, DT_Position (Alias (Prim))); | |
1079 | ||
1080 | elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then | |
1081 | Error_Msg_NE ("is a primitive operation of&," & | |
1082 | " pragma Cpp_Virtual required", Prim, Typ); | |
1083 | end if; | |
1084 | ||
1085 | if DTC_Entity (Prim) = The_Tag then | |
1086 | ||
1087 | -- Get the slot from the parent subprogram if any | |
1088 | ||
1089 | declare | |
1090 | H : Entity_Id := Homonym (Prim); | |
1091 | ||
1092 | begin | |
1093 | while Present (H) loop | |
1094 | if Present (DTC_Entity (H)) | |
1095 | and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ | |
1096 | then | |
1097 | Set_DT_Position (Prim, DT_Position (H)); | |
1098 | exit; | |
1099 | end if; | |
1100 | ||
1101 | H := Homonym (H); | |
1102 | end loop; | |
1103 | end; | |
1104 | ||
1105 | -- Otherwise take the canonical slot after the end of the | |
1106 | -- parent Vtable | |
1107 | ||
1108 | if DT_Position (Prim) = No_Uint then | |
1109 | Nb_Prim := Nb_Prim + 1; | |
1110 | Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim)); | |
1111 | ||
1112 | elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then | |
1113 | Nb_Prim := Nb_Prim + 1; | |
1114 | end if; | |
1115 | end if; | |
1116 | ||
1117 | Next_Elmt (Prim_Elmt); | |
1118 | end loop; | |
1119 | ||
1120 | -- Check that the declared size of the Vtable is bigger or equal | |
1121 | -- than the number of primitive operations (if bigger it means that | |
1122 | -- some of the c++ virtual functions were not imported, that is | |
1123 | -- allowed) | |
1124 | ||
1125 | if DT_Entry_Count (The_Tag) = No_Uint | |
1126 | or else not Is_CPP_Class (Typ) | |
1127 | then | |
1128 | Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim)); | |
1129 | ||
1130 | elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then | |
1131 | Error_Msg_N ("not enough room in the Vtable for all virtual" | |
1132 | & " functions", The_Tag); | |
1133 | end if; | |
1134 | ||
1135 | -- Check that Positions are not duplicate nor outside the range of | |
1136 | -- the Vtable | |
1137 | ||
1138 | declare | |
1139 | Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag)); | |
1140 | Pos : Int; | |
1141 | Prim_Pos_Table : array (1 .. Size) of Entity_Id := | |
1142 | (others => Empty); | |
1143 | ||
1144 | begin | |
1145 | Prim_Elmt := First_Prim; | |
1146 | while Present (Prim_Elmt) loop | |
1147 | Prim := Node (Prim_Elmt); | |
1148 | ||
1149 | if DTC_Entity (Prim) = The_Tag then | |
1150 | Pos := UI_To_Int (DT_Position (Prim)); | |
1151 | ||
1152 | if Pos not in Prim_Pos_Table'Range then | |
1153 | Error_Msg_N | |
1154 | ("position not in range of virtual table", Prim); | |
1155 | ||
1156 | elsif Present (Prim_Pos_Table (Pos)) then | |
1157 | Error_Msg_NE ("cannot be at the same position in the" | |
1158 | & " vtable than&", Prim, Prim_Pos_Table (Pos)); | |
1159 | ||
1160 | else | |
1161 | Prim_Pos_Table (Pos) := Prim; | |
1162 | end if; | |
1163 | end if; | |
1164 | ||
1165 | Next_Elmt (Prim_Elmt); | |
1166 | end loop; | |
1167 | end; | |
1168 | ||
1169 | -- For regular Ada tagged types, just set the DT_Position for | |
1170 | -- each primitive operation. Perform some sanity checks to avoid | |
1171 | -- to build completely inconsistant dispatch tables. | |
1172 | ||
fbf5a39b AC |
1173 | -- Note that the _Size primitive is always set at position 1 in order |
1174 | -- to comply with the needs of Ada.Tags.Parent_Size (see documentation | |
1175 | -- in a-tags.ad?) | |
70482933 | 1176 | |
fbf5a39b AC |
1177 | else |
1178 | Nb_Prim := 1; | |
70482933 RK |
1179 | Prim_Elmt := First_Prim; |
1180 | while Present (Prim_Elmt) loop | |
1181 | Nb_Prim := Nb_Prim + 1; | |
1182 | Prim := Node (Prim_Elmt); | |
1183 | Set_DTC_Entity (Prim, The_Tag); | |
fbf5a39b AC |
1184 | |
1185 | if Chars (Prim) = Name_uSize then | |
1186 | Set_DT_Position (Prim, Uint_1); | |
1187 | Nb_Prim := Nb_Prim - 1; | |
1188 | else | |
1189 | Set_DT_Position (Prim, UI_From_Int (Nb_Prim)); | |
1190 | end if; | |
70482933 RK |
1191 | |
1192 | if Chars (Prim) = Name_Finalize | |
fbf5a39b AC |
1193 | and then |
1194 | (Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) | |
1195 | or else not Is_Predefined_File_Name | |
1196 | (Unit_File_Name (Get_Source_Unit (Prim)))) | |
70482933 RK |
1197 | then |
1198 | Finalized := True; | |
1199 | end if; | |
1200 | ||
1201 | if Chars (Prim) = Name_Adjust then | |
1202 | Adjusted := True; | |
1203 | end if; | |
1204 | ||
1205 | -- An abstract operation cannot be declared in the private part | |
1206 | -- for a visible abstract type, because it could never be over- | |
1207 | -- ridden. For explicit declarations this is checked at the point | |
1208 | -- of declaration, but for inherited operations it must be done | |
1209 | -- when building the dispatch table. Input is excluded because | |
70482933 RK |
1210 | |
1211 | if Is_Abstract (Typ) | |
1212 | and then Is_Abstract (Prim) | |
1213 | and then Present (Alias (Prim)) | |
1214 | and then Is_Derived_Type (Typ) | |
1215 | and then In_Private_Part (Current_Scope) | |
1216 | and then List_Containing (Parent (Prim)) | |
1217 | = Private_Declarations | |
1218 | (Specification (Unit_Declaration_Node (Current_Scope))) | |
1219 | and then Original_View_In_Visible_Part (Typ) | |
70482933 | 1220 | then |
fbf5a39b AC |
1221 | -- We exclude Input and Output stream operations because |
1222 | -- Limited_Controlled inherits useless Input and Output | |
1223 | -- stream operations from Root_Controlled, which can | |
1224 | -- never be overridden. | |
1225 | ||
1226 | if not Is_TSS (Prim, TSS_Stream_Input) | |
1227 | and then | |
1228 | not Is_TSS (Prim, TSS_Stream_Output) | |
1229 | then | |
1230 | Error_Msg_NE | |
1231 | ("abstract inherited private operation&" & | |
1232 | " must be overridden ('R'M 3.9.3(10))", | |
1233 | Parent (Typ), Prim); | |
1234 | end if; | |
70482933 RK |
1235 | end if; |
1236 | Next_Elmt (Prim_Elmt); | |
1237 | end loop; | |
1238 | ||
1239 | if Is_Controlled (Typ) then | |
1240 | if not Finalized then | |
1241 | Error_Msg_N | |
1242 | ("controlled type has no explicit Finalize method?", Typ); | |
1243 | ||
1244 | elsif not Adjusted then | |
1245 | Error_Msg_N | |
1246 | ("controlled type has no explicit Adjust method?", Typ); | |
1247 | end if; | |
1248 | end if; | |
1249 | ||
1250 | Set_DT_Entry_Count (The_Tag, UI_From_Int (Nb_Prim)); | |
1251 | ||
fbf5a39b AC |
1252 | -- The derived type must have at least as many components as its |
1253 | -- parent (for root types, the Etype points back to itself | |
70482933 RK |
1254 | -- and the test should not fail) |
1255 | ||
1256 | pragma Assert ( | |
1257 | DT_Entry_Count (The_Tag) >= | |
1258 | DT_Entry_Count (Tag_Component (Parent_Typ))); | |
1259 | end if; | |
1260 | end Set_All_DT_Position; | |
1261 | ||
1262 | ----------------------------- | |
1263 | -- Set_Default_Constructor -- | |
1264 | ----------------------------- | |
1265 | ||
1266 | procedure Set_Default_Constructor (Typ : Entity_Id) is | |
1267 | Loc : Source_Ptr; | |
1268 | Init : Entity_Id; | |
1269 | Param : Entity_Id; | |
70482933 RK |
1270 | E : Entity_Id; |
1271 | ||
1272 | begin | |
1273 | -- Look for the default constructor entity. For now only the | |
1274 | -- default constructor has the flag Is_Constructor. | |
1275 | ||
1276 | E := Next_Entity (Typ); | |
1277 | while Present (E) | |
1278 | and then (Ekind (E) /= E_Function or else not Is_Constructor (E)) | |
1279 | loop | |
1280 | Next_Entity (E); | |
1281 | end loop; | |
1282 | ||
1283 | -- Create the init procedure | |
1284 | ||
1285 | if Present (E) then | |
1286 | Loc := Sloc (E); | |
fbf5a39b | 1287 | Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ)); |
70482933 | 1288 | Param := Make_Defining_Identifier (Loc, Name_X); |
fbf5a39b AC |
1289 | |
1290 | Discard_Node ( | |
70482933 RK |
1291 | Make_Subprogram_Declaration (Loc, |
1292 | Make_Procedure_Specification (Loc, | |
1293 | Defining_Unit_Name => Init, | |
1294 | Parameter_Specifications => New_List ( | |
1295 | Make_Parameter_Specification (Loc, | |
1296 | Defining_Identifier => Param, | |
fbf5a39b | 1297 | Parameter_Type => New_Reference_To (Typ, Loc)))))); |
70482933 RK |
1298 | |
1299 | Set_Init_Proc (Typ, Init); | |
fbf5a39b | 1300 | Set_Is_Imported (Init); |
70482933 | 1301 | Set_Interface_Name (Init, Interface_Name (E)); |
fbf5a39b AC |
1302 | Set_Convention (Init, Convention_C); |
1303 | Set_Is_Public (Init); | |
70482933 RK |
1304 | Set_Has_Completion (Init); |
1305 | ||
fbf5a39b | 1306 | -- If there are no constructors, mark the type as abstract since we |
70482933 RK |
1307 | -- won't be able to declare objects of that type. |
1308 | ||
1309 | else | |
1310 | Set_Is_Abstract (Typ); | |
1311 | end if; | |
1312 | end Set_Default_Constructor; | |
1313 | ||
1314 | end Exp_Disp; |