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