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