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