1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                             E X P _ A T A G                              --
6--                                                                          --
7--                                 S p e c                                  --
8--                                                                          --
9--          Copyright (C) 2006-2013, 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 3,  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 COPYING3.  If not, go to --
19-- http://www.gnu.org/licenses for a complete copy of the license.          --
20--                                                                          --
21-- GNAT was originally developed  by the GNAT team at  New York University. --
22-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23--                                                                          --
24------------------------------------------------------------------------------
25
26with Atree;    use Atree;
27with Einfo;    use Einfo;
28with Elists;   use Elists;
29with Exp_Disp; use Exp_Disp;
30with Exp_Util; use Exp_Util;
31with Namet;    use Namet;
32with Nlists;   use Nlists;
33with Nmake;    use Nmake;
34with Opt;      use Opt;
35with Rtsfind;  use Rtsfind;
36with Sinfo;    use Sinfo;
37with Sem_Aux;  use Sem_Aux;
38with Sem_Disp; use Sem_Disp;
39with Sem_Util; use Sem_Util;
40with Stand;    use Stand;
41with Snames;   use Snames;
42with Tbuild;   use Tbuild;
43
44package body Exp_Atag is
45
46   -----------------------
47   -- Local Subprograms --
48   -----------------------
49
50   function Build_DT
51     (Loc      : Source_Ptr;
52      Tag_Node : Node_Id) return Node_Id;
53   --  Build code that displaces the Tag to reference the base of the wrapper
54   --  record
55   --
56   --  Generates:
57   --    To_Dispatch_Table_Ptr
58   --      (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position);
59
60   function Build_TSD
61     (Loc           : Source_Ptr;
62      Tag_Node_Addr : Node_Id) return Node_Id;
63   --  Build code that retrieves the address of the record containing the Type
64   --  Specific Data generated by GNAT.
65   --
66   --  Generate: To_Type_Specific_Data_Ptr
67   --              (To_Addr_Ptr (Tag_Node_Addr - Typeinfo_Offset).all);
68
69   ------------------------------------------------
70   -- Build_Common_Dispatching_Select_Statements --
71   ------------------------------------------------
72
73   procedure Build_Common_Dispatching_Select_Statements
74     (Typ    : Entity_Id;
75      Stmts  : List_Id)
76   is
77      Loc      : constant Source_Ptr := Sloc (Typ);
78      Tag_Node : Node_Id;
79
80   begin
81      --  Generate:
82      --    C := get_prim_op_kind (tag! (<type>VP), S);
83
84      --  where C is the out parameter capturing the call kind and S is the
85      --  dispatch table slot number.
86
87      if Tagged_Type_Expansion then
88         Tag_Node :=
89           Unchecked_Convert_To (RTE (RE_Tag),
90             New_Occurrence_Of
91              (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
92
93      else
94         Tag_Node :=
95           Make_Attribute_Reference (Loc,
96             Prefix => New_Occurrence_Of (Typ, Loc),
97             Attribute_Name => Name_Tag);
98      end if;
99
100      Append_To (Stmts,
101        Make_Assignment_Statement (Loc,
102          Name => Make_Identifier (Loc, Name_uC),
103          Expression =>
104            Make_Function_Call (Loc,
105              Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),
106              Parameter_Associations => New_List (
107                Tag_Node,
108                Make_Identifier (Loc, Name_uS)))));
109
110      --  Generate:
111
112      --    if C = POK_Procedure
113      --      or else C = POK_Protected_Procedure
114      --      or else C = POK_Task_Procedure;
115      --    then
116      --       F := True;
117      --       return;
118
119      --  where F is the out parameter capturing the status of a potential
120      --  entry call.
121
122      Append_To (Stmts,
123        Make_If_Statement (Loc,
124
125          Condition =>
126            Make_Or_Else (Loc,
127              Left_Opnd =>
128                Make_Op_Eq (Loc,
129                  Left_Opnd  => Make_Identifier (Loc, Name_uC),
130                  Right_Opnd =>
131                    New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)),
132              Right_Opnd =>
133                Make_Or_Else (Loc,
134                  Left_Opnd =>
135                    Make_Op_Eq (Loc,
136                      Left_Opnd => Make_Identifier (Loc, Name_uC),
137                      Right_Opnd =>
138                        New_Occurrence_Of
139                          (RTE (RE_POK_Protected_Procedure), Loc)),
140                  Right_Opnd =>
141                    Make_Op_Eq (Loc,
142                      Left_Opnd  => Make_Identifier (Loc, Name_uC),
143                      Right_Opnd =>
144                        New_Occurrence_Of
145                          (RTE (RE_POK_Task_Procedure), Loc)))),
146
147          Then_Statements =>
148            New_List (
149              Make_Assignment_Statement (Loc,
150                Name       => Make_Identifier (Loc, Name_uF),
151                Expression => New_Occurrence_Of (Standard_True, Loc)),
152              Make_Simple_Return_Statement (Loc))));
153   end Build_Common_Dispatching_Select_Statements;
154
155   -------------------------
156   -- Build_CW_Membership --
157   -------------------------
158
159   procedure Build_CW_Membership
160     (Loc          : Source_Ptr;
161      Obj_Tag_Node : in out Node_Id;
162      Typ_Tag_Node : Node_Id;
163      Related_Nod  : Node_Id;
164      New_Node     : out Node_Id)
165   is
166      Tag_Addr : constant Entity_Id := Make_Temporary (Loc, 'D', Obj_Tag_Node);
167      Obj_TSD  : constant Entity_Id := Make_Temporary (Loc, 'D');
168      Typ_TSD  : constant Entity_Id := Make_Temporary (Loc, 'D');
169      Index    : constant Entity_Id := Make_Temporary (Loc, 'D');
170
171   begin
172      --  Generate:
173
174      --    Tag_Addr : constant Tag := Address!(Obj_Tag);
175      --    Obj_TSD  : constant Type_Specific_Data_Ptr
176      --                          := Build_TSD (Tag_Addr);
177      --    Typ_TSD  : constant Type_Specific_Data_Ptr
178      --                          := Build_TSD (Address!(Typ_Tag));
179      --    Index    : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth
180      --    Index > 0 and then Obj_TSD.Tags_Table (Index) = Typ'Tag
181
182      Insert_Action (Related_Nod,
183        Make_Object_Declaration (Loc,
184          Defining_Identifier => Tag_Addr,
185          Constant_Present    => True,
186          Object_Definition   => New_Occurrence_Of (RTE (RE_Address), Loc),
187          Expression          => Unchecked_Convert_To
188                                   (RTE (RE_Address), Obj_Tag_Node)));
189
190      --  Unchecked_Convert_To relocates Obj_Tag_Node and therefore we must
191      --  update it.
192
193      Obj_Tag_Node := Expression (Expression (Parent (Tag_Addr)));
194
195      Insert_Action (Related_Nod,
196        Make_Object_Declaration (Loc,
197          Defining_Identifier => Obj_TSD,
198          Constant_Present    => True,
199          Object_Definition   => New_Occurrence_Of
200                                   (RTE (RE_Type_Specific_Data_Ptr), Loc),
201          Expression => Build_TSD (Loc, New_Occurrence_Of (Tag_Addr, Loc))));
202
203      Insert_Action (Related_Nod,
204        Make_Object_Declaration (Loc,
205          Defining_Identifier => Typ_TSD,
206          Constant_Present    => True,
207          Object_Definition   => New_Occurrence_Of
208                                   (RTE (RE_Type_Specific_Data_Ptr), Loc),
209          Expression => Build_TSD (Loc,
210                          Unchecked_Convert_To (RTE (RE_Address),
211                            Typ_Tag_Node))));
212
213      Insert_Action (Related_Nod,
214        Make_Object_Declaration (Loc,
215          Defining_Identifier => Index,
216          Constant_Present    => True,
217          Object_Definition   => New_Occurrence_Of (Standard_Integer, Loc),
218          Expression =>
219            Make_Op_Subtract (Loc,
220              Left_Opnd =>
221                Make_Selected_Component (Loc,
222                  Prefix        => New_Occurrence_Of (Obj_TSD, Loc),
223                  Selector_Name =>
224                     New_Occurrence_Of
225                       (RTE_Record_Component (RE_Idepth), Loc)),
226
227               Right_Opnd =>
228                 Make_Selected_Component (Loc,
229                   Prefix        => New_Occurrence_Of (Typ_TSD, Loc),
230                   Selector_Name =>
231                     New_Occurrence_Of
232                       (RTE_Record_Component (RE_Idepth), Loc)))));
233
234      New_Node :=
235        Make_And_Then (Loc,
236          Left_Opnd =>
237            Make_Op_Ge (Loc,
238              Left_Opnd  => New_Occurrence_Of (Index, Loc),
239              Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
240
241          Right_Opnd =>
242            Make_Op_Eq (Loc,
243              Left_Opnd =>
244                Make_Indexed_Component (Loc,
245                  Prefix =>
246                    Make_Selected_Component (Loc,
247                      Prefix        => New_Occurrence_Of (Obj_TSD, Loc),
248                      Selector_Name =>
249                        New_Occurrence_Of
250                          (RTE_Record_Component (RE_Tags_Table), Loc)),
251                  Expressions =>
252                    New_List (New_Occurrence_Of (Index, Loc))),
253
254              Right_Opnd => Typ_Tag_Node));
255   end Build_CW_Membership;
256
257   --------------
258   -- Build_DT --
259   --------------
260
261   function Build_DT
262     (Loc      : Source_Ptr;
263      Tag_Node : Node_Id) return Node_Id
264   is
265   begin
266      return
267        Make_Function_Call (Loc,
268          Name => New_Occurrence_Of (RTE (RE_DT), Loc),
269          Parameter_Associations => New_List (
270            Unchecked_Convert_To (RTE (RE_Tag), Tag_Node)));
271   end Build_DT;
272
273   ----------------------------
274   -- Build_Get_Access_Level --
275   ----------------------------
276
277   function Build_Get_Access_Level
278     (Loc      : Source_Ptr;
279      Tag_Node : Node_Id) return Node_Id
280   is
281   begin
282      return
283        Make_Selected_Component (Loc,
284          Prefix =>
285            Build_TSD (Loc,
286              Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
287          Selector_Name =>
288            New_Occurrence_Of
289              (RTE_Record_Component (RE_Access_Level), Loc));
290   end Build_Get_Access_Level;
291
292   -------------------------
293   -- Build_Get_Alignment --
294   -------------------------
295
296   function Build_Get_Alignment
297     (Loc      : Source_Ptr;
298      Tag_Node : Node_Id) return Node_Id
299   is
300   begin
301      return
302        Make_Selected_Component (Loc,
303          Prefix        =>
304            Build_TSD (Loc, Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
305          Selector_Name =>
306            New_Occurrence_Of (RTE_Record_Component (RE_Alignment), Loc));
307   end Build_Get_Alignment;
308
309   ------------------------------------------
310   -- Build_Get_Predefined_Prim_Op_Address --
311   ------------------------------------------
312
313   procedure Build_Get_Predefined_Prim_Op_Address
314     (Loc      : Source_Ptr;
315      Position : Uint;
316      Tag_Node : in out Node_Id;
317      New_Node : out Node_Id)
318   is
319      Ctrl_Tag : Node_Id;
320
321   begin
322      Ctrl_Tag := Unchecked_Convert_To (RTE (RE_Address), Tag_Node);
323
324      --  Unchecked_Convert_To relocates the controlling tag node and therefore
325      --  we must update it.
326
327      Tag_Node := Expression (Ctrl_Tag);
328
329      --  Build code that retrieves the address of the dispatch table
330      --  containing the predefined Ada primitives:
331      --
332      --  Generate:
333      --    To_Predef_Prims_Table_Ptr
334      --     (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
335
336      New_Node :=
337        Make_Indexed_Component (Loc,
338          Prefix =>
339            Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
340              Make_Explicit_Dereference (Loc,
341                Unchecked_Convert_To (RTE (RE_Addr_Ptr),
342                  Make_Function_Call (Loc,
343                    Name =>
344                      Make_Expanded_Name (Loc,
345                        Chars => Name_Op_Subtract,
346                        Prefix =>
347                          New_Occurrence_Of
348                            (RTU_Entity (System_Storage_Elements), Loc),
349                        Selector_Name =>
350                          Make_Identifier (Loc, Name_Op_Subtract)),
351                    Parameter_Associations => New_List (
352                      Ctrl_Tag,
353                      New_Occurrence_Of
354                        (RTE (RE_DT_Predef_Prims_Offset), Loc)))))),
355          Expressions =>
356            New_List (Make_Integer_Literal (Loc, Position)));
357   end Build_Get_Predefined_Prim_Op_Address;
358
359   -----------------------------
360   -- Build_Inherit_CPP_Prims --
361   -----------------------------
362
363   function Build_Inherit_CPP_Prims (Typ : Entity_Id) return List_Id is
364      Loc          : constant Source_Ptr := Sloc (Typ);
365      CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
366      CPP_Table    : array (1 .. CPP_Nb_Prims) of Boolean := (others => False);
367      CPP_Typ      : constant Entity_Id := Enclosing_CPP_Parent (Typ);
368      Result       : constant List_Id   := New_List;
369      Parent_Typ   : constant Entity_Id := Etype (Typ);
370      E            : Entity_Id;
371      Elmt         : Elmt_Id;
372      Parent_Tag   : Entity_Id;
373      Prim         : Entity_Id;
374      Prim_Pos     : Nat;
375      Typ_Tag      : Entity_Id;
376
377   begin
378      pragma Assert (not Is_CPP_Class (Typ));
379
380      --  No code needed if this type has no primitives inherited from C++
381
382      if CPP_Nb_Prims = 0 then
383         return Result;
384      end if;
385
386      --  Stage 1: Inherit and override C++ slots of the primary dispatch table
387
388      --  Generate:
389      --     Typ'Tag (Prim_Pos) := Prim'Unrestricted_Access;
390
391      Parent_Tag := Node (First_Elmt (Access_Disp_Table (Parent_Typ)));
392      Typ_Tag    := Node (First_Elmt (Access_Disp_Table (Typ)));
393
394      Elmt := First_Elmt (Primitive_Operations (Typ));
395      while Present (Elmt) loop
396         Prim     := Node (Elmt);
397         E        := Ultimate_Alias (Prim);
398         Prim_Pos := UI_To_Int (DT_Position (E));
399
400         --  Skip predefined, abstract, and eliminated primitives. Skip also
401         --  primitives not located in the C++ part of the dispatch table.
402
403         if not Is_Predefined_Dispatching_Operation (Prim)
404           and then not Is_Predefined_Dispatching_Operation (E)
405           and then not Present (Interface_Alias (Prim))
406           and then not Is_Abstract_Subprogram (E)
407           and then not Is_Eliminated (E)
408           and then Prim_Pos <= CPP_Nb_Prims
409           and then Find_Dispatching_Type (E) = Typ
410         then
411            --  Remember that this slot is used
412
413            pragma Assert (CPP_Table (Prim_Pos) = False);
414            CPP_Table (Prim_Pos) := True;
415
416            Append_To (Result,
417              Make_Assignment_Statement (Loc,
418                Name =>
419                  Make_Indexed_Component (Loc,
420                    Prefix =>
421                      Make_Explicit_Dereference (Loc,
422                        Unchecked_Convert_To
423                          (Node (Last_Elmt (Access_Disp_Table (Typ))),
424                           New_Occurrence_Of (Typ_Tag, Loc))),
425                    Expressions =>
426                       New_List (Make_Integer_Literal (Loc, Prim_Pos))),
427
428               Expression =>
429                 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
430                   Make_Attribute_Reference (Loc,
431                     Prefix => New_Occurrence_Of (E, Loc),
432                     Attribute_Name => Name_Unrestricted_Access))));
433         end if;
434
435         Next_Elmt (Elmt);
436      end loop;
437
438      --  If all primitives have been overridden then there is no need to copy
439      --  from Typ's parent its dispatch table. Otherwise, if some primitive is
440      --  inherited from the parent we copy only the C++ part of the dispatch
441      --  table from the parent before the assignments that initialize the
442      --  overridden primitives.
443
444      --  Generate:
445
446      --     type CPP_TypG is array (1 .. CPP_Nb_Prims) ofd Prim_Ptr;
447      --     type CPP_TypH is access CPP_TypG;
448      --     CPP_TypG!(Typ_Tag).all := CPP_TypG!(Parent_Tag).all;
449
450      --   Note: There is no need to duplicate the declarations of CPP_TypG and
451      --         CPP_TypH because, for expansion of dispatching calls, these
452      --         entities are stored in the last elements of Access_Disp_Table.
453
454      for J in CPP_Table'Range loop
455         if not CPP_Table (J) then
456            Prepend_To (Result,
457              Make_Assignment_Statement (Loc,
458                Name =>
459                  Make_Explicit_Dereference (Loc,
460                    Unchecked_Convert_To
461                      (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))),
462                       New_Occurrence_Of (Typ_Tag, Loc))),
463                Expression =>
464                  Make_Explicit_Dereference (Loc,
465                    Unchecked_Convert_To
466                      (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))),
467                       New_Occurrence_Of (Parent_Tag, Loc)))));
468            exit;
469         end if;
470      end loop;
471
472      --  Stage 2: Inherit and override C++ slots of secondary dispatch tables
473
474      declare
475         Iface                   : Entity_Id;
476         Iface_Nb_Prims          : Nat;
477         Parent_Ifaces_List      : Elist_Id;
478         Parent_Ifaces_Comp_List : Elist_Id;
479         Parent_Ifaces_Tag_List  : Elist_Id;
480         Parent_Iface_Tag_Elmt   : Elmt_Id;
481         Typ_Ifaces_List         : Elist_Id;
482         Typ_Ifaces_Comp_List    : Elist_Id;
483         Typ_Ifaces_Tag_List     : Elist_Id;
484         Typ_Iface_Tag_Elmt      : Elmt_Id;
485
486      begin
487         Collect_Interfaces_Info
488           (T               => Parent_Typ,
489            Ifaces_List     => Parent_Ifaces_List,
490            Components_List => Parent_Ifaces_Comp_List,
491            Tags_List       => Parent_Ifaces_Tag_List);
492
493         Collect_Interfaces_Info
494           (T               => Typ,
495            Ifaces_List     => Typ_Ifaces_List,
496            Components_List => Typ_Ifaces_Comp_List,
497            Tags_List       => Typ_Ifaces_Tag_List);
498
499         Parent_Iface_Tag_Elmt := First_Elmt (Parent_Ifaces_Tag_List);
500         Typ_Iface_Tag_Elmt    := First_Elmt (Typ_Ifaces_Tag_List);
501         while Present (Parent_Iface_Tag_Elmt) loop
502            Parent_Tag := Node (Parent_Iface_Tag_Elmt);
503            Typ_Tag    := Node (Typ_Iface_Tag_Elmt);
504
505            pragma Assert
506              (Related_Type (Parent_Tag) = Related_Type (Typ_Tag));
507            Iface := Related_Type (Parent_Tag);
508
509            Iface_Nb_Prims :=
510              UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface)));
511
512            if Iface_Nb_Prims > 0 then
513
514               --  Update slots of overridden primitives
515
516               declare
517                  Last_Nod : constant Node_Id := Last (Result);
518                  Nb_Prims : constant Nat := UI_To_Int
519                                              (DT_Entry_Count
520                                               (First_Tag_Component (Iface)));
521                  Elmt     : Elmt_Id;
522                  Prim     : Entity_Id;
523                  E        : Entity_Id;
524                  Prim_Pos : Nat;
525
526                  Prims_Table : array (1 .. Nb_Prims) of Boolean;
527
528               begin
529                  Prims_Table := (others => False);
530
531                  Elmt := First_Elmt (Primitive_Operations (Typ));
532                  while Present (Elmt) loop
533                     Prim := Node (Elmt);
534                     E    := Ultimate_Alias (Prim);
535
536                     if not Is_Predefined_Dispatching_Operation (Prim)
537                       and then Present (Interface_Alias (Prim))
538                       and then Find_Dispatching_Type (Interface_Alias (Prim))
539                                  = Iface
540                       and then not Is_Abstract_Subprogram (E)
541                       and then not Is_Eliminated (E)
542                       and then Find_Dispatching_Type (E) = Typ
543                     then
544                        Prim_Pos := UI_To_Int (DT_Position (Prim));
545
546                        --  Remember that this slot is already initialized
547
548                        pragma Assert (Prims_Table (Prim_Pos) = False);
549                        Prims_Table (Prim_Pos) := True;
550
551                        Append_To (Result,
552                          Make_Assignment_Statement (Loc,
553                            Name =>
554                              Make_Indexed_Component (Loc,
555                                Prefix =>
556                                  Make_Explicit_Dereference (Loc,
557                                    Unchecked_Convert_To
558                                      (Node
559                                        (Last_Elmt
560                                          (Access_Disp_Table (Iface))),
561                                       New_Occurrence_Of (Typ_Tag, Loc))),
562                                Expressions =>
563                                   New_List
564                                    (Make_Integer_Literal (Loc, Prim_Pos))),
565
566                            Expression =>
567                              Unchecked_Convert_To (RTE (RE_Prim_Ptr),
568                                Make_Attribute_Reference (Loc,
569                                  Prefix => New_Occurrence_Of (E, Loc),
570                                  Attribute_Name =>
571                                    Name_Unrestricted_Access))));
572                     end if;
573
574                     Next_Elmt (Elmt);
575                  end loop;
576
577                  --  Check if all primitives from the parent have been
578                  --  overridden (to avoid copying the whole secondary
579                  --  table from the parent).
580
581                  --   IfaceG!(Typ_Sec_Tag).all := IfaceG!(Parent_Sec_Tag).all;
582
583                  for J in Prims_Table'Range loop
584                     if not Prims_Table (J) then
585                        Insert_After (Last_Nod,
586                          Make_Assignment_Statement (Loc,
587                            Name =>
588                              Make_Explicit_Dereference (Loc,
589                                Unchecked_Convert_To
590                                 (Node (Last_Elmt (Access_Disp_Table (Iface))),
591                                  New_Occurrence_Of (Typ_Tag, Loc))),
592                            Expression =>
593                              Make_Explicit_Dereference (Loc,
594                                Unchecked_Convert_To
595                                 (Node (Last_Elmt (Access_Disp_Table (Iface))),
596                                  New_Occurrence_Of (Parent_Tag, Loc)))));
597                        exit;
598                     end if;
599                  end loop;
600               end;
601            end if;
602
603            Next_Elmt (Typ_Iface_Tag_Elmt);
604            Next_Elmt (Parent_Iface_Tag_Elmt);
605         end loop;
606      end;
607
608      return Result;
609   end Build_Inherit_CPP_Prims;
610
611   -------------------------
612   -- Build_Inherit_Prims --
613   -------------------------
614
615   function Build_Inherit_Prims
616     (Loc          : Source_Ptr;
617      Typ          : Entity_Id;
618      Old_Tag_Node : Node_Id;
619      New_Tag_Node : Node_Id;
620      Num_Prims    : Nat) return Node_Id
621   is
622   begin
623      if RTE_Available (RE_DT) then
624         return
625           Make_Assignment_Statement (Loc,
626             Name =>
627               Make_Slice (Loc,
628                 Prefix =>
629                   Make_Selected_Component (Loc,
630                     Prefix =>
631                       Build_DT (Loc, New_Tag_Node),
632                     Selector_Name =>
633                       New_Occurrence_Of
634                         (RTE_Record_Component (RE_Prims_Ptr), Loc)),
635                 Discrete_Range =>
636                   Make_Range (Loc,
637                   Low_Bound  => Make_Integer_Literal (Loc, 1),
638                   High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
639
640             Expression =>
641               Make_Slice (Loc,
642                 Prefix =>
643                   Make_Selected_Component (Loc,
644                     Prefix =>
645                       Build_DT (Loc, Old_Tag_Node),
646                     Selector_Name =>
647                       New_Occurrence_Of
648                         (RTE_Record_Component (RE_Prims_Ptr), Loc)),
649                 Discrete_Range =>
650                   Make_Range (Loc,
651                     Low_Bound  => Make_Integer_Literal (Loc, 1),
652                     High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
653      else
654         return
655           Make_Assignment_Statement (Loc,
656             Name =>
657               Make_Slice (Loc,
658                 Prefix =>
659                   Unchecked_Convert_To
660                     (Node (Last_Elmt (Access_Disp_Table (Typ))),
661                      New_Tag_Node),
662                 Discrete_Range =>
663                   Make_Range (Loc,
664                   Low_Bound  => Make_Integer_Literal (Loc, 1),
665                   High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
666
667             Expression =>
668               Make_Slice (Loc,
669                 Prefix =>
670                   Unchecked_Convert_To
671                     (Node (Last_Elmt (Access_Disp_Table (Typ))),
672                      Old_Tag_Node),
673                 Discrete_Range =>
674                   Make_Range (Loc,
675                     Low_Bound  => Make_Integer_Literal (Loc, 1),
676                     High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
677      end if;
678   end Build_Inherit_Prims;
679
680   -------------------------------
681   -- Build_Get_Prim_Op_Address --
682   -------------------------------
683
684   procedure Build_Get_Prim_Op_Address
685     (Loc      : Source_Ptr;
686      Typ      : Entity_Id;
687      Position : Uint;
688      Tag_Node : in out Node_Id;
689      New_Node : out Node_Id)
690   is
691      New_Prefix : Node_Id;
692
693   begin
694      pragma Assert
695        (Position <= DT_Entry_Count (First_Tag_Component (Typ)));
696
697      --  At the end of the Access_Disp_Table list we have the type
698      --  declaration required to convert the tag into a pointer to
699      --  the prims_ptr table (see Freeze_Record_Type).
700
701      New_Prefix :=
702        Unchecked_Convert_To
703          (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node);
704
705      --  Unchecked_Convert_To relocates the controlling tag node and therefore
706      --  we must update it.
707
708      Tag_Node := Expression (New_Prefix);
709
710      New_Node :=
711        Make_Indexed_Component (Loc,
712          Prefix      => New_Prefix,
713          Expressions => New_List (Make_Integer_Literal (Loc, Position)));
714   end Build_Get_Prim_Op_Address;
715
716   -----------------------------
717   -- Build_Get_Transportable --
718   -----------------------------
719
720   function Build_Get_Transportable
721     (Loc      : Source_Ptr;
722      Tag_Node : Node_Id) return Node_Id
723   is
724   begin
725      return
726        Make_Selected_Component (Loc,
727          Prefix =>
728            Build_TSD (Loc,
729              Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
730          Selector_Name =>
731            New_Occurrence_Of
732              (RTE_Record_Component (RE_Transportable), Loc));
733   end Build_Get_Transportable;
734
735   ------------------------------------
736   -- Build_Inherit_Predefined_Prims --
737   ------------------------------------
738
739   function Build_Inherit_Predefined_Prims
740     (Loc          : Source_Ptr;
741      Old_Tag_Node : Node_Id;
742      New_Tag_Node : Node_Id) return Node_Id
743   is
744   begin
745      return
746        Make_Assignment_Statement (Loc,
747          Name =>
748            Make_Slice (Loc,
749              Prefix =>
750                Make_Explicit_Dereference (Loc,
751                  Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
752                    Make_Explicit_Dereference (Loc,
753                      Unchecked_Convert_To (RTE (RE_Addr_Ptr),
754                        New_Tag_Node)))),
755              Discrete_Range => Make_Range (Loc,
756                Make_Integer_Literal (Loc, Uint_1),
757                New_Occurrence_Of (RTE (RE_Max_Predef_Prims), Loc))),
758
759          Expression =>
760            Make_Slice (Loc,
761              Prefix =>
762                Make_Explicit_Dereference (Loc,
763                  Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
764                    Make_Explicit_Dereference (Loc,
765                      Unchecked_Convert_To (RTE (RE_Addr_Ptr),
766                        Old_Tag_Node)))),
767              Discrete_Range =>
768                Make_Range (Loc,
769                  Make_Integer_Literal (Loc, 1),
770                  New_Occurrence_Of (RTE (RE_Max_Predef_Prims), Loc))));
771   end Build_Inherit_Predefined_Prims;
772
773   -------------------------
774   -- Build_Offset_To_Top --
775   -------------------------
776
777   function Build_Offset_To_Top
778     (Loc       : Source_Ptr;
779      This_Node : Node_Id) return Node_Id
780   is
781      Tag_Node : Node_Id;
782
783   begin
784      Tag_Node :=
785        Make_Explicit_Dereference (Loc,
786          Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node));
787
788      return
789        Make_Explicit_Dereference (Loc,
790          Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
791            Make_Function_Call (Loc,
792              Name =>
793                Make_Expanded_Name (Loc,
794                  Chars         => Name_Op_Subtract,
795                  Prefix        =>
796                    New_Occurrence_Of
797                      (RTU_Entity (System_Storage_Elements), Loc),
798                  Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)),
799              Parameter_Associations => New_List (
800                Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
801                New_Occurrence_Of
802                  (RTE (RE_DT_Offset_To_Top_Offset), Loc)))));
803   end Build_Offset_To_Top;
804
805   ------------------------------------------
806   -- Build_Set_Predefined_Prim_Op_Address --
807   ------------------------------------------
808
809   function Build_Set_Predefined_Prim_Op_Address
810     (Loc          : Source_Ptr;
811      Tag_Node     : Node_Id;
812      Position     : Uint;
813      Address_Node : Node_Id) return Node_Id
814   is
815   begin
816      return
817         Make_Assignment_Statement (Loc,
818           Name =>
819             Make_Indexed_Component (Loc,
820               Prefix =>
821                 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
822                   Make_Explicit_Dereference (Loc,
823                     Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))),
824               Expressions =>
825                 New_List (Make_Integer_Literal (Loc, Position))),
826
827           Expression => Address_Node);
828   end Build_Set_Predefined_Prim_Op_Address;
829
830   -------------------------------
831   -- Build_Set_Prim_Op_Address --
832   -------------------------------
833
834   function Build_Set_Prim_Op_Address
835     (Loc          : Source_Ptr;
836      Typ          : Entity_Id;
837      Tag_Node     : Node_Id;
838      Position     : Uint;
839      Address_Node : Node_Id) return Node_Id
840   is
841      Ctrl_Tag : Node_Id := Tag_Node;
842      New_Node : Node_Id;
843
844   begin
845      Build_Get_Prim_Op_Address (Loc, Typ, Position, Ctrl_Tag, New_Node);
846
847      return
848        Make_Assignment_Statement (Loc,
849          Name       => New_Node,
850          Expression => Address_Node);
851   end Build_Set_Prim_Op_Address;
852
853   -----------------------------
854   -- Build_Set_Size_Function --
855   -----------------------------
856
857   function Build_Set_Size_Function
858     (Loc       : Source_Ptr;
859      Tag_Node  : Node_Id;
860      Size_Func : Entity_Id) return Node_Id is
861   begin
862      pragma Assert (Chars (Size_Func) = Name_uSize
863        and then RTE_Record_Component_Available (RE_Size_Func));
864      return
865        Make_Assignment_Statement (Loc,
866          Name =>
867            Make_Selected_Component (Loc,
868              Prefix =>
869                Build_TSD (Loc,
870                  Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
871              Selector_Name =>
872                New_Occurrence_Of
873                  (RTE_Record_Component (RE_Size_Func), Loc)),
874          Expression =>
875            Unchecked_Convert_To (RTE (RE_Size_Ptr),
876              Make_Attribute_Reference (Loc,
877                Prefix => New_Occurrence_Of (Size_Func, Loc),
878                Attribute_Name => Name_Unrestricted_Access)));
879   end Build_Set_Size_Function;
880
881   ------------------------------------
882   -- Build_Set_Static_Offset_To_Top --
883   ------------------------------------
884
885   function Build_Set_Static_Offset_To_Top
886     (Loc          : Source_Ptr;
887      Iface_Tag    : Node_Id;
888      Offset_Value : Node_Id) return Node_Id is
889   begin
890      return
891        Make_Assignment_Statement (Loc,
892          Make_Explicit_Dereference (Loc,
893            Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
894              Make_Function_Call (Loc,
895                Name =>
896                  Make_Expanded_Name (Loc,
897                    Chars         => Name_Op_Subtract,
898                    Prefix        =>
899                      New_Occurrence_Of
900                        (RTU_Entity (System_Storage_Elements), Loc),
901                    Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)),
902                Parameter_Associations => New_List (
903                  Unchecked_Convert_To (RTE (RE_Address), Iface_Tag),
904                  New_Occurrence_Of
905                    (RTE (RE_DT_Offset_To_Top_Offset), Loc))))),
906          Offset_Value);
907   end Build_Set_Static_Offset_To_Top;
908
909   ---------------
910   -- Build_TSD --
911   ---------------
912
913   function Build_TSD
914     (Loc           : Source_Ptr;
915      Tag_Node_Addr : Node_Id) return Node_Id is
916   begin
917      return
918        Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
919          Make_Explicit_Dereference (Loc,
920            Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
921              Make_Function_Call (Loc,
922                Name =>
923                  Make_Expanded_Name (Loc,
924                    Chars => Name_Op_Subtract,
925                    Prefix =>
926                      New_Occurrence_Of
927                        (RTU_Entity (System_Storage_Elements), Loc),
928                    Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)),
929
930                Parameter_Associations => New_List (
931                  Tag_Node_Addr,
932                  New_Occurrence_Of
933                    (RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
934   end Build_TSD;
935
936end Exp_Atag;
937