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