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