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