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