OSDN Git Service

e065538c72b12facded6540464458377e8350d3b
[pf3gnuchains/gcc-fork.git] / gcc / ada / exp_disp.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                         GNAT COMPILER COMPONENTS                         --
4 --                                                                          --
5 --                             E X P _ D I S P                              --
6 --                                                                          --
7 --                                 B o d y                                  --
8 --                                                                          --
9 --          Copyright (C) 1992-2012, 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
26 with Atree;    use Atree;
27 with Checks;   use Checks;
28 with Debug;    use Debug;
29 with Einfo;    use Einfo;
30 with Elists;   use Elists;
31 with Errout;   use Errout;
32 with Exp_Atag; use Exp_Atag;
33 with Exp_Ch6;  use Exp_Ch6;
34 with Exp_CG;   use Exp_CG;
35 with Exp_Dbug; use Exp_Dbug;
36 with Exp_Tss;  use Exp_Tss;
37 with Exp_Util; use Exp_Util;
38 with Freeze;   use Freeze;
39 with Itypes;   use Itypes;
40 with Layout;   use Layout;
41 with Nlists;   use Nlists;
42 with Nmake;    use Nmake;
43 with Namet;    use Namet;
44 with Opt;      use Opt;
45 with Output;   use Output;
46 with Restrict; use Restrict;
47 with Rident;   use Rident;
48 with Rtsfind;  use Rtsfind;
49 with Sem;      use Sem;
50 with Sem_Aux;  use Sem_Aux;
51 with Sem_Ch6;  use Sem_Ch6;
52 with Sem_Ch7;  use Sem_Ch7;
53 with Sem_Ch8;  use Sem_Ch8;
54 with Sem_Disp; use Sem_Disp;
55 with Sem_Eval; use Sem_Eval;
56 with Sem_Res;  use Sem_Res;
57 with Sem_Type; use Sem_Type;
58 with Sem_Util; use Sem_Util;
59 with Sinfo;    use Sinfo;
60 with Snames;   use Snames;
61 with Stand;    use Stand;
62 with Stringt;  use Stringt;
63 with SCIL_LL;  use SCIL_LL;
64 with Targparm; use Targparm;
65 with Tbuild;   use Tbuild;
66 with Uintp;    use Uintp;
67
68 package body Exp_Disp is
69
70    -----------------------
71    -- Local Subprograms --
72    -----------------------
73
74    function Default_Prim_Op_Position (E : Entity_Id) return Uint;
75    --  Ada 2005 (AI-251): Returns the fixed position in the dispatch table
76    --  of the default primitive operations.
77
78    function Find_Specific_Type (CW : Entity_Id) return Entity_Id;
79    --  Find specific type of a class-wide type, and handle the case of an
80    --  incomplete type coming either from a limited_with clause or from an
81    --  incomplete type declaration. Shouldn't this be in Sem_Util? It seems
82    --  like a general purpose semantic routine ???
83
84    function Has_DT (Typ : Entity_Id) return Boolean;
85    pragma Inline (Has_DT);
86    --  Returns true if we generate a dispatch table for tagged type Typ
87
88    function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
89    --  Returns true if Prim is not a predefined dispatching primitive but it is
90    --  an alias of a predefined dispatching primitive (i.e. through a renaming)
91
92    function New_Value (From : Node_Id) return Node_Id;
93    --  From is the original Expression. New_Value is equivalent to a call
94    --  to Duplicate_Subexpr with an explicit dereference when From is an
95    --  access parameter.
96
97    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
98    --  Check if the type has a private view or if the public view appears
99    --  in the visible part of a package spec.
100
101    function Prim_Op_Kind
102      (Prim : Entity_Id;
103       Typ  : Entity_Id) return Node_Id;
104    --  Ada 2005 (AI-345): Determine the primitive operation kind of Prim
105    --  according to its type Typ. Return a reference to an RE_Prim_Op_Kind
106    --  enumeration value.
107
108    function Tagged_Kind (T : Entity_Id) return Node_Id;
109    --  Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
110    --  to an RE_Tagged_Kind enumeration value.
111
112    ----------------------
113    -- Apply_Tag_Checks --
114    ----------------------
115
116    procedure Apply_Tag_Checks (Call_Node : Node_Id) is
117       Loc        : constant Source_Ptr := Sloc (Call_Node);
118       Ctrl_Arg   : constant Node_Id   := Controlling_Argument (Call_Node);
119       Ctrl_Typ   : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
120       Param_List : constant List_Id   := Parameter_Associations (Call_Node);
121
122       Subp            : Entity_Id;
123       CW_Typ          : Entity_Id;
124       Param           : Node_Id;
125       Typ             : Entity_Id;
126       Eq_Prim_Op      : Entity_Id := Empty;
127
128    begin
129       if No_Run_Time_Mode then
130          Error_Msg_CRT ("tagged types", Call_Node);
131          return;
132       end if;
133
134       --  Apply_Tag_Checks is called directly from the semantics, so we need
135       --  a check to see whether expansion is active before proceeding. In
136       --  addition, there is no need to expand the call when compiling under
137       --  restriction No_Dispatching_Calls; the semantic analyzer has
138       --  previously notified the violation of this restriction.
139
140       if not Expander_Active
141         or else Restriction_Active (No_Dispatching_Calls)
142       then
143          return;
144       end if;
145
146       --  Set subprogram. If this is an inherited operation that was
147       --  overridden, the body that is being called is its alias.
148
149       Subp := Entity (Name (Call_Node));
150
151       if Present (Alias (Subp))
152         and then Is_Inherited_Operation (Subp)
153         and then No (DTC_Entity (Subp))
154       then
155          Subp := Alias (Subp);
156       end if;
157
158       --  Definition of the class-wide type and the tagged type
159
160       --  If the controlling argument is itself a tag rather than a tagged
161       --  object, then use the class-wide type associated with the subprogram's
162       --  controlling type. This case can occur when a call to an inherited
163       --  primitive has an actual that originated from a default parameter
164       --  given by a tag-indeterminate call and when there is no other
165       --  controlling argument providing the tag (AI-239 requires dispatching).
166       --  This capability of dispatching directly by tag is also needed by the
167       --  implementation of AI-260 (for the generic dispatching constructors).
168
169       if Ctrl_Typ = RTE (RE_Tag)
170         or else (RTE_Available (RE_Interface_Tag)
171                   and then Ctrl_Typ = RTE (RE_Interface_Tag))
172       then
173          CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
174
175       --  Class_Wide_Type is applied to the expressions used to initialize
176       --  CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
177       --  there are cases where the controlling type is resolved to a specific
178       --  type (such as for designated types of arguments such as CW'Access).
179
180       elsif Is_Access_Type (Ctrl_Typ) then
181          CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
182
183       else
184          CW_Typ := Class_Wide_Type (Ctrl_Typ);
185       end if;
186
187       Typ := Find_Specific_Type (CW_Typ);
188
189       if not Is_Limited_Type (Typ) then
190          Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
191       end if;
192
193       --  Dispatching call to C++ primitive
194
195       if Is_CPP_Class (Typ) then
196          null;
197
198       --  Dispatching call to Ada primitive
199
200       elsif Present (Param_List) then
201
202          --  Generate the Tag checks when appropriate
203
204          Param := First_Actual (Call_Node);
205          while Present (Param) loop
206
207             --  No tag check with itself
208
209             if Param = Ctrl_Arg then
210                null;
211
212             --  No tag check for parameter whose type is neither tagged nor
213             --  access to tagged (for access parameters)
214
215             elsif No (Find_Controlling_Arg (Param)) then
216                null;
217
218             --  No tag check for function dispatching on result if the
219             --  Tag given by the context is this one
220
221             elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
222                null;
223
224             --  "=" is the only dispatching operation allowed to get
225             --  operands with incompatible tags (it just returns false).
226             --  We use Duplicate_Subexpr_Move_Checks instead of calling
227             --  Relocate_Node because the value will be duplicated to
228             --  check the tags.
229
230             elsif Subp = Eq_Prim_Op then
231                null;
232
233             --  No check in presence of suppress flags
234
235             elsif Tag_Checks_Suppressed (Etype (Param))
236               or else (Is_Access_Type (Etype (Param))
237                          and then Tag_Checks_Suppressed
238                                     (Designated_Type (Etype (Param))))
239             then
240                null;
241
242             --  Optimization: no tag checks if the parameters are identical
243
244             elsif Is_Entity_Name (Param)
245               and then Is_Entity_Name (Ctrl_Arg)
246               and then Entity (Param) = Entity (Ctrl_Arg)
247             then
248                null;
249
250             --  Now we need to generate the Tag check
251
252             else
253                --  Generate code for tag equality check
254                --  Perhaps should have Checks.Apply_Tag_Equality_Check???
255
256                Insert_Action (Ctrl_Arg,
257                  Make_Implicit_If_Statement (Call_Node,
258                    Condition =>
259                      Make_Op_Ne (Loc,
260                        Left_Opnd =>
261                          Make_Selected_Component (Loc,
262                            Prefix => New_Value (Ctrl_Arg),
263                            Selector_Name =>
264                              New_Reference_To
265                                (First_Tag_Component (Typ), Loc)),
266
267                        Right_Opnd =>
268                          Make_Selected_Component (Loc,
269                            Prefix =>
270                              Unchecked_Convert_To (Typ, New_Value (Param)),
271                            Selector_Name =>
272                              New_Reference_To
273                                (First_Tag_Component (Typ), Loc))),
274
275                    Then_Statements =>
276                      New_List (New_Constraint_Error (Loc))));
277             end if;
278
279             Next_Actual (Param);
280          end loop;
281       end if;
282    end Apply_Tag_Checks;
283
284    ------------------------
285    -- Building_Static_DT --
286    ------------------------
287
288    function Building_Static_DT (Typ : Entity_Id) return Boolean is
289       Root_Typ : Entity_Id := Root_Type (Typ);
290
291    begin
292       --  Handle private types
293
294       if Present (Full_View (Root_Typ)) then
295          Root_Typ := Full_View (Root_Typ);
296       end if;
297
298       return Static_Dispatch_Tables
299         and then Is_Library_Level_Tagged_Type (Typ)
300         and then VM_Target = No_VM
301
302          --  If the type is derived from a CPP class we cannot statically
303          --  build the dispatch tables because we must inherit primitives
304          --  from the CPP side.
305
306         and then not Is_CPP_Class (Root_Typ);
307    end Building_Static_DT;
308
309    ----------------------------------
310    -- Build_Static_Dispatch_Tables --
311    ----------------------------------
312
313    procedure Build_Static_Dispatch_Tables (N : Entity_Id) is
314       Target_List : List_Id;
315
316       procedure Build_Dispatch_Tables (List : List_Id);
317       --  Build the static dispatch table of tagged types found in the list of
318       --  declarations. The generated nodes are added at the end of Target_List
319
320       procedure Build_Package_Dispatch_Tables (N : Node_Id);
321       --  Build static dispatch tables associated with package declaration N
322
323       ---------------------------
324       -- Build_Dispatch_Tables --
325       ---------------------------
326
327       procedure Build_Dispatch_Tables (List : List_Id) is
328          D : Node_Id;
329
330       begin
331          D := First (List);
332          while Present (D) loop
333
334             --  Handle nested packages and package bodies recursively. The
335             --  generated code is placed on the Target_List established for
336             --  the enclosing compilation unit.
337
338             if Nkind (D) = N_Package_Declaration then
339                Build_Package_Dispatch_Tables (D);
340
341             elsif Nkind (D) = N_Package_Body then
342                Build_Dispatch_Tables (Declarations (D));
343
344             elsif Nkind (D) = N_Package_Body_Stub
345               and then Present (Library_Unit (D))
346             then
347                Build_Dispatch_Tables
348                  (Declarations (Proper_Body (Unit (Library_Unit (D)))));
349
350             --  Handle full type declarations and derivations of library
351             --  level tagged types
352
353             elsif Nkind_In (D, N_Full_Type_Declaration,
354                                N_Derived_Type_Definition)
355               and then Is_Library_Level_Tagged_Type (Defining_Entity (D))
356               and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
357               and then not Is_Private_Type (Defining_Entity (D))
358             then
359                --  We do not generate dispatch tables for the internal types
360                --  created for a type extension with unknown discriminants
361                --  The needed information is shared with the source type,
362                --  See Expand_N_Record_Extension.
363
364                if Is_Underlying_Record_View (Defining_Entity (D))
365                  or else
366                   (not Comes_From_Source (Defining_Entity (D))
367                      and then
368                        Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
369                      and then
370                        not Comes_From_Source
371                              (First_Subtype (Defining_Entity (D))))
372                then
373                   null;
374                else
375                   Insert_List_After_And_Analyze (Last (Target_List),
376                     Make_DT (Defining_Entity (D)));
377                end if;
378
379             --  Handle private types of library level tagged types. We must
380             --  exchange the private and full-view to ensure the correct
381             --  expansion. If the full view is a synchronized type ignore
382             --  the type because the table will be built for the corresponding
383             --  record type, that has its own declaration.
384
385             elsif (Nkind (D) = N_Private_Type_Declaration
386                      or else Nkind (D) = N_Private_Extension_Declaration)
387                and then Present (Full_View (Defining_Entity (D)))
388             then
389                declare
390                   E1 : constant Entity_Id := Defining_Entity (D);
391                   E2 : constant Entity_Id := Full_View (E1);
392
393                begin
394                   if Is_Library_Level_Tagged_Type (E2)
395                     and then Ekind (E2) /= E_Record_Subtype
396                     and then not Is_Concurrent_Type (E2)
397                   then
398                      Exchange_Declarations (E1);
399                      Insert_List_After_And_Analyze (Last (Target_List),
400                        Make_DT (E1));
401                      Exchange_Declarations (E2);
402                   end if;
403                end;
404             end if;
405
406             Next (D);
407          end loop;
408       end Build_Dispatch_Tables;
409
410       -----------------------------------
411       -- Build_Package_Dispatch_Tables --
412       -----------------------------------
413
414       procedure Build_Package_Dispatch_Tables (N : Node_Id) is
415          Spec       : constant Node_Id   := Specification (N);
416          Id         : constant Entity_Id := Defining_Entity (N);
417          Vis_Decls  : constant List_Id   := Visible_Declarations (Spec);
418          Priv_Decls : constant List_Id   := Private_Declarations (Spec);
419
420       begin
421          Push_Scope (Id);
422
423          if Present (Priv_Decls) then
424             Build_Dispatch_Tables (Vis_Decls);
425             Build_Dispatch_Tables (Priv_Decls);
426
427          elsif Present (Vis_Decls) then
428             Build_Dispatch_Tables (Vis_Decls);
429          end if;
430
431          Pop_Scope;
432       end Build_Package_Dispatch_Tables;
433
434    --  Start of processing for Build_Static_Dispatch_Tables
435
436    begin
437       if not Expander_Active
438         or else not Tagged_Type_Expansion
439       then
440          return;
441       end if;
442
443       if Nkind (N) = N_Package_Declaration then
444          declare
445             Spec       : constant Node_Id := Specification (N);
446             Vis_Decls  : constant List_Id := Visible_Declarations (Spec);
447             Priv_Decls : constant List_Id := Private_Declarations (Spec);
448
449          begin
450             if Present (Priv_Decls)
451               and then Is_Non_Empty_List (Priv_Decls)
452             then
453                Target_List := Priv_Decls;
454
455             elsif not Present (Vis_Decls) then
456                Target_List := New_List;
457                Set_Private_Declarations (Spec, Target_List);
458             else
459                Target_List := Vis_Decls;
460             end if;
461
462             Build_Package_Dispatch_Tables (N);
463          end;
464
465       else pragma Assert (Nkind (N) = N_Package_Body);
466          Target_List := Declarations (N);
467          Build_Dispatch_Tables (Target_List);
468       end if;
469    end Build_Static_Dispatch_Tables;
470
471    ------------------------------
472    -- Convert_Tag_To_Interface --
473    ------------------------------
474
475    function Convert_Tag_To_Interface
476      (Typ  : Entity_Id;
477       Expr : Node_Id) return Node_Id
478    is
479       Loc       : constant Source_Ptr := Sloc (Expr);
480       Anon_Type : Entity_Id;
481       Result    : Node_Id;
482
483    begin
484       pragma Assert (Is_Class_Wide_Type (Typ)
485         and then Is_Interface (Typ)
486         and then
487           ((Nkind (Expr) = N_Selected_Component
488              and then Is_Tag (Entity (Selector_Name (Expr))))
489            or else
490            (Nkind (Expr) = N_Function_Call
491              and then RTE_Available (RE_Displace)
492              and then Entity (Name (Expr)) = RTE (RE_Displace))));
493
494       Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr);
495       Set_Directly_Designated_Type (Anon_Type, Typ);
496       Set_Etype (Anon_Type, Anon_Type);
497       Set_Can_Never_Be_Null (Anon_Type);
498
499       --  Decorate the size and alignment attributes of the anonymous access
500       --  type, as required by gigi.
501
502       Layout_Type (Anon_Type);
503
504       if Nkind (Expr) = N_Selected_Component
505         and then Is_Tag (Entity (Selector_Name (Expr)))
506       then
507          Result :=
508            Make_Explicit_Dereference (Loc,
509              Unchecked_Convert_To (Anon_Type,
510                Make_Attribute_Reference (Loc,
511                  Prefix         => Expr,
512                  Attribute_Name => Name_Address)));
513       else
514          Result :=
515            Make_Explicit_Dereference (Loc,
516              Unchecked_Convert_To (Anon_Type, Expr));
517       end if;
518
519       return Result;
520    end Convert_Tag_To_Interface;
521
522    -------------------
523    -- CPP_Num_Prims --
524    -------------------
525
526    function CPP_Num_Prims (Typ : Entity_Id) return Nat is
527       CPP_Typ  : Entity_Id;
528       Tag_Comp : Entity_Id;
529
530    begin
531       if not Is_Tagged_Type (Typ)
532         or else not Is_CPP_Class (Root_Type (Typ))
533       then
534          return 0;
535
536       else
537          CPP_Typ  := Enclosing_CPP_Parent (Typ);
538          Tag_Comp := First_Tag_Component (CPP_Typ);
539
540          --  If the number of primitives is already set in the tag component
541          --  then use it
542
543          if Present (Tag_Comp)
544            and then DT_Entry_Count (Tag_Comp) /= No_Uint
545          then
546             return UI_To_Int (DT_Entry_Count (Tag_Comp));
547
548          --  Otherwise, count the primitives of the enclosing CPP type
549
550          else
551             declare
552                Count : Nat := 0;
553                Elmt  : Elmt_Id;
554
555             begin
556                Elmt := First_Elmt (Primitive_Operations (CPP_Typ));
557                while Present (Elmt) loop
558                   Count := Count + 1;
559                   Next_Elmt (Elmt);
560                end loop;
561
562                return Count;
563             end;
564          end if;
565       end if;
566    end CPP_Num_Prims;
567
568    ------------------------------
569    -- Default_Prim_Op_Position --
570    ------------------------------
571
572    function Default_Prim_Op_Position (E : Entity_Id) return Uint is
573       TSS_Name : TSS_Name_Type;
574
575    begin
576       Get_Name_String (Chars (E));
577       TSS_Name :=
578         TSS_Name_Type
579           (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
580
581       if Chars (E) = Name_uSize then
582          return Uint_1;
583
584       elsif TSS_Name = TSS_Stream_Read then
585          return Uint_2;
586
587       elsif TSS_Name = TSS_Stream_Write then
588          return Uint_3;
589
590       elsif TSS_Name = TSS_Stream_Input then
591          return Uint_4;
592
593       elsif TSS_Name = TSS_Stream_Output then
594          return Uint_5;
595
596       elsif Chars (E) = Name_Op_Eq then
597          return Uint_6;
598
599       elsif Chars (E) = Name_uAssign then
600          return Uint_7;
601
602       elsif TSS_Name = TSS_Deep_Adjust then
603          return Uint_8;
604
605       elsif TSS_Name = TSS_Deep_Finalize then
606          return Uint_9;
607
608       --  In VM targets unconditionally allow obtaining the position associated
609       --  with predefined interface primitives since in these platforms any
610       --  tagged type has these primitives.
611
612       elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then
613          if Chars (E) = Name_uDisp_Asynchronous_Select then
614             return Uint_10;
615
616          elsif Chars (E) = Name_uDisp_Conditional_Select then
617             return Uint_11;
618
619          elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
620             return Uint_12;
621
622          elsif Chars (E) = Name_uDisp_Get_Task_Id then
623             return Uint_13;
624
625          elsif Chars (E) = Name_uDisp_Requeue then
626             return Uint_14;
627
628          elsif Chars (E) = Name_uDisp_Timed_Select then
629             return Uint_15;
630          end if;
631       end if;
632
633       raise Program_Error;
634    end Default_Prim_Op_Position;
635
636    -----------------------------
637    -- Expand_Dispatching_Call --
638    -----------------------------
639
640    procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
641       Loc      : constant Source_Ptr := Sloc (Call_Node);
642       Call_Typ : constant Entity_Id  := Etype (Call_Node);
643
644       Ctrl_Arg   : constant Node_Id   := Controlling_Argument (Call_Node);
645       Ctrl_Typ   : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
646       Param_List : constant List_Id   := Parameter_Associations (Call_Node);
647
648       Subp            : Entity_Id;
649       CW_Typ          : Entity_Id;
650       New_Call        : Node_Id;
651       New_Call_Name   : Node_Id;
652       New_Params      : List_Id := No_List;
653       Param           : Node_Id;
654       Res_Typ         : Entity_Id;
655       Subp_Ptr_Typ    : Entity_Id;
656       Subp_Typ        : Entity_Id;
657       Typ             : Entity_Id;
658       Eq_Prim_Op      : Entity_Id := Empty;
659       Controlling_Tag : Node_Id;
660
661       function New_Value (From : Node_Id) return Node_Id;
662       --  From is the original Expression. New_Value is equivalent to a call
663       --  to Duplicate_Subexpr with an explicit dereference when From is an
664       --  access parameter.
665
666       ---------------
667       -- New_Value --
668       ---------------
669
670       function New_Value (From : Node_Id) return Node_Id is
671          Res : constant Node_Id := Duplicate_Subexpr (From);
672       begin
673          if Is_Access_Type (Etype (From)) then
674             return
675               Make_Explicit_Dereference (Sloc (From),
676                 Prefix => Res);
677          else
678             return Res;
679          end if;
680       end New_Value;
681
682       --  Local variables
683
684       New_Node          : Node_Id;
685       SCIL_Node         : Node_Id;
686       SCIL_Related_Node : Node_Id := Call_Node;
687
688    --  Start of processing for Expand_Dispatching_Call
689
690    begin
691       if No_Run_Time_Mode then
692          Error_Msg_CRT ("tagged types", Call_Node);
693          return;
694       end if;
695
696       --  Expand_Dispatching_Call is called directly from the semantics,
697       --  so we only proceed if the expander is active.
698
699       if not Full_Expander_Active
700
701         --  And there is no need to expand the call if we are compiling under
702         --  restriction No_Dispatching_Calls; the semantic analyzer has
703         --  previously notified the violation of this restriction.
704
705         or else Restriction_Active (No_Dispatching_Calls)
706       then
707          return;
708       end if;
709
710       --  Set subprogram. If this is an inherited operation that was
711       --  overridden, the body that is being called is its alias.
712
713       Subp := Entity (Name (Call_Node));
714
715       if Present (Alias (Subp))
716         and then Is_Inherited_Operation (Subp)
717         and then No (DTC_Entity (Subp))
718       then
719          Subp := Alias (Subp);
720       end if;
721
722       --  Definition of the class-wide type and the tagged type
723
724       --  If the controlling argument is itself a tag rather than a tagged
725       --  object, then use the class-wide type associated with the subprogram's
726       --  controlling type. This case can occur when a call to an inherited
727       --  primitive has an actual that originated from a default parameter
728       --  given by a tag-indeterminate call and when there is no other
729       --  controlling argument providing the tag (AI-239 requires dispatching).
730       --  This capability of dispatching directly by tag is also needed by the
731       --  implementation of AI-260 (for the generic dispatching constructors).
732
733       if Ctrl_Typ = RTE (RE_Tag)
734         or else (RTE_Available (RE_Interface_Tag)
735                   and then Ctrl_Typ = RTE (RE_Interface_Tag))
736       then
737          CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
738
739       --  Class_Wide_Type is applied to the expressions used to initialize
740       --  CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
741       --  there are cases where the controlling type is resolved to a specific
742       --  type (such as for designated types of arguments such as CW'Access).
743
744       elsif Is_Access_Type (Ctrl_Typ) then
745          CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
746
747       else
748          CW_Typ := Class_Wide_Type (Ctrl_Typ);
749       end if;
750
751       Typ := Find_Specific_Type (CW_Typ);
752
753       if not Is_Limited_Type (Typ) then
754          Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
755       end if;
756
757       --  Dispatching call to C++ primitive. Create a new parameter list
758       --  with no tag checks.
759
760       New_Params := New_List;
761
762       if Is_CPP_Class (Typ) then
763          Param := First_Actual (Call_Node);
764          while Present (Param) loop
765             Append_To (New_Params, Relocate_Node (Param));
766             Next_Actual (Param);
767          end loop;
768
769       --  Dispatching call to Ada primitive
770
771       elsif Present (Param_List) then
772          Apply_Tag_Checks (Call_Node);
773
774          Param := First_Actual (Call_Node);
775          while Present (Param) loop
776             --  Cases in which we may have generated runtime checks
777
778             if Param = Ctrl_Arg
779               or else Subp = Eq_Prim_Op
780             then
781                Append_To (New_Params,
782                  Duplicate_Subexpr_Move_Checks (Param));
783
784             elsif Nkind (Parent (Param)) /= N_Parameter_Association
785               or else not Is_Accessibility_Actual (Parent (Param))
786             then
787                Append_To (New_Params, Relocate_Node (Param));
788             end if;
789
790             Next_Actual (Param);
791          end loop;
792       end if;
793
794       --  Generate the appropriate subprogram pointer type
795
796       if Etype (Subp) = Typ then
797          Res_Typ := CW_Typ;
798       else
799          Res_Typ := Etype (Subp);
800       end if;
801
802       Subp_Typ     := Create_Itype (E_Subprogram_Type, Call_Node);
803       Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
804       Set_Etype          (Subp_Typ, Res_Typ);
805       Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
806
807       --  Create a new list of parameters which is a copy of the old formal
808       --  list including the creation of a new set of matching entities.
809
810       declare
811          Old_Formal : Entity_Id := First_Formal (Subp);
812          New_Formal : Entity_Id;
813          Extra      : Entity_Id := Empty;
814
815       begin
816          if Present (Old_Formal) then
817             New_Formal := New_Copy (Old_Formal);
818             Set_First_Entity (Subp_Typ, New_Formal);
819             Param := First_Actual (Call_Node);
820
821             loop
822                Set_Scope (New_Formal, Subp_Typ);
823
824                --  Change all the controlling argument types to be class-wide
825                --  to avoid a recursion in dispatching.
826
827                if Is_Controlling_Formal (New_Formal) then
828                   Set_Etype (New_Formal, Etype (Param));
829                end if;
830
831                --  If the type of the formal is an itype, there was code here
832                --  introduced in 1998 in revision 1.46, to create a new itype
833                --  by copy. This seems useless, and in fact leads to semantic
834                --  errors when the itype is the completion of a type derived
835                --  from a private type.
836
837                Extra := New_Formal;
838                Next_Formal (Old_Formal);
839                exit when No (Old_Formal);
840
841                Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
842                Next_Entity (New_Formal);
843                Next_Actual (Param);
844             end loop;
845
846             Set_Next_Entity (New_Formal, Empty);
847             Set_Last_Entity (Subp_Typ, Extra);
848          end if;
849
850          --  Now that the explicit formals have been duplicated, any extra
851          --  formals needed by the subprogram must be created.
852
853          if Present (Extra) then
854             Set_Extra_Formal (Extra, Empty);
855          end if;
856
857          Create_Extra_Formals (Subp_Typ);
858       end;
859
860       --  Complete description of pointer type, including size information, as
861       --  must be done with itypes to prevent order-of-elaboration anomalies
862       --  in gigi.
863
864       Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
865       Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
866       Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ));
867       Layout_Type    (Subp_Ptr_Typ);
868
869       --  If the controlling argument is a value of type Ada.Tag or an abstract
870       --  interface class-wide type then use it directly. Otherwise, the tag
871       --  must be extracted from the controlling object.
872
873       if Ctrl_Typ = RTE (RE_Tag)
874         or else (RTE_Available (RE_Interface_Tag)
875                   and then Ctrl_Typ = RTE (RE_Interface_Tag))
876       then
877          Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
878
879       --  Extract the tag from an unchecked type conversion. Done to avoid
880       --  the expansion of additional code just to obtain the value of such
881       --  tag because the current management of interface type conversions
882       --  generates in some cases this unchecked type conversion with the
883       --  tag of the object (see Expand_Interface_Conversion).
884
885       elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
886         and then
887           (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
888             or else
889               (RTE_Available (RE_Interface_Tag)
890                 and then
891                   Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
892       then
893          Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
894
895       --  Ada 2005 (AI-251): Abstract interface class-wide type
896
897       elsif Is_Interface (Ctrl_Typ)
898         and then Is_Class_Wide_Type (Ctrl_Typ)
899       then
900          Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
901
902       else
903          Controlling_Tag :=
904            Make_Selected_Component (Loc,
905              Prefix        => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
906              Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
907       end if;
908
909       --  Handle dispatching calls to predefined primitives
910
911       if Is_Predefined_Dispatching_Operation (Subp)
912         or else Is_Predefined_Dispatching_Alias (Subp)
913       then
914          Build_Get_Predefined_Prim_Op_Address (Loc,
915            Tag_Node => Controlling_Tag,
916            Position => DT_Position (Subp),
917            New_Node => New_Node);
918
919       --  Handle dispatching calls to user-defined primitives
920
921       else
922          Build_Get_Prim_Op_Address (Loc,
923            Typ      => Underlying_Type (Find_Dispatching_Type (Subp)),
924            Tag_Node => Controlling_Tag,
925            Position => DT_Position (Subp),
926            New_Node => New_Node);
927       end if;
928
929       New_Call_Name :=
930         Unchecked_Convert_To (Subp_Ptr_Typ, New_Node);
931
932       --  Generate the SCIL node for this dispatching call. Done now because
933       --  attribute SCIL_Controlling_Tag must be set after the new call name
934       --  is built to reference the nodes that will see the SCIL backend
935       --  (because Build_Get_Prim_Op_Address generates an unchecked type
936       --  conversion which relocates the controlling tag node).
937
938       if Generate_SCIL then
939          SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node));
940          Set_SCIL_Entity      (SCIL_Node, Typ);
941          Set_SCIL_Target_Prim (SCIL_Node, Subp);
942
943          --  Common case: the controlling tag is the tag of an object
944          --  (for example, obj.tag)
945
946          if Nkind (Controlling_Tag) = N_Selected_Component then
947             Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
948
949          --  Handle renaming of selected component
950
951          elsif Nkind (Controlling_Tag) = N_Identifier
952            and then Nkind (Parent (Entity (Controlling_Tag))) =
953                                              N_Object_Renaming_Declaration
954            and then Nkind (Name (Parent (Entity (Controlling_Tag)))) =
955                                              N_Selected_Component
956          then
957             Set_SCIL_Controlling_Tag (SCIL_Node,
958               Name (Parent (Entity (Controlling_Tag))));
959
960          --  If the controlling tag is an identifier, the SCIL node references
961          --  the corresponding object or parameter declaration
962
963          elsif Nkind (Controlling_Tag) = N_Identifier
964            and then Nkind_In (Parent (Entity (Controlling_Tag)),
965                               N_Object_Declaration,
966                               N_Parameter_Specification)
967          then
968             Set_SCIL_Controlling_Tag (SCIL_Node,
969               Parent (Entity (Controlling_Tag)));
970
971          --  If the controlling tag is a dereference, the SCIL node references
972          --  the corresponding object or parameter declaration
973
974          elsif Nkind (Controlling_Tag) = N_Explicit_Dereference
975             and then Nkind (Prefix (Controlling_Tag)) = N_Identifier
976             and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))),
977                                N_Object_Declaration,
978                                N_Parameter_Specification)
979          then
980             Set_SCIL_Controlling_Tag (SCIL_Node,
981               Parent (Entity (Prefix (Controlling_Tag))));
982
983          --  For a direct reference of the tag of the type the SCIL node
984          --  references the internal object declaration containing the tag
985          --  of the type.
986
987          elsif Nkind (Controlling_Tag) = N_Attribute_Reference
988             and then Attribute_Name (Controlling_Tag) = Name_Tag
989          then
990             Set_SCIL_Controlling_Tag (SCIL_Node,
991               Parent
992                 (Node
993                   (First_Elmt
994                     (Access_Disp_Table (Entity (Prefix (Controlling_Tag)))))));
995
996          --  Interfaces are not supported. For now we leave the SCIL node
997          --  decorated with the Controlling_Tag. More work needed here???
998
999          elsif Is_Interface (Etype (Controlling_Tag)) then
1000             Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
1001
1002          else
1003             pragma Assert (False);
1004             null;
1005          end if;
1006       end if;
1007
1008       if Nkind (Call_Node) = N_Function_Call then
1009          New_Call :=
1010            Make_Function_Call (Loc,
1011              Name                   => New_Call_Name,
1012              Parameter_Associations => New_Params);
1013
1014          --  If this is a dispatching "=", we must first compare the tags so
1015          --  we generate: x.tag = y.tag and then x = y
1016
1017          if Subp = Eq_Prim_Op then
1018             Param := First_Actual (Call_Node);
1019             New_Call :=
1020               Make_And_Then (Loc,
1021                 Left_Opnd =>
1022                      Make_Op_Eq (Loc,
1023                        Left_Opnd =>
1024                          Make_Selected_Component (Loc,
1025                            Prefix        => New_Value (Param),
1026                            Selector_Name =>
1027                              New_Reference_To (First_Tag_Component (Typ),
1028                                                Loc)),
1029
1030                        Right_Opnd =>
1031                          Make_Selected_Component (Loc,
1032                            Prefix        =>
1033                              Unchecked_Convert_To (Typ,
1034                                New_Value (Next_Actual (Param))),
1035                            Selector_Name =>
1036                              New_Reference_To
1037                                (First_Tag_Component (Typ), Loc))),
1038                 Right_Opnd => New_Call);
1039
1040             SCIL_Related_Node := Right_Opnd (New_Call);
1041          end if;
1042
1043       else
1044          New_Call :=
1045            Make_Procedure_Call_Statement (Loc,
1046              Name                   => New_Call_Name,
1047              Parameter_Associations => New_Params);
1048       end if;
1049
1050       --  Register the dispatching call in the call graph nodes table
1051
1052       Register_CG_Node (Call_Node);
1053
1054       Rewrite (Call_Node, New_Call);
1055
1056       --  Associate the SCIL node of this dispatching call
1057
1058       if Generate_SCIL then
1059          Set_SCIL_Node (SCIL_Related_Node, SCIL_Node);
1060       end if;
1061
1062       --  Suppress all checks during the analysis of the expanded code
1063       --  to avoid the generation of spurious warnings under ZFP run-time.
1064
1065       Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
1066    end Expand_Dispatching_Call;
1067
1068    ---------------------------------
1069    -- Expand_Interface_Conversion --
1070    ---------------------------------
1071
1072    procedure Expand_Interface_Conversion
1073      (N         : Node_Id;
1074       Is_Static : Boolean := True)
1075    is
1076       Loc         : constant Source_Ptr := Sloc (N);
1077       Etyp        : constant Entity_Id  := Etype (N);
1078       Operand     : constant Node_Id    := Expression (N);
1079       Operand_Typ : Entity_Id           := Etype (Operand);
1080       Func        : Node_Id;
1081       Iface_Typ   : Entity_Id           := Etype (N);
1082       Iface_Tag   : Entity_Id;
1083
1084    begin
1085       --  Ada 2005 (AI-345): Handle synchronized interface type derivations
1086
1087       if Is_Concurrent_Type (Operand_Typ) then
1088          Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
1089       end if;
1090
1091       --  Handle access to class-wide interface types
1092
1093       if Is_Access_Type (Iface_Typ) then
1094          Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
1095       end if;
1096
1097       --  Handle class-wide interface types. This conversion can appear
1098       --  explicitly in the source code. Example: I'Class (Obj)
1099
1100       if Is_Class_Wide_Type (Iface_Typ) then
1101          Iface_Typ := Root_Type (Iface_Typ);
1102       end if;
1103
1104       --  If the target type is a tagged synchronized type, the dispatch table
1105       --  info is in the corresponding record type.
1106
1107       if Is_Concurrent_Type (Iface_Typ) then
1108          Iface_Typ := Corresponding_Record_Type (Iface_Typ);
1109       end if;
1110
1111       --  Handle private types
1112
1113       Iface_Typ := Underlying_Type (Iface_Typ);
1114
1115       --  Freeze the entity associated with the target interface to have
1116       --  available the attribute Access_Disp_Table.
1117
1118       Freeze_Before (N, Iface_Typ);
1119
1120       pragma Assert (not Is_Static
1121         or else (not Is_Class_Wide_Type (Iface_Typ)
1122                   and then Is_Interface (Iface_Typ)));
1123
1124       if not Tagged_Type_Expansion then
1125          if VM_Target /= No_VM then
1126             if Is_Access_Type (Operand_Typ) then
1127                Operand_Typ := Designated_Type (Operand_Typ);
1128             end if;
1129
1130             if Is_Class_Wide_Type (Operand_Typ) then
1131                Operand_Typ := Root_Type (Operand_Typ);
1132             end if;
1133
1134             if not Is_Static
1135               and then Operand_Typ /= Iface_Typ
1136             then
1137                Insert_Action (N,
1138                  Make_Procedure_Call_Statement (Loc,
1139                    Name => New_Occurrence_Of
1140                             (RTE (RE_Check_Interface_Conversion), Loc),
1141                    Parameter_Associations => New_List (
1142                      Make_Attribute_Reference (Loc,
1143                        Prefix => Duplicate_Subexpr (Expression (N)),
1144                        Attribute_Name => Name_Tag),
1145                      Make_Attribute_Reference (Loc,
1146                        Prefix         => New_Reference_To (Iface_Typ, Loc),
1147                        Attribute_Name => Name_Tag))));
1148             end if;
1149
1150             --  Just do a conversion ???
1151
1152             Rewrite (N, Unchecked_Convert_To (Etype (N), N));
1153             Analyze (N);
1154          end if;
1155
1156          return;
1157       end if;
1158
1159       if not Is_Static then
1160
1161          --  Give error if configurable run time and Displace not available
1162
1163          if not RTE_Available (RE_Displace) then
1164             Error_Msg_CRT ("dynamic interface conversion", N);
1165             return;
1166          end if;
1167
1168          --  Handle conversion of access-to-class-wide interface types. Target
1169          --  can be an access to an object or an access to another class-wide
1170          --  interface (see -1- and -2- in the following example):
1171
1172          --     type Iface1_Ref is access all Iface1'Class;
1173          --     type Iface2_Ref is access all Iface1'Class;
1174
1175          --     Acc1 : Iface1_Ref := new ...
1176          --     Obj  : Obj_Ref    := Obj_Ref (Acc);    -- 1
1177          --     Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
1178
1179          if Is_Access_Type (Operand_Typ) then
1180             Rewrite (N,
1181               Unchecked_Convert_To (Etype (N),
1182                 Make_Function_Call (Loc,
1183                   Name => New_Reference_To (RTE (RE_Displace), Loc),
1184                   Parameter_Associations => New_List (
1185
1186                     Unchecked_Convert_To (RTE (RE_Address),
1187                       Relocate_Node (Expression (N))),
1188
1189                     New_Occurrence_Of
1190                       (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1191                        Loc)))));
1192
1193             Analyze (N);
1194             return;
1195          end if;
1196
1197          Rewrite (N,
1198            Make_Function_Call (Loc,
1199              Name => New_Reference_To (RTE (RE_Displace), Loc),
1200              Parameter_Associations => New_List (
1201                Make_Attribute_Reference (Loc,
1202                  Prefix => Relocate_Node (Expression (N)),
1203                  Attribute_Name => Name_Address),
1204
1205                New_Occurrence_Of
1206                  (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1207                   Loc))));
1208
1209          Analyze (N);
1210
1211          --  If the target is a class-wide interface we change the type of the
1212          --  data returned by IW_Convert to indicate that this is a dispatching
1213          --  call.
1214
1215          declare
1216             New_Itype : Entity_Id;
1217
1218          begin
1219             New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
1220             Set_Etype (New_Itype, New_Itype);
1221             Set_Directly_Designated_Type (New_Itype, Etyp);
1222
1223             Rewrite (N,
1224               Make_Explicit_Dereference (Loc,
1225                 Prefix =>
1226                   Unchecked_Convert_To (New_Itype, Relocate_Node (N))));
1227             Analyze (N);
1228             Freeze_Itype (New_Itype, N);
1229
1230             return;
1231          end;
1232       end if;
1233
1234       Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
1235       pragma Assert (Iface_Tag /= Empty);
1236
1237       --  Keep separate access types to interfaces because one internal
1238       --  function is used to handle the null value (see following comments)
1239
1240       if not Is_Access_Type (Etype (N)) then
1241
1242          --  Statically displace the pointer to the object to reference
1243          --  the component containing the secondary dispatch table.
1244
1245          Rewrite (N,
1246            Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ),
1247              Make_Selected_Component (Loc,
1248                Prefix => Relocate_Node (Expression (N)),
1249                Selector_Name => New_Occurrence_Of (Iface_Tag, Loc))));
1250
1251       else
1252          --  Build internal function to handle the case in which the
1253          --  actual is null. If the actual is null returns null because
1254          --  no displacement is required; otherwise performs a type
1255          --  conversion that will be expanded in the code that returns
1256          --  the value of the displaced actual. That is:
1257
1258          --     function Func (O : Address) return Iface_Typ is
1259          --        type Op_Typ is access all Operand_Typ;
1260          --        Aux : Op_Typ := To_Op_Typ (O);
1261          --     begin
1262          --        if O = Null_Address then
1263          --           return null;
1264          --        else
1265          --           return Iface_Typ!(Aux.Iface_Tag'Address);
1266          --        end if;
1267          --     end Func;
1268
1269          declare
1270             Desig_Typ    : Entity_Id;
1271             Fent         : Entity_Id;
1272             New_Typ_Decl : Node_Id;
1273             Stats        : List_Id;
1274
1275          begin
1276             Desig_Typ := Etype (Expression (N));
1277
1278             if Is_Access_Type (Desig_Typ) then
1279                Desig_Typ :=
1280                  Available_View (Directly_Designated_Type (Desig_Typ));
1281             end if;
1282
1283             if Is_Concurrent_Type (Desig_Typ) then
1284                Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ));
1285             end if;
1286
1287             New_Typ_Decl :=
1288               Make_Full_Type_Declaration (Loc,
1289                 Defining_Identifier => Make_Temporary (Loc, 'T'),
1290                 Type_Definition =>
1291                   Make_Access_To_Object_Definition (Loc,
1292                     All_Present            => True,
1293                     Null_Exclusion_Present => False,
1294                     Constant_Present       => False,
1295                     Subtype_Indication     =>
1296                       New_Reference_To (Desig_Typ, Loc)));
1297
1298             Stats := New_List (
1299               Make_Simple_Return_Statement (Loc,
1300                 Unchecked_Convert_To (Etype (N),
1301                   Make_Attribute_Reference (Loc,
1302                     Prefix =>
1303                       Make_Selected_Component (Loc,
1304                         Prefix =>
1305                           Unchecked_Convert_To
1306                             (Defining_Identifier (New_Typ_Decl),
1307                              Make_Identifier (Loc, Name_uO)),
1308                         Selector_Name =>
1309                           New_Occurrence_Of (Iface_Tag, Loc)),
1310                     Attribute_Name => Name_Address))));
1311
1312             --  If the type is null-excluding, no need for the null branch.
1313             --  Otherwise we need to check for it and return null.
1314
1315             if not Can_Never_Be_Null (Etype (N)) then
1316                Stats := New_List (
1317                  Make_If_Statement (Loc,
1318                   Condition       =>
1319                     Make_Op_Eq (Loc,
1320                        Left_Opnd  => Make_Identifier (Loc, Name_uO),
1321                        Right_Opnd => New_Reference_To
1322                                        (RTE (RE_Null_Address), Loc)),
1323
1324                  Then_Statements => New_List (
1325                    Make_Simple_Return_Statement (Loc,
1326                      Make_Null (Loc))),
1327                  Else_Statements => Stats));
1328             end if;
1329
1330             Fent := Make_Temporary (Loc, 'F');
1331             Func :=
1332               Make_Subprogram_Body (Loc,
1333                 Specification =>
1334                   Make_Function_Specification (Loc,
1335                     Defining_Unit_Name => Fent,
1336
1337                     Parameter_Specifications => New_List (
1338                       Make_Parameter_Specification (Loc,
1339                         Defining_Identifier =>
1340                           Make_Defining_Identifier (Loc, Name_uO),
1341                         Parameter_Type =>
1342                           New_Reference_To (RTE (RE_Address), Loc))),
1343
1344                     Result_Definition =>
1345                       New_Reference_To (Etype (N), Loc)),
1346
1347                 Declarations => New_List (New_Typ_Decl),
1348
1349                 Handled_Statement_Sequence =>
1350                   Make_Handled_Sequence_Of_Statements (Loc, Stats));
1351
1352             --  Place function body before the expression containing the
1353             --  conversion. We suppress all checks because the body of the
1354             --  internally generated function already takes care of the case
1355             --  in which the actual is null; therefore there is no need to
1356             --  double check that the pointer is not null when the program
1357             --  executes the alternative that performs the type conversion).
1358
1359             Insert_Action (N, Func, Suppress => All_Checks);
1360
1361             if Is_Access_Type (Etype (Expression (N))) then
1362
1363                --  Generate: Func (Address!(Expression))
1364
1365                Rewrite (N,
1366                  Make_Function_Call (Loc,
1367                    Name => New_Reference_To (Fent, Loc),
1368                    Parameter_Associations => New_List (
1369                      Unchecked_Convert_To (RTE (RE_Address),
1370                        Relocate_Node (Expression (N))))));
1371
1372             else
1373                --  Generate: Func (Operand_Typ!(Expression)'Address)
1374
1375                Rewrite (N,
1376                  Make_Function_Call (Loc,
1377                    Name => New_Reference_To (Fent, Loc),
1378                    Parameter_Associations => New_List (
1379                      Make_Attribute_Reference (Loc,
1380                        Prefix  => Unchecked_Convert_To (Operand_Typ,
1381                                     Relocate_Node (Expression (N))),
1382                        Attribute_Name => Name_Address))));
1383             end if;
1384          end;
1385       end if;
1386
1387       Analyze (N);
1388    end Expand_Interface_Conversion;
1389
1390    ------------------------------
1391    -- Expand_Interface_Actuals --
1392    ------------------------------
1393
1394    procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
1395       Actual     : Node_Id;
1396       Actual_Dup : Node_Id;
1397       Actual_Typ : Entity_Id;
1398       Anon       : Entity_Id;
1399       Conversion : Node_Id;
1400       Formal     : Entity_Id;
1401       Formal_Typ : Entity_Id;
1402       Subp       : Entity_Id;
1403       Formal_DDT : Entity_Id;
1404       Actual_DDT : Entity_Id;
1405
1406    begin
1407       --  This subprogram is called directly from the semantics, so we need a
1408       --  check to see whether expansion is active before proceeding.
1409
1410       if not Expander_Active then
1411          return;
1412       end if;
1413
1414       --  Call using access to subprogram with explicit dereference
1415
1416       if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
1417          Subp := Etype (Name (Call_Node));
1418
1419       --  Call using selected component
1420
1421       elsif Nkind (Name (Call_Node)) = N_Selected_Component then
1422          Subp := Entity (Selector_Name (Name (Call_Node)));
1423
1424       --  Call using direct name
1425
1426       else
1427          Subp := Entity (Name (Call_Node));
1428       end if;
1429
1430       --  Ada 2005 (AI-251): Look for interface type formals to force "this"
1431       --  displacement
1432
1433       Formal := First_Formal (Subp);
1434       Actual := First_Actual (Call_Node);
1435       while Present (Formal) loop
1436          Formal_Typ := Etype (Formal);
1437
1438          if Ekind (Formal_Typ) = E_Record_Type_With_Private then
1439             Formal_Typ := Full_View (Formal_Typ);
1440          end if;
1441
1442          if Is_Access_Type (Formal_Typ) then
1443             Formal_DDT := Directly_Designated_Type (Formal_Typ);
1444          end if;
1445
1446          Actual_Typ := Etype (Actual);
1447
1448          if Is_Access_Type (Actual_Typ) then
1449             Actual_DDT := Directly_Designated_Type (Actual_Typ);
1450          end if;
1451
1452          if Is_Interface (Formal_Typ)
1453            and then Is_Class_Wide_Type (Formal_Typ)
1454          then
1455             --  No need to displace the pointer if the type of the actual
1456             --  coincides with the type of the formal.
1457
1458             if Actual_Typ = Formal_Typ then
1459                null;
1460
1461             --  No need to displace the pointer if the interface type is
1462             --  a parent of the type of the actual because in this case the
1463             --  interface primitives are located in the primary dispatch table.
1464
1465             elsif Is_Ancestor (Formal_Typ, Actual_Typ,
1466                                Use_Full_View => True)
1467             then
1468                null;
1469
1470             --  Implicit conversion to the class-wide formal type to force
1471             --  the displacement of the pointer.
1472
1473             else
1474                --  Normally, expansion of actuals for calls to build-in-place
1475                --  functions happens as part of Expand_Actuals, but in this
1476                --  case the call will be wrapped in a conversion and soon after
1477                --  expanded further to handle the displacement for a class-wide
1478                --  interface conversion, so if this is a BIP call then we need
1479                --  to handle it now.
1480
1481                if Ada_Version >= Ada_2005
1482                  and then Is_Build_In_Place_Function_Call (Actual)
1483                then
1484                   Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
1485                end if;
1486
1487                Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
1488                Rewrite (Actual, Conversion);
1489                Analyze_And_Resolve (Actual, Formal_Typ);
1490             end if;
1491
1492          --  Access to class-wide interface type
1493
1494          elsif Is_Access_Type (Formal_Typ)
1495            and then Is_Interface (Formal_DDT)
1496            and then Is_Class_Wide_Type (Formal_DDT)
1497            and then Interface_Present_In_Ancestor
1498                       (Typ   => Actual_DDT,
1499                        Iface => Etype (Formal_DDT))
1500          then
1501             --  Handle attributes 'Access and 'Unchecked_Access
1502
1503             if Nkind (Actual) = N_Attribute_Reference
1504               and then
1505                (Attribute_Name (Actual) = Name_Access
1506                  or else Attribute_Name (Actual) = Name_Unchecked_Access)
1507             then
1508                --  This case must have been handled by the analysis and
1509                --  expansion of 'Access. The only exception is when types
1510                --  match and no further expansion is required.
1511
1512                pragma Assert (Base_Type (Etype (Prefix (Actual)))
1513                                = Base_Type (Formal_DDT));
1514                null;
1515
1516             --  No need to displace the pointer if the type of the actual
1517             --  coincides with the type of the formal.
1518
1519             elsif Actual_DDT = Formal_DDT then
1520                null;
1521
1522             --  No need to displace the pointer if the interface type is
1523             --  a parent of the type of the actual because in this case the
1524             --  interface primitives are located in the primary dispatch table.
1525
1526             elsif Is_Ancestor (Formal_DDT, Actual_DDT,
1527                                Use_Full_View => True)
1528             then
1529                null;
1530
1531             else
1532                Actual_Dup := Relocate_Node (Actual);
1533
1534                if From_With_Type (Actual_Typ) then
1535
1536                   --  If the type of the actual parameter comes from a limited
1537                   --  with-clause and the non-limited view is already available
1538                   --  we replace the anonymous access type by a duplicate
1539                   --  declaration whose designated type is the non-limited view
1540
1541                   if Ekind (Actual_DDT) = E_Incomplete_Type
1542                     and then Present (Non_Limited_View (Actual_DDT))
1543                   then
1544                      Anon := New_Copy (Actual_Typ);
1545
1546                      if Is_Itype (Anon) then
1547                         Set_Scope (Anon, Current_Scope);
1548                      end if;
1549
1550                      Set_Directly_Designated_Type (Anon,
1551                        Non_Limited_View (Actual_DDT));
1552                      Set_Etype (Actual_Dup, Anon);
1553
1554                   elsif Is_Class_Wide_Type (Actual_DDT)
1555                     and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type
1556                     and then Present (Non_Limited_View (Etype (Actual_DDT)))
1557                   then
1558                      Anon := New_Copy (Actual_Typ);
1559
1560                      if Is_Itype (Anon) then
1561                         Set_Scope (Anon, Current_Scope);
1562                      end if;
1563
1564                      Set_Directly_Designated_Type (Anon,
1565                        New_Copy (Actual_DDT));
1566                      Set_Class_Wide_Type (Directly_Designated_Type (Anon),
1567                        New_Copy (Class_Wide_Type (Actual_DDT)));
1568                      Set_Etype (Directly_Designated_Type (Anon),
1569                        Non_Limited_View (Etype (Actual_DDT)));
1570                      Set_Etype (
1571                        Class_Wide_Type (Directly_Designated_Type (Anon)),
1572                        Non_Limited_View (Etype (Actual_DDT)));
1573                      Set_Etype (Actual_Dup, Anon);
1574                   end if;
1575                end if;
1576
1577                Conversion := Convert_To (Formal_Typ, Actual_Dup);
1578                Rewrite (Actual, Conversion);
1579                Analyze_And_Resolve (Actual, Formal_Typ);
1580             end if;
1581          end if;
1582
1583          Next_Actual (Actual);
1584          Next_Formal (Formal);
1585       end loop;
1586    end Expand_Interface_Actuals;
1587
1588    ----------------------------
1589    -- Expand_Interface_Thunk --
1590    ----------------------------
1591
1592    procedure Expand_Interface_Thunk
1593      (Prim       : Node_Id;
1594       Thunk_Id   : out Entity_Id;
1595       Thunk_Code : out Node_Id)
1596    is
1597       Loc     : constant Source_Ptr := Sloc (Prim);
1598       Actuals : constant List_Id    := New_List;
1599       Decl    : constant List_Id    := New_List;
1600       Formals : constant List_Id    := New_List;
1601       Target  : constant Entity_Id  := Ultimate_Alias (Prim);
1602
1603       Controlling_Typ : Entity_Id;
1604       Decl_1          : Node_Id;
1605       Decl_2          : Node_Id;
1606       Expr            : Node_Id;
1607       Formal          : Node_Id;
1608       Ftyp            : Entity_Id;
1609       Iface_Formal    : Node_Id;
1610       New_Arg         : Node_Id;
1611       Offset_To_Top   : Node_Id;
1612       Target_Formal   : Entity_Id;
1613
1614    begin
1615       Thunk_Id   := Empty;
1616       Thunk_Code := Empty;
1617
1618       --  No thunk needed if the primitive has been eliminated
1619
1620       if Is_Eliminated (Ultimate_Alias (Prim)) then
1621          return;
1622
1623       --  In case of primitives that are functions without formals and a
1624       --  controlling result there is no need to build the thunk.
1625
1626       elsif not Present (First_Formal (Target)) then
1627          pragma Assert (Ekind (Target) = E_Function
1628            and then Has_Controlling_Result (Target));
1629          return;
1630       end if;
1631
1632       --  Duplicate the formals of the Target primitive. In the thunk, the type
1633       --  of the controlling formal is the covered interface type (instead of
1634       --  the target tagged type). Done to avoid problems with discriminated
1635       --  tagged types because, if the controlling type has discriminants with
1636       --  default values, then the type conversions done inside the body of
1637       --  the thunk (after the displacement of the pointer to the base of the
1638       --  actual object) generate code that modify its contents.
1639
1640       --  Note: This special management is not done for predefined primitives
1641       --  because???
1642
1643       if not Is_Predefined_Dispatching_Operation (Prim) then
1644          Iface_Formal := First_Formal (Interface_Alias (Prim));
1645       end if;
1646
1647       Formal := First_Formal (Target);
1648       while Present (Formal) loop
1649          Ftyp := Etype (Formal);
1650
1651          --  Use the interface type as the type of the controlling formal (see
1652          --  comment above).
1653
1654          if not Is_Controlling_Formal (Formal)
1655            or else Is_Predefined_Dispatching_Operation (Prim)
1656          then
1657             Ftyp := Etype (Formal);
1658             Expr := New_Copy_Tree (Expression (Parent (Formal)));
1659          else
1660             Ftyp := Etype (Iface_Formal);
1661             Expr := Empty;
1662          end if;
1663
1664          Append_To (Formals,
1665            Make_Parameter_Specification (Loc,
1666              Defining_Identifier =>
1667                Make_Defining_Identifier (Sloc (Formal),
1668                  Chars => Chars (Formal)),
1669              In_Present => In_Present (Parent (Formal)),
1670              Out_Present => Out_Present (Parent (Formal)),
1671              Parameter_Type => New_Reference_To (Ftyp, Loc),
1672              Expression => Expr));
1673
1674          if not Is_Predefined_Dispatching_Operation (Prim) then
1675             Next_Formal (Iface_Formal);
1676          end if;
1677
1678          Next_Formal (Formal);
1679       end loop;
1680
1681       Controlling_Typ := Find_Dispatching_Type (Target);
1682
1683       Target_Formal := First_Formal (Target);
1684       Formal        := First (Formals);
1685       while Present (Formal) loop
1686
1687          --  If the parent is a constrained discriminated type, then the
1688          --  primitive operation will have been defined on a first subtype.
1689          --  For proper matching with controlling type, use base type.
1690
1691          if Ekind (Target_Formal) = E_In_Parameter
1692            and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1693          then
1694             Ftyp :=
1695               Base_Type (Directly_Designated_Type (Etype (Target_Formal)));
1696          else
1697             Ftyp := Base_Type (Etype (Target_Formal));
1698          end if;
1699
1700          --  For concurrent types, the relevant information is found in the
1701          --  Corresponding_Record_Type, rather than the type entity itself.
1702
1703          if Is_Concurrent_Type (Ftyp) then
1704             Ftyp := Corresponding_Record_Type (Ftyp);
1705          end if;
1706
1707          if Ekind (Target_Formal) = E_In_Parameter
1708            and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1709            and then Ftyp = Controlling_Typ
1710          then
1711             --  Generate:
1712             --     type T is access all <<type of the target formal>>
1713             --     S : Storage_Offset := Storage_Offset!(Formal)
1714             --                            - Offset_To_Top (address!(Formal))
1715
1716             Decl_2 :=
1717               Make_Full_Type_Declaration (Loc,
1718                 Defining_Identifier => Make_Temporary (Loc, 'T'),
1719                 Type_Definition =>
1720                   Make_Access_To_Object_Definition (Loc,
1721                     All_Present            => True,
1722                     Null_Exclusion_Present => False,
1723                     Constant_Present       => False,
1724                     Subtype_Indication     =>
1725                       New_Reference_To (Ftyp, Loc)));
1726
1727             New_Arg :=
1728               Unchecked_Convert_To (RTE (RE_Address),
1729                 New_Reference_To (Defining_Identifier (Formal), Loc));
1730
1731             if not RTE_Available (RE_Offset_To_Top) then
1732                Offset_To_Top :=
1733                  Build_Offset_To_Top (Loc, New_Arg);
1734             else
1735                Offset_To_Top :=
1736                  Make_Function_Call (Loc,
1737                    Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1738                    Parameter_Associations => New_List (New_Arg));
1739             end if;
1740
1741             Decl_1 :=
1742               Make_Object_Declaration (Loc,
1743                 Defining_Identifier => Make_Temporary (Loc, 'S'),
1744                 Constant_Present    => True,
1745                 Object_Definition   =>
1746                   New_Reference_To (RTE (RE_Storage_Offset), Loc),
1747                 Expression          =>
1748                   Make_Op_Subtract (Loc,
1749                     Left_Opnd  =>
1750                       Unchecked_Convert_To
1751                         (RTE (RE_Storage_Offset),
1752                          New_Reference_To (Defining_Identifier (Formal), Loc)),
1753                      Right_Opnd =>
1754                        Offset_To_Top));
1755
1756             Append_To (Decl, Decl_2);
1757             Append_To (Decl, Decl_1);
1758
1759             --  Reference the new actual. Generate:
1760             --    T!(S)
1761
1762             Append_To (Actuals,
1763               Unchecked_Convert_To
1764                 (Defining_Identifier (Decl_2),
1765                  New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1766
1767          elsif Ftyp = Controlling_Typ then
1768
1769             --  Generate:
1770             --     S1 : Storage_Offset := Storage_Offset!(Formal'Address)
1771             --                             - Offset_To_Top (Formal'Address)
1772             --     S2 : Addr_Ptr := Addr_Ptr!(S1)
1773
1774             New_Arg :=
1775               Make_Attribute_Reference (Loc,
1776                 Prefix =>
1777                   New_Reference_To (Defining_Identifier (Formal), Loc),
1778                 Attribute_Name =>
1779                   Name_Address);
1780
1781             if not RTE_Available (RE_Offset_To_Top) then
1782                Offset_To_Top :=
1783                  Build_Offset_To_Top (Loc, New_Arg);
1784             else
1785                Offset_To_Top :=
1786                  Make_Function_Call (Loc,
1787                    Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1788                    Parameter_Associations => New_List (New_Arg));
1789             end if;
1790
1791             Decl_1 :=
1792               Make_Object_Declaration (Loc,
1793                 Defining_Identifier => Make_Temporary (Loc, 'S'),
1794                 Constant_Present    => True,
1795                 Object_Definition   =>
1796                   New_Reference_To (RTE (RE_Storage_Offset), Loc),
1797                 Expression          =>
1798                   Make_Op_Subtract (Loc,
1799                     Left_Opnd =>
1800                       Unchecked_Convert_To
1801                         (RTE (RE_Storage_Offset),
1802                          Make_Attribute_Reference (Loc,
1803                            Prefix =>
1804                              New_Reference_To
1805                                (Defining_Identifier (Formal), Loc),
1806                            Attribute_Name => Name_Address)),
1807                     Right_Opnd =>
1808                       Offset_To_Top));
1809
1810             Decl_2 :=
1811               Make_Object_Declaration (Loc,
1812                 Defining_Identifier => Make_Temporary (Loc, 'S'),
1813                 Constant_Present    => True,
1814                 Object_Definition   =>
1815                   New_Reference_To (RTE (RE_Addr_Ptr), Loc),
1816                 Expression          =>
1817                   Unchecked_Convert_To
1818                     (RTE (RE_Addr_Ptr),
1819                      New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1820
1821             Append_To (Decl, Decl_1);
1822             Append_To (Decl, Decl_2);
1823
1824             --  Reference the new actual, generate:
1825             --    Target_Formal (S2.all)
1826
1827             Append_To (Actuals,
1828               Unchecked_Convert_To (Ftyp,
1829                  Make_Explicit_Dereference (Loc,
1830                    New_Reference_To (Defining_Identifier (Decl_2), Loc))));
1831
1832          --  No special management required for this actual
1833
1834          else
1835             Append_To (Actuals,
1836                New_Reference_To (Defining_Identifier (Formal), Loc));
1837          end if;
1838
1839          Next_Formal (Target_Formal);
1840          Next (Formal);
1841       end loop;
1842
1843       Thunk_Id := Make_Temporary (Loc, 'T');
1844       Set_Is_Thunk (Thunk_Id);
1845
1846       --  Procedure case
1847
1848       if Ekind (Target) = E_Procedure then
1849          Thunk_Code :=
1850            Make_Subprogram_Body (Loc,
1851               Specification =>
1852                 Make_Procedure_Specification (Loc,
1853                   Defining_Unit_Name       => Thunk_Id,
1854                   Parameter_Specifications => Formals),
1855               Declarations => Decl,
1856               Handled_Statement_Sequence =>
1857                 Make_Handled_Sequence_Of_Statements (Loc,
1858                   Statements => New_List (
1859                     Make_Procedure_Call_Statement (Loc,
1860                       Name => New_Occurrence_Of (Target, Loc),
1861                       Parameter_Associations => Actuals))));
1862
1863       --  Function case
1864
1865       else pragma Assert (Ekind (Target) = E_Function);
1866          Thunk_Code :=
1867            Make_Subprogram_Body (Loc,
1868               Specification =>
1869                 Make_Function_Specification (Loc,
1870                   Defining_Unit_Name       => Thunk_Id,
1871                   Parameter_Specifications => Formals,
1872                   Result_Definition =>
1873                     New_Copy (Result_Definition (Parent (Target)))),
1874               Declarations => Decl,
1875               Handled_Statement_Sequence =>
1876                 Make_Handled_Sequence_Of_Statements (Loc,
1877                   Statements => New_List (
1878                     Make_Simple_Return_Statement (Loc,
1879                       Make_Function_Call (Loc,
1880                         Name => New_Occurrence_Of (Target, Loc),
1881                         Parameter_Associations => Actuals)))));
1882       end if;
1883    end Expand_Interface_Thunk;
1884
1885    ------------------------
1886    -- Find_Specific_Type --
1887    ------------------------
1888
1889    function Find_Specific_Type (CW : Entity_Id) return Entity_Id is
1890       Typ : Entity_Id := Root_Type (CW);
1891
1892    begin
1893       if Ekind (Typ) = E_Incomplete_Type then
1894          if From_With_Type (Typ) then
1895             Typ := Non_Limited_View (Typ);
1896          else
1897             Typ := Full_View (Typ);
1898          end if;
1899       end if;
1900
1901       return Typ;
1902    end Find_Specific_Type;
1903
1904    --------------------------
1905    -- Has_CPP_Constructors --
1906    --------------------------
1907
1908    function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is
1909       E : Entity_Id;
1910
1911    begin
1912       --  Look for the constructor entities
1913
1914       E := Next_Entity (Typ);
1915       while Present (E) loop
1916          if Ekind (E) = E_Function
1917            and then Is_Constructor (E)
1918          then
1919             return True;
1920          end if;
1921
1922          Next_Entity (E);
1923       end loop;
1924
1925       return False;
1926    end Has_CPP_Constructors;
1927
1928    ------------
1929    -- Has_DT --
1930    ------------
1931
1932    function Has_DT (Typ : Entity_Id) return Boolean is
1933    begin
1934       return not Is_Interface (Typ)
1935                and then not Restriction_Active (No_Dispatching_Calls);
1936    end Has_DT;
1937
1938    -----------------------------------------
1939    -- Is_Predefined_Dispatching_Operation --
1940    -----------------------------------------
1941
1942    function Is_Predefined_Dispatching_Operation
1943      (E : Entity_Id) return Boolean
1944    is
1945       TSS_Name : TSS_Name_Type;
1946
1947    begin
1948       if not Is_Dispatching_Operation (E) then
1949          return False;
1950       end if;
1951
1952       Get_Name_String (Chars (E));
1953
1954       --  Most predefined primitives have internally generated names. Equality
1955       --  must be treated differently; the predefined operation is recognized
1956       --  as a homogeneous binary operator that returns Boolean.
1957
1958       if Name_Len > TSS_Name_Type'Last then
1959          TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
1960                                      .. Name_Len));
1961          if        Chars (E) = Name_uSize
1962            or else TSS_Name  = TSS_Stream_Read
1963            or else TSS_Name  = TSS_Stream_Write
1964            or else TSS_Name  = TSS_Stream_Input
1965            or else TSS_Name  = TSS_Stream_Output
1966            or else
1967              (Chars (E) = Name_Op_Eq
1968                 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
1969            or else Chars (E) = Name_uAssign
1970            or else TSS_Name  = TSS_Deep_Adjust
1971            or else TSS_Name  = TSS_Deep_Finalize
1972            or else Is_Predefined_Interface_Primitive (E)
1973          then
1974             return True;
1975          end if;
1976       end if;
1977
1978       return False;
1979    end Is_Predefined_Dispatching_Operation;
1980
1981    ---------------------------------------
1982    -- Is_Predefined_Internal_Operation  --
1983    ---------------------------------------
1984
1985    function Is_Predefined_Internal_Operation
1986      (E : Entity_Id) return Boolean
1987    is
1988       TSS_Name : TSS_Name_Type;
1989
1990    begin
1991       if not Is_Dispatching_Operation (E) then
1992          return False;
1993       end if;
1994
1995       Get_Name_String (Chars (E));
1996
1997       --  Most predefined primitives have internally generated names. Equality
1998       --  must be treated differently; the predefined operation is recognized
1999       --  as a homogeneous binary operator that returns Boolean.
2000
2001       if Name_Len > TSS_Name_Type'Last then
2002          TSS_Name :=
2003            TSS_Name_Type
2004              (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
2005
2006          if        Chars (E) = Name_uSize
2007            or else
2008              (Chars (E) = Name_Op_Eq
2009                 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
2010            or else Chars (E) = Name_uAssign
2011            or else TSS_Name  = TSS_Deep_Adjust
2012            or else TSS_Name  = TSS_Deep_Finalize
2013            or else Is_Predefined_Interface_Primitive (E)
2014          then
2015             return True;
2016          end if;
2017       end if;
2018
2019       return False;
2020    end Is_Predefined_Internal_Operation;
2021
2022    -------------------------------------
2023    -- Is_Predefined_Dispatching_Alias --
2024    -------------------------------------
2025
2026    function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
2027    is
2028    begin
2029       return not Is_Predefined_Dispatching_Operation (Prim)
2030         and then Present (Alias (Prim))
2031         and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim));
2032    end Is_Predefined_Dispatching_Alias;
2033
2034    ---------------------------------------
2035    -- Is_Predefined_Interface_Primitive --
2036    ---------------------------------------
2037
2038    function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
2039    begin
2040       --  In VM targets we don't restrict the functionality of this test to
2041       --  compiling in Ada 2005 mode since in VM targets any tagged type has
2042       --  these primitives
2043
2044       return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
2045         and then (Chars (E) = Name_uDisp_Asynchronous_Select or else
2046                   Chars (E) = Name_uDisp_Conditional_Select  or else
2047                   Chars (E) = Name_uDisp_Get_Prim_Op_Kind    or else
2048                   Chars (E) = Name_uDisp_Get_Task_Id         or else
2049                   Chars (E) = Name_uDisp_Requeue             or else
2050                   Chars (E) = Name_uDisp_Timed_Select);
2051    end Is_Predefined_Interface_Primitive;
2052
2053    ----------------------------------------
2054    -- Make_Disp_Asynchronous_Select_Body --
2055    ----------------------------------------
2056
2057    --  For interface types, generate:
2058
2059    --     procedure _Disp_Asynchronous_Select
2060    --       (T : in out <Typ>;
2061    --        S : Integer;
2062    --        P : System.Address;
2063    --        B : out System.Storage_Elements.Dummy_Communication_Block;
2064    --        F : out Boolean)
2065    --     is
2066    --     begin
2067    --        F := False;
2068    --        C := Ada.Tags.POK_Function;
2069    --     end _Disp_Asynchronous_Select;
2070
2071    --  For protected types, generate:
2072
2073    --     procedure _Disp_Asynchronous_Select
2074    --       (T : in out <Typ>;
2075    --        S : Integer;
2076    --        P : System.Address;
2077    --        B : out System.Storage_Elements.Dummy_Communication_Block;
2078    --        F : out Boolean)
2079    --     is
2080    --        I   : Integer :=
2081    --                Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2082    --        Bnn : System.Tasking.Protected_Objects.Operations.
2083    --                Communication_Block;
2084    --     begin
2085    --        System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2086    --          (T._object'Access,
2087    --           System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2088    --           P,
2089    --           System.Tasking.Asynchronous_Call,
2090    --           Bnn);
2091    --        B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
2092    --     end _Disp_Asynchronous_Select;
2093
2094    --  For task types, generate:
2095
2096    --     procedure _Disp_Asynchronous_Select
2097    --       (T : in out <Typ>;
2098    --        S : Integer;
2099    --        P : System.Address;
2100    --        B : out System.Storage_Elements.Dummy_Communication_Block;
2101    --        F : out Boolean)
2102    --     is
2103    --        I   : Integer :=
2104    --                Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2105    --     begin
2106    --        System.Tasking.Rendezvous.Task_Entry_Call
2107    --          (T._task_id,
2108    --           System.Tasking.Task_Entry_Index (I),
2109    --           P,
2110    --           System.Tasking.Asynchronous_Call,
2111    --           F);
2112    --     end _Disp_Asynchronous_Select;
2113
2114    function Make_Disp_Asynchronous_Select_Body
2115      (Typ : Entity_Id) return Node_Id
2116    is
2117       Com_Block : Entity_Id;
2118       Conc_Typ  : Entity_Id           := Empty;
2119       Decls     : constant List_Id    := New_List;
2120       Loc       : constant Source_Ptr := Sloc (Typ);
2121       Obj_Ref   : Node_Id;
2122       Stmts     : constant List_Id    := New_List;
2123       Tag_Node  : Node_Id;
2124
2125    begin
2126       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2127
2128       --  Null body is generated for interface types
2129
2130       if Is_Interface (Typ) then
2131          return
2132            Make_Subprogram_Body (Loc,
2133              Specification => Make_Disp_Asynchronous_Select_Spec (Typ),
2134              Declarations  => New_List,
2135              Handled_Statement_Sequence =>
2136                Make_Handled_Sequence_Of_Statements (Loc,
2137                  New_List (Make_Assignment_Statement (Loc,
2138                    Name       => Make_Identifier (Loc, Name_uF),
2139                    Expression => New_Reference_To (Standard_False, Loc)))));
2140       end if;
2141
2142       if Is_Concurrent_Record_Type (Typ) then
2143          Conc_Typ := Corresponding_Concurrent_Type (Typ);
2144
2145          --  Generate:
2146          --    I : Integer :=
2147          --          Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2148
2149          --  where I will be used to capture the entry index of the primitive
2150          --  wrapper at position S.
2151
2152          if Tagged_Type_Expansion then
2153             Tag_Node :=
2154               Unchecked_Convert_To (RTE (RE_Tag),
2155                 New_Reference_To
2156                   (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2157          else
2158             Tag_Node :=
2159               Make_Attribute_Reference (Loc,
2160                 Prefix => New_Reference_To (Typ, Loc),
2161                 Attribute_Name => Name_Tag);
2162          end if;
2163
2164          Append_To (Decls,
2165            Make_Object_Declaration (Loc,
2166              Defining_Identifier =>
2167                Make_Defining_Identifier (Loc, Name_uI),
2168              Object_Definition =>
2169                New_Reference_To (Standard_Integer, Loc),
2170              Expression =>
2171                Make_Function_Call (Loc,
2172                  Name =>
2173                    New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
2174                  Parameter_Associations =>
2175                    New_List (
2176                      Tag_Node,
2177                      Make_Identifier (Loc, Name_uS)))));
2178
2179          if Ekind (Conc_Typ) = E_Protected_Type then
2180
2181             --  Generate:
2182             --    Bnn : Communication_Block;
2183
2184             Com_Block := Make_Temporary (Loc, 'B');
2185             Append_To (Decls,
2186               Make_Object_Declaration (Loc,
2187                 Defining_Identifier =>
2188                   Com_Block,
2189                 Object_Definition =>
2190                   New_Reference_To (RTE (RE_Communication_Block), Loc)));
2191
2192             --  Build T._object'Access for calls below
2193
2194             Obj_Ref :=
2195                Make_Attribute_Reference (Loc,
2196                  Attribute_Name => Name_Unchecked_Access,
2197                  Prefix         =>
2198                    Make_Selected_Component (Loc,
2199                      Prefix        => Make_Identifier (Loc, Name_uT),
2200                      Selector_Name => Make_Identifier (Loc, Name_uObject)));
2201
2202             case Corresponding_Runtime_Package (Conc_Typ) is
2203                when System_Tasking_Protected_Objects_Entries =>
2204
2205                   --  Generate:
2206                   --    Protected_Entry_Call
2207                   --      (T._object'Access,            --  Object
2208                   --       Protected_Entry_Index! (I),  --  E
2209                   --       P,                           --  Uninterpreted_Data
2210                   --       Asynchronous_Call,           --  Mode
2211                   --       Bnn);                        --  Communication_Block
2212
2213                   --  where T is the protected object, I is the entry index, P
2214                   --  is the wrapped parameters and B is the name of the
2215                   --  communication block.
2216
2217                   Append_To (Stmts,
2218                     Make_Procedure_Call_Statement (Loc,
2219                       Name =>
2220                         New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
2221                       Parameter_Associations =>
2222                         New_List (
2223                           Obj_Ref,
2224
2225                           Make_Unchecked_Type_Conversion (Loc,  --  entry index
2226                             Subtype_Mark =>
2227                               New_Reference_To
2228                                 (RTE (RE_Protected_Entry_Index), Loc),
2229                             Expression => Make_Identifier (Loc, Name_uI)),
2230
2231                           Make_Identifier (Loc, Name_uP), --  parameter block
2232                           New_Reference_To                --  Asynchronous_Call
2233                             (RTE (RE_Asynchronous_Call), Loc),
2234
2235                           New_Reference_To (Com_Block, Loc)))); -- comm block
2236
2237                when System_Tasking_Protected_Objects_Single_Entry =>
2238
2239                   --  Generate:
2240                   --    procedure Protected_Single_Entry_Call
2241                   --      (Object              : Protection_Entry_Access;
2242                   --       Uninterpreted_Data  : System.Address;
2243                   --       Mode                : Call_Modes);
2244
2245                   Append_To (Stmts,
2246                     Make_Procedure_Call_Statement (Loc,
2247                       Name =>
2248                         New_Reference_To
2249                           (RTE (RE_Protected_Single_Entry_Call), Loc),
2250                       Parameter_Associations =>
2251                         New_List (
2252                           Obj_Ref,
2253
2254                           Make_Attribute_Reference (Loc,
2255                             Prefix         => Make_Identifier (Loc, Name_uP),
2256                             Attribute_Name => Name_Address),
2257
2258                             New_Reference_To
2259                              (RTE (RE_Asynchronous_Call), Loc))));
2260
2261                when others =>
2262                   raise Program_Error;
2263             end case;
2264
2265             --  Generate:
2266             --    B := Dummy_Communication_Block (Bnn);
2267
2268             Append_To (Stmts,
2269               Make_Assignment_Statement (Loc,
2270                 Name => Make_Identifier (Loc, Name_uB),
2271                 Expression =>
2272                   Make_Unchecked_Type_Conversion (Loc,
2273                     Subtype_Mark =>
2274                       New_Reference_To (
2275                         RTE (RE_Dummy_Communication_Block), Loc),
2276                     Expression =>
2277                       New_Reference_To (Com_Block, Loc))));
2278
2279             --  Generate:
2280             --    F := False;
2281
2282             Append_To (Stmts,
2283               Make_Assignment_Statement (Loc,
2284                 Name       => Make_Identifier (Loc, Name_uF),
2285                 Expression => New_Reference_To (Standard_False, Loc)));
2286
2287          else
2288             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2289
2290             --  Generate:
2291             --    Task_Entry_Call
2292             --      (T._task_id,             --  Acceptor
2293             --       Task_Entry_Index! (I),  --  E
2294             --       P,                      --  Uninterpreted_Data
2295             --       Asynchronous_Call,      --  Mode
2296             --       F);                     --  Rendezvous_Successful
2297
2298             --  where T is the task object, I is the entry index, P is the
2299             --  wrapped parameters and F is the status flag.
2300
2301             Append_To (Stmts,
2302               Make_Procedure_Call_Statement (Loc,
2303                 Name =>
2304                   New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
2305                 Parameter_Associations =>
2306                   New_List (
2307                     Make_Selected_Component (Loc,         -- T._task_id
2308                       Prefix        => Make_Identifier (Loc, Name_uT),
2309                       Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2310
2311                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
2312                       Subtype_Mark =>
2313                         New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2314                       Expression => Make_Identifier (Loc, Name_uI)),
2315
2316                     Make_Identifier (Loc, Name_uP),       --  parameter block
2317                     New_Reference_To                      --  Asynchronous_Call
2318                       (RTE (RE_Asynchronous_Call), Loc),
2319                     Make_Identifier (Loc, Name_uF))));    --  status flag
2320          end if;
2321
2322       else
2323          --  Ensure that the statements list is non-empty
2324
2325          Append_To (Stmts,
2326            Make_Assignment_Statement (Loc,
2327              Name       => Make_Identifier (Loc, Name_uF),
2328              Expression => New_Reference_To (Standard_False, Loc)));
2329       end if;
2330
2331       return
2332         Make_Subprogram_Body (Loc,
2333           Specification              =>
2334             Make_Disp_Asynchronous_Select_Spec (Typ),
2335           Declarations               => Decls,
2336           Handled_Statement_Sequence =>
2337             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2338    end Make_Disp_Asynchronous_Select_Body;
2339
2340    ----------------------------------------
2341    -- Make_Disp_Asynchronous_Select_Spec --
2342    ----------------------------------------
2343
2344    function Make_Disp_Asynchronous_Select_Spec
2345      (Typ : Entity_Id) return Node_Id
2346    is
2347       Loc    : constant Source_Ptr := Sloc (Typ);
2348       Def_Id : constant Node_Id    :=
2349                  Make_Defining_Identifier (Loc,
2350                    Name_uDisp_Asynchronous_Select);
2351       Params : constant List_Id    := New_List;
2352
2353    begin
2354       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2355
2356       --  T : in out Typ;                     --  Object parameter
2357       --  S : Integer;                        --  Primitive operation slot
2358       --  P : Address;                        --  Wrapped parameters
2359       --  B : out Dummy_Communication_Block;  --  Communication block dummy
2360       --  F : out Boolean;                    --  Status flag
2361
2362       Append_List_To (Params, New_List (
2363
2364         Make_Parameter_Specification (Loc,
2365           Defining_Identifier =>
2366             Make_Defining_Identifier (Loc, Name_uT),
2367           Parameter_Type =>
2368             New_Reference_To (Typ, Loc),
2369           In_Present  => True,
2370           Out_Present => True),
2371
2372         Make_Parameter_Specification (Loc,
2373           Defining_Identifier =>
2374             Make_Defining_Identifier (Loc, Name_uS),
2375           Parameter_Type =>
2376             New_Reference_To (Standard_Integer, Loc)),
2377
2378         Make_Parameter_Specification (Loc,
2379           Defining_Identifier =>
2380             Make_Defining_Identifier (Loc, Name_uP),
2381           Parameter_Type =>
2382             New_Reference_To (RTE (RE_Address), Loc)),
2383
2384         Make_Parameter_Specification (Loc,
2385           Defining_Identifier =>
2386             Make_Defining_Identifier (Loc, Name_uB),
2387           Parameter_Type =>
2388             New_Reference_To (RTE (RE_Dummy_Communication_Block), Loc),
2389           Out_Present => True),
2390
2391         Make_Parameter_Specification (Loc,
2392           Defining_Identifier =>
2393             Make_Defining_Identifier (Loc, Name_uF),
2394           Parameter_Type =>
2395             New_Reference_To (Standard_Boolean, Loc),
2396           Out_Present => True)));
2397
2398       return
2399         Make_Procedure_Specification (Loc,
2400           Defining_Unit_Name       => Def_Id,
2401           Parameter_Specifications => Params);
2402    end Make_Disp_Asynchronous_Select_Spec;
2403
2404    ---------------------------------------
2405    -- Make_Disp_Conditional_Select_Body --
2406    ---------------------------------------
2407
2408    --  For interface types, generate:
2409
2410    --     procedure _Disp_Conditional_Select
2411    --       (T : in out <Typ>;
2412    --        S : Integer;
2413    --        P : System.Address;
2414    --        C : out Ada.Tags.Prim_Op_Kind;
2415    --        F : out Boolean)
2416    --     is
2417    --     begin
2418    --        F := False;
2419    --        C := Ada.Tags.POK_Function;
2420    --     end _Disp_Conditional_Select;
2421
2422    --  For protected types, generate:
2423
2424    --     procedure _Disp_Conditional_Select
2425    --       (T : in out <Typ>;
2426    --        S : Integer;
2427    --        P : System.Address;
2428    --        C : out Ada.Tags.Prim_Op_Kind;
2429    --        F : out Boolean)
2430    --     is
2431    --        I   : Integer;
2432    --        Bnn : System.Tasking.Protected_Objects.Operations.
2433    --                Communication_Block;
2434
2435    --     begin
2436    --        C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
2437
2438    --        if C = Ada.Tags.POK_Procedure
2439    --          or else C = Ada.Tags.POK_Protected_Procedure
2440    --          or else C = Ada.Tags.POK_Task_Procedure
2441    --        then
2442    --           F := True;
2443    --           return;
2444    --        end if;
2445
2446    --        I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2447    --        System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2448    --          (T.object'Access,
2449    --           System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2450    --           P,
2451    --           System.Tasking.Conditional_Call,
2452    --           Bnn);
2453    --        F := not Cancelled (Bnn);
2454    --     end _Disp_Conditional_Select;
2455
2456    --  For task types, generate:
2457
2458    --     procedure _Disp_Conditional_Select
2459    --       (T : in out <Typ>;
2460    --        S : Integer;
2461    --        P : System.Address;
2462    --        C : out Ada.Tags.Prim_Op_Kind;
2463    --        F : out Boolean)
2464    --     is
2465    --        I : Integer;
2466
2467    --     begin
2468    --        I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2469    --        System.Tasking.Rendezvous.Task_Entry_Call
2470    --          (T._task_id,
2471    --           System.Tasking.Task_Entry_Index (I),
2472    --           P,
2473    --           System.Tasking.Conditional_Call,
2474    --           F);
2475    --     end _Disp_Conditional_Select;
2476
2477    function Make_Disp_Conditional_Select_Body
2478      (Typ : Entity_Id) return Node_Id
2479    is
2480       Loc      : constant Source_Ptr := Sloc (Typ);
2481       Blk_Nam  : Entity_Id;
2482       Conc_Typ : Entity_Id           := Empty;
2483       Decls    : constant List_Id    := New_List;
2484       Obj_Ref  : Node_Id;
2485       Stmts    : constant List_Id    := New_List;
2486       Tag_Node : Node_Id;
2487
2488    begin
2489       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2490
2491       --  Null body is generated for interface types
2492
2493       if Is_Interface (Typ) then
2494          return
2495            Make_Subprogram_Body (Loc,
2496              Specification =>
2497                Make_Disp_Conditional_Select_Spec (Typ),
2498              Declarations =>
2499                No_List,
2500              Handled_Statement_Sequence =>
2501                Make_Handled_Sequence_Of_Statements (Loc,
2502                  New_List (Make_Assignment_Statement (Loc,
2503                    Name       => Make_Identifier (Loc, Name_uF),
2504                    Expression => New_Reference_To (Standard_False, Loc)))));
2505       end if;
2506
2507       if Is_Concurrent_Record_Type (Typ) then
2508          Conc_Typ := Corresponding_Concurrent_Type (Typ);
2509
2510          --  Generate:
2511          --    I : Integer;
2512
2513          --  where I will be used to capture the entry index of the primitive
2514          --  wrapper at position S.
2515
2516          Append_To (Decls,
2517            Make_Object_Declaration (Loc,
2518              Defining_Identifier =>
2519                Make_Defining_Identifier (Loc, Name_uI),
2520              Object_Definition =>
2521                New_Reference_To (Standard_Integer, Loc)));
2522
2523          --  Generate:
2524          --    C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2525
2526          --    if C = POK_Procedure
2527          --      or else C = POK_Protected_Procedure
2528          --      or else C = POK_Task_Procedure;
2529          --    then
2530          --       F := True;
2531          --       return;
2532          --    end if;
2533
2534          Build_Common_Dispatching_Select_Statements (Typ, Stmts);
2535
2536          --  Generate:
2537          --    Bnn : Communication_Block;
2538
2539          --  where Bnn is the name of the communication block used in the
2540          --  call to Protected_Entry_Call.
2541
2542          Blk_Nam := Make_Temporary (Loc, 'B');
2543          Append_To (Decls,
2544            Make_Object_Declaration (Loc,
2545              Defining_Identifier =>
2546                Blk_Nam,
2547              Object_Definition =>
2548                New_Reference_To (RTE (RE_Communication_Block), Loc)));
2549
2550          --  Generate:
2551          --    I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2552
2553          --  I is the entry index and S is the dispatch table slot
2554
2555          if Tagged_Type_Expansion then
2556             Tag_Node :=
2557               Unchecked_Convert_To (RTE (RE_Tag),
2558                 New_Reference_To
2559                   (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2560
2561          else
2562             Tag_Node :=
2563               Make_Attribute_Reference (Loc,
2564                 Prefix => New_Reference_To (Typ, Loc),
2565                 Attribute_Name => Name_Tag);
2566          end if;
2567
2568          Append_To (Stmts,
2569            Make_Assignment_Statement (Loc,
2570              Name => Make_Identifier (Loc, Name_uI),
2571              Expression =>
2572                Make_Function_Call (Loc,
2573                  Name =>
2574                    New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
2575                  Parameter_Associations =>
2576                    New_List (
2577                      Tag_Node,
2578                      Make_Identifier (Loc, Name_uS)))));
2579
2580          if Ekind (Conc_Typ) = E_Protected_Type then
2581
2582             Obj_Ref :=                                  -- T._object'Access
2583                Make_Attribute_Reference (Loc,
2584                  Attribute_Name => Name_Unchecked_Access,
2585                  Prefix         =>
2586                    Make_Selected_Component (Loc,
2587                      Prefix        => Make_Identifier (Loc, Name_uT),
2588                      Selector_Name => Make_Identifier (Loc, Name_uObject)));
2589
2590             case Corresponding_Runtime_Package (Conc_Typ) is
2591                when System_Tasking_Protected_Objects_Entries =>
2592                   --  Generate:
2593
2594                   --    Protected_Entry_Call
2595                   --      (T._object'Access,            --  Object
2596                   --       Protected_Entry_Index! (I),  --  E
2597                   --       P,                           --  Uninterpreted_Data
2598                   --       Conditional_Call,            --  Mode
2599                   --       Bnn);                        --  Block
2600
2601                   --  where T is the protected object, I is the entry index, P
2602                   --  are the wrapped parameters and Bnn is the name of the
2603                   --  communication block.
2604
2605                   Append_To (Stmts,
2606                     Make_Procedure_Call_Statement (Loc,
2607                       Name =>
2608                         New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
2609                       Parameter_Associations =>
2610                         New_List (
2611                           Obj_Ref,
2612
2613                           Make_Unchecked_Type_Conversion (Loc,  --  entry index
2614                             Subtype_Mark =>
2615                               New_Reference_To
2616                                  (RTE (RE_Protected_Entry_Index), Loc),
2617                             Expression => Make_Identifier (Loc, Name_uI)),
2618
2619                           Make_Identifier (Loc, Name_uP),  --  parameter block
2620
2621                           New_Reference_To (               --  Conditional_Call
2622                             RTE (RE_Conditional_Call), Loc),
2623                           New_Reference_To (               --  Bnn
2624                             Blk_Nam, Loc))));
2625
2626                when System_Tasking_Protected_Objects_Single_Entry =>
2627
2628                   --    If we are compiling for a restricted run-time, the call
2629                   --    uses the simpler form.
2630
2631                   Append_To (Stmts,
2632                     Make_Procedure_Call_Statement (Loc,
2633                       Name =>
2634                         New_Reference_To
2635                           (RTE (RE_Protected_Single_Entry_Call), Loc),
2636                       Parameter_Associations =>
2637                         New_List (
2638                           Obj_Ref,
2639
2640                           Make_Attribute_Reference (Loc,
2641                             Prefix         => Make_Identifier (Loc, Name_uP),
2642                             Attribute_Name => Name_Address),
2643
2644                             New_Reference_To
2645                              (RTE (RE_Conditional_Call), Loc))));
2646                when others =>
2647                   raise Program_Error;
2648             end case;
2649
2650             --  Generate:
2651             --    F := not Cancelled (Bnn);
2652
2653             --  where F is the success flag. The status of Cancelled is negated
2654             --  in order to match the behaviour of the version for task types.
2655
2656             Append_To (Stmts,
2657               Make_Assignment_Statement (Loc,
2658                 Name       => Make_Identifier (Loc, Name_uF),
2659                 Expression =>
2660                   Make_Op_Not (Loc,
2661                     Right_Opnd =>
2662                       Make_Function_Call (Loc,
2663                         Name =>
2664                           New_Reference_To (RTE (RE_Cancelled), Loc),
2665                         Parameter_Associations =>
2666                           New_List (
2667                             New_Reference_To (Blk_Nam, Loc))))));
2668          else
2669             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2670
2671             --  Generate:
2672             --    Task_Entry_Call
2673             --      (T._task_id,             --  Acceptor
2674             --       Task_Entry_Index! (I),  --  E
2675             --       P,                      --  Uninterpreted_Data
2676             --       Conditional_Call,       --  Mode
2677             --       F);                     --  Rendezvous_Successful
2678
2679             --  where T is the task object, I is the entry index, P are the
2680             --  wrapped parameters and F is the status flag.
2681
2682             Append_To (Stmts,
2683               Make_Procedure_Call_Statement (Loc,
2684                 Name =>
2685                   New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
2686                 Parameter_Associations =>
2687                   New_List (
2688
2689                     Make_Selected_Component (Loc,         -- T._task_id
2690                       Prefix        => Make_Identifier (Loc, Name_uT),
2691                       Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2692
2693                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
2694                       Subtype_Mark =>
2695                         New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2696                       Expression   => Make_Identifier (Loc, Name_uI)),
2697
2698                     Make_Identifier (Loc, Name_uP),       --  parameter block
2699                     New_Reference_To                      --  Conditional_Call
2700                       (RTE (RE_Conditional_Call), Loc),
2701                     Make_Identifier (Loc, Name_uF))));    --  status flag
2702          end if;
2703
2704       else
2705          --  Initialize out parameters
2706
2707          Append_To (Stmts,
2708            Make_Assignment_Statement (Loc,
2709              Name       => Make_Identifier (Loc, Name_uF),
2710              Expression => New_Reference_To (Standard_False, Loc)));
2711          Append_To (Stmts,
2712            Make_Assignment_Statement (Loc,
2713              Name       => Make_Identifier (Loc, Name_uC),
2714              Expression => New_Reference_To (RTE (RE_POK_Function), Loc)));
2715       end if;
2716
2717       return
2718         Make_Subprogram_Body (Loc,
2719           Specification              =>
2720             Make_Disp_Conditional_Select_Spec (Typ),
2721           Declarations               => Decls,
2722           Handled_Statement_Sequence =>
2723             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2724    end Make_Disp_Conditional_Select_Body;
2725
2726    ---------------------------------------
2727    -- Make_Disp_Conditional_Select_Spec --
2728    ---------------------------------------
2729
2730    function Make_Disp_Conditional_Select_Spec
2731      (Typ : Entity_Id) return Node_Id
2732    is
2733       Loc    : constant Source_Ptr := Sloc (Typ);
2734       Def_Id : constant Node_Id    :=
2735                  Make_Defining_Identifier (Loc,
2736                    Name_uDisp_Conditional_Select);
2737       Params : constant List_Id    := New_List;
2738
2739    begin
2740       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2741
2742       --  T : in out Typ;        --  Object parameter
2743       --  S : Integer;           --  Primitive operation slot
2744       --  P : Address;           --  Wrapped parameters
2745       --  C : out Prim_Op_Kind;  --  Call kind
2746       --  F : out Boolean;       --  Status flag
2747
2748       Append_List_To (Params, New_List (
2749
2750         Make_Parameter_Specification (Loc,
2751           Defining_Identifier =>
2752             Make_Defining_Identifier (Loc, Name_uT),
2753           Parameter_Type =>
2754             New_Reference_To (Typ, Loc),
2755           In_Present  => True,
2756           Out_Present => True),
2757
2758         Make_Parameter_Specification (Loc,
2759           Defining_Identifier =>
2760             Make_Defining_Identifier (Loc, Name_uS),
2761           Parameter_Type =>
2762             New_Reference_To (Standard_Integer, Loc)),
2763
2764         Make_Parameter_Specification (Loc,
2765           Defining_Identifier =>
2766             Make_Defining_Identifier (Loc, Name_uP),
2767           Parameter_Type =>
2768             New_Reference_To (RTE (RE_Address), Loc)),
2769
2770         Make_Parameter_Specification (Loc,
2771           Defining_Identifier =>
2772             Make_Defining_Identifier (Loc, Name_uC),
2773           Parameter_Type =>
2774             New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
2775           Out_Present => True),
2776
2777         Make_Parameter_Specification (Loc,
2778           Defining_Identifier =>
2779             Make_Defining_Identifier (Loc, Name_uF),
2780           Parameter_Type =>
2781             New_Reference_To (Standard_Boolean, Loc),
2782           Out_Present => True)));
2783
2784       return
2785         Make_Procedure_Specification (Loc,
2786           Defining_Unit_Name       => Def_Id,
2787           Parameter_Specifications => Params);
2788    end Make_Disp_Conditional_Select_Spec;
2789
2790    -------------------------------------
2791    -- Make_Disp_Get_Prim_Op_Kind_Body --
2792    -------------------------------------
2793
2794    function Make_Disp_Get_Prim_Op_Kind_Body
2795      (Typ : Entity_Id) return Node_Id
2796    is
2797       Loc      : constant Source_Ptr := Sloc (Typ);
2798       Tag_Node : Node_Id;
2799
2800    begin
2801       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2802
2803       if Is_Interface (Typ) then
2804          return
2805            Make_Subprogram_Body (Loc,
2806              Specification =>
2807                Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2808              Declarations =>
2809                New_List,
2810              Handled_Statement_Sequence =>
2811                Make_Handled_Sequence_Of_Statements (Loc,
2812                  New_List (Make_Null_Statement (Loc))));
2813       end if;
2814
2815       --  Generate:
2816       --    C := get_prim_op_kind (tag! (<type>VP), S);
2817
2818       --  where C is the out parameter capturing the call kind and S is the
2819       --  dispatch table slot number.
2820
2821       if Tagged_Type_Expansion then
2822          Tag_Node :=
2823            Unchecked_Convert_To (RTE (RE_Tag),
2824              New_Reference_To
2825               (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2826
2827       else
2828          Tag_Node :=
2829            Make_Attribute_Reference (Loc,
2830              Prefix => New_Reference_To (Typ, Loc),
2831              Attribute_Name => Name_Tag);
2832       end if;
2833
2834       return
2835         Make_Subprogram_Body (Loc,
2836           Specification =>
2837             Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2838           Declarations =>
2839             New_List,
2840           Handled_Statement_Sequence =>
2841             Make_Handled_Sequence_Of_Statements (Loc,
2842               New_List (
2843                 Make_Assignment_Statement (Loc,
2844                   Name =>
2845                     Make_Identifier (Loc, Name_uC),
2846                   Expression =>
2847                     Make_Function_Call (Loc,
2848                       Name =>
2849                         New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc),
2850                       Parameter_Associations => New_List (
2851                         Tag_Node,
2852                         Make_Identifier (Loc, Name_uS)))))));
2853    end Make_Disp_Get_Prim_Op_Kind_Body;
2854
2855    -------------------------------------
2856    -- Make_Disp_Get_Prim_Op_Kind_Spec --
2857    -------------------------------------
2858
2859    function Make_Disp_Get_Prim_Op_Kind_Spec
2860      (Typ : Entity_Id) return Node_Id
2861    is
2862       Loc    : constant Source_Ptr := Sloc (Typ);
2863       Def_Id : constant Node_Id    :=
2864                  Make_Defining_Identifier (Loc,
2865                    Name_uDisp_Get_Prim_Op_Kind);
2866       Params : constant List_Id    := New_List;
2867
2868    begin
2869       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2870
2871       --  T : in out Typ;       --  Object parameter
2872       --  S : Integer;          --  Primitive operation slot
2873       --  C : out Prim_Op_Kind; --  Call kind
2874
2875       Append_List_To (Params, New_List (
2876
2877         Make_Parameter_Specification (Loc,
2878           Defining_Identifier =>
2879             Make_Defining_Identifier (Loc, Name_uT),
2880           Parameter_Type =>
2881             New_Reference_To (Typ, Loc),
2882           In_Present  => True,
2883           Out_Present => True),
2884
2885         Make_Parameter_Specification (Loc,
2886           Defining_Identifier =>
2887             Make_Defining_Identifier (Loc, Name_uS),
2888           Parameter_Type =>
2889             New_Reference_To (Standard_Integer, Loc)),
2890
2891         Make_Parameter_Specification (Loc,
2892           Defining_Identifier =>
2893             Make_Defining_Identifier (Loc, Name_uC),
2894           Parameter_Type =>
2895             New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
2896           Out_Present => True)));
2897
2898       return
2899         Make_Procedure_Specification (Loc,
2900            Defining_Unit_Name       => Def_Id,
2901            Parameter_Specifications => Params);
2902    end Make_Disp_Get_Prim_Op_Kind_Spec;
2903
2904    --------------------------------
2905    -- Make_Disp_Get_Task_Id_Body --
2906    --------------------------------
2907
2908    function Make_Disp_Get_Task_Id_Body
2909      (Typ : Entity_Id) return Node_Id
2910    is
2911       Loc : constant Source_Ptr := Sloc (Typ);
2912       Ret : Node_Id;
2913
2914    begin
2915       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2916
2917       if Is_Concurrent_Record_Type (Typ)
2918         and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
2919       then
2920          --  Generate:
2921          --    return To_Address (_T._task_id);
2922
2923          Ret :=
2924            Make_Simple_Return_Statement (Loc,
2925              Expression =>
2926                Make_Unchecked_Type_Conversion (Loc,
2927                  Subtype_Mark =>
2928                    New_Reference_To (RTE (RE_Address), Loc),
2929                  Expression =>
2930                    Make_Selected_Component (Loc,
2931                      Prefix        => Make_Identifier (Loc, Name_uT),
2932                      Selector_Name => Make_Identifier (Loc, Name_uTask_Id))));
2933
2934       --  A null body is constructed for non-task types
2935
2936       else
2937          --  Generate:
2938          --    return Null_Address;
2939
2940          Ret :=
2941            Make_Simple_Return_Statement (Loc,
2942              Expression =>
2943                New_Reference_To (RTE (RE_Null_Address), Loc));
2944       end if;
2945
2946       return
2947         Make_Subprogram_Body (Loc,
2948           Specification =>
2949             Make_Disp_Get_Task_Id_Spec (Typ),
2950           Declarations =>
2951             New_List,
2952           Handled_Statement_Sequence =>
2953             Make_Handled_Sequence_Of_Statements (Loc,
2954               New_List (Ret)));
2955    end Make_Disp_Get_Task_Id_Body;
2956
2957    --------------------------------
2958    -- Make_Disp_Get_Task_Id_Spec --
2959    --------------------------------
2960
2961    function Make_Disp_Get_Task_Id_Spec
2962      (Typ : Entity_Id) return Node_Id
2963    is
2964       Loc : constant Source_Ptr := Sloc (Typ);
2965
2966    begin
2967       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2968
2969       return
2970         Make_Function_Specification (Loc,
2971           Defining_Unit_Name =>
2972             Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
2973           Parameter_Specifications => New_List (
2974             Make_Parameter_Specification (Loc,
2975               Defining_Identifier =>
2976                 Make_Defining_Identifier (Loc, Name_uT),
2977               Parameter_Type =>
2978                 New_Reference_To (Typ, Loc))),
2979           Result_Definition =>
2980             New_Reference_To (RTE (RE_Address), Loc));
2981    end Make_Disp_Get_Task_Id_Spec;
2982
2983    ----------------------------
2984    -- Make_Disp_Requeue_Body --
2985    ----------------------------
2986
2987    function Make_Disp_Requeue_Body
2988      (Typ : Entity_Id) return Node_Id
2989    is
2990       Loc      : constant Source_Ptr := Sloc (Typ);
2991       Conc_Typ : Entity_Id           := Empty;
2992       Stmts    : constant List_Id    := New_List;
2993
2994    begin
2995       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2996
2997       --  Null body is generated for interface types and non-concurrent
2998       --  tagged types.
2999
3000       if Is_Interface (Typ)
3001         or else not Is_Concurrent_Record_Type (Typ)
3002       then
3003          return
3004            Make_Subprogram_Body (Loc,
3005              Specification =>
3006                Make_Disp_Requeue_Spec (Typ),
3007              Declarations =>
3008                No_List,
3009              Handled_Statement_Sequence =>
3010                Make_Handled_Sequence_Of_Statements (Loc,
3011                  New_List (Make_Null_Statement (Loc))));
3012       end if;
3013
3014       Conc_Typ := Corresponding_Concurrent_Type (Typ);
3015
3016       if Ekind (Conc_Typ) = E_Protected_Type then
3017
3018          --  Generate statements:
3019          --    if F then
3020          --       System.Tasking.Protected_Objects.Operations.
3021          --         Requeue_Protected_Entry
3022          --           (Protection_Entries_Access (P),
3023          --            O._object'Unchecked_Access,
3024          --            Protected_Entry_Index (I),
3025          --            A);
3026          --    else
3027          --       System.Tasking.Protected_Objects.Operations.
3028          --         Requeue_Task_To_Protected_Entry
3029          --           (O._object'Unchecked_Access,
3030          --            Protected_Entry_Index (I),
3031          --            A);
3032          --    end if;
3033
3034          if Restriction_Active (No_Entry_Queue) then
3035             Append_To (Stmts, Make_Null_Statement (Loc));
3036          else
3037             Append_To (Stmts,
3038               Make_If_Statement (Loc,
3039                 Condition       => Make_Identifier (Loc, Name_uF),
3040
3041                 Then_Statements =>
3042                   New_List (
3043
3044                      --  Call to Requeue_Protected_Entry
3045
3046                     Make_Procedure_Call_Statement (Loc,
3047                       Name =>
3048                         New_Reference_To (
3049                           RTE (RE_Requeue_Protected_Entry), Loc),
3050                       Parameter_Associations =>
3051                         New_List (
3052
3053                           Make_Unchecked_Type_Conversion (Loc,  -- PEA (P)
3054                             Subtype_Mark =>
3055                               New_Reference_To (
3056                                 RTE (RE_Protection_Entries_Access), Loc),
3057                             Expression =>
3058                               Make_Identifier (Loc, Name_uP)),
3059
3060                           Make_Attribute_Reference (Loc,      -- O._object'Acc
3061                             Attribute_Name =>
3062                               Name_Unchecked_Access,
3063                             Prefix =>
3064                               Make_Selected_Component (Loc,
3065                                 Prefix        =>
3066                                   Make_Identifier (Loc, Name_uO),
3067                                 Selector_Name =>
3068                                   Make_Identifier (Loc, Name_uObject))),
3069
3070                           Make_Unchecked_Type_Conversion (Loc,  -- entry index
3071                             Subtype_Mark =>
3072                               New_Reference_To (
3073                                 RTE (RE_Protected_Entry_Index), Loc),
3074                             Expression => Make_Identifier (Loc, Name_uI)),
3075
3076                           Make_Identifier (Loc, Name_uA)))),   -- abort status
3077
3078                 Else_Statements =>
3079                   New_List (
3080
3081                      --  Call to Requeue_Task_To_Protected_Entry
3082
3083                     Make_Procedure_Call_Statement (Loc,
3084                       Name =>
3085                         New_Reference_To (
3086                           RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
3087                       Parameter_Associations =>
3088                         New_List (
3089
3090                           Make_Attribute_Reference (Loc,     -- O._object'Acc
3091                             Attribute_Name =>
3092                               Name_Unchecked_Access,
3093                             Prefix =>
3094                               Make_Selected_Component (Loc,
3095                                 Prefix =>
3096                                   Make_Identifier (Loc, Name_uO),
3097                                 Selector_Name =>
3098                                   Make_Identifier (Loc, Name_uObject))),
3099
3100                           Make_Unchecked_Type_Conversion (Loc, -- entry index
3101                             Subtype_Mark =>
3102                               New_Reference_To (
3103                                 RTE (RE_Protected_Entry_Index), Loc),
3104                             Expression =>
3105                               Make_Identifier (Loc, Name_uI)),
3106
3107                           Make_Identifier (Loc, Name_uA)))))); -- abort status
3108          end if;
3109       else
3110          pragma Assert (Is_Task_Type (Conc_Typ));
3111
3112          --  Generate:
3113          --    if F then
3114          --       System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
3115          --         (Protection_Entries_Access (P),
3116          --          O._task_id,
3117          --          Task_Entry_Index (I),
3118          --          A);
3119          --    else
3120          --       System.Tasking.Rendezvous.Requeue_Task_Entry
3121          --         (O._task_id,
3122          --          Task_Entry_Index (I),
3123          --          A);
3124          --    end if;
3125
3126          Append_To (Stmts,
3127            Make_If_Statement (Loc,
3128              Condition       => Make_Identifier (Loc, Name_uF),
3129
3130              Then_Statements => New_List (
3131
3132                --  Call to Requeue_Protected_To_Task_Entry
3133
3134                Make_Procedure_Call_Statement (Loc,
3135                  Name =>
3136                    New_Reference_To
3137                      (RTE (RE_Requeue_Protected_To_Task_Entry), Loc),
3138
3139                  Parameter_Associations => New_List (
3140
3141                    Make_Unchecked_Type_Conversion (Loc,  -- PEA (P)
3142                      Subtype_Mark =>
3143                        New_Reference_To
3144                          (RTE (RE_Protection_Entries_Access), Loc),
3145                           Expression => Make_Identifier (Loc, Name_uP)),
3146
3147                    Make_Selected_Component (Loc,         -- O._task_id
3148                      Prefix        => Make_Identifier (Loc, Name_uO),
3149                      Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3150
3151                    Make_Unchecked_Type_Conversion (Loc,  -- entry index
3152                      Subtype_Mark =>
3153                        New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
3154                      Expression   => Make_Identifier (Loc, Name_uI)),
3155
3156                    Make_Identifier (Loc, Name_uA)))),    -- abort status
3157
3158              Else_Statements => New_List (
3159
3160                --  Call to Requeue_Task_Entry
3161
3162                Make_Procedure_Call_Statement (Loc,
3163                  Name => New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc),
3164
3165                  Parameter_Associations => New_List (
3166
3167                    Make_Selected_Component (Loc,         -- O._task_id
3168                      Prefix        => Make_Identifier (Loc, Name_uO),
3169                      Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3170
3171                    Make_Unchecked_Type_Conversion (Loc,  -- entry index
3172                      Subtype_Mark =>
3173                        New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
3174                      Expression   => Make_Identifier (Loc, Name_uI)),
3175
3176                    Make_Identifier (Loc, Name_uA))))));  -- abort status
3177       end if;
3178
3179       --  Even though no declarations are needed in both cases, we allocate
3180       --  a list for entities added by Freeze.
3181
3182       return
3183         Make_Subprogram_Body (Loc,
3184           Specification =>
3185             Make_Disp_Requeue_Spec (Typ),
3186           Declarations =>
3187             New_List,
3188           Handled_Statement_Sequence =>
3189             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3190    end Make_Disp_Requeue_Body;
3191
3192    ----------------------------
3193    -- Make_Disp_Requeue_Spec --
3194    ----------------------------
3195
3196    function Make_Disp_Requeue_Spec
3197      (Typ : Entity_Id) return Node_Id
3198    is
3199       Loc : constant Source_Ptr := Sloc (Typ);
3200
3201    begin
3202       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3203
3204       --  O : in out Typ;   -  Object parameter
3205       --  F : Boolean;      -  Protected (True) / task (False) flag
3206       --  P : Address;      -  Protection_Entries_Access value
3207       --  I : Entry_Index   -  Index of entry call
3208       --  A : Boolean       -  Abort flag
3209
3210       --  Note that the Protection_Entries_Access value is represented as a
3211       --  System.Address in order to avoid dragging in the tasking runtime
3212       --  when compiling sources without tasking constructs.
3213
3214       return
3215         Make_Procedure_Specification (Loc,
3216           Defining_Unit_Name =>
3217             Make_Defining_Identifier (Loc, Name_uDisp_Requeue),
3218
3219           Parameter_Specifications =>
3220             New_List (
3221
3222               Make_Parameter_Specification (Loc,             --  O
3223                 Defining_Identifier =>
3224                   Make_Defining_Identifier (Loc, Name_uO),
3225                 Parameter_Type =>
3226                   New_Reference_To (Typ, Loc),
3227                 In_Present  => True,
3228                 Out_Present => True),
3229
3230               Make_Parameter_Specification (Loc,             --  F
3231                 Defining_Identifier =>
3232                   Make_Defining_Identifier (Loc, Name_uF),
3233                 Parameter_Type =>
3234                   New_Reference_To (Standard_Boolean, Loc)),
3235
3236               Make_Parameter_Specification (Loc,             --  P
3237                 Defining_Identifier =>
3238                   Make_Defining_Identifier (Loc, Name_uP),
3239                 Parameter_Type =>
3240                   New_Reference_To (RTE (RE_Address), Loc)),
3241
3242               Make_Parameter_Specification (Loc,             --  I
3243                 Defining_Identifier =>
3244                   Make_Defining_Identifier (Loc, Name_uI),
3245                 Parameter_Type =>
3246                   New_Reference_To (Standard_Integer, Loc)),
3247
3248               Make_Parameter_Specification (Loc,             --  A
3249                 Defining_Identifier =>
3250                   Make_Defining_Identifier (Loc, Name_uA),
3251                 Parameter_Type =>
3252                   New_Reference_To (Standard_Boolean, Loc))));
3253    end Make_Disp_Requeue_Spec;
3254
3255    ---------------------------------
3256    -- Make_Disp_Timed_Select_Body --
3257    ---------------------------------
3258
3259    --  For interface types, generate:
3260
3261    --     procedure _Disp_Timed_Select
3262    --       (T : in out <Typ>;
3263    --        S : Integer;
3264    --        P : System.Address;
3265    --        D : Duration;
3266    --        M : Integer;
3267    --        C : out Ada.Tags.Prim_Op_Kind;
3268    --        F : out Boolean)
3269    --     is
3270    --     begin
3271    --        F := False;
3272    --        C := Ada.Tags.POK_Function;
3273    --     end _Disp_Timed_Select;
3274
3275    --  For protected types, generate:
3276
3277    --     procedure _Disp_Timed_Select
3278    --       (T : in out <Typ>;
3279    --        S : Integer;
3280    --        P : System.Address;
3281    --        D : Duration;
3282    --        M : Integer;
3283    --        C : out Ada.Tags.Prim_Op_Kind;
3284    --        F : out Boolean)
3285    --     is
3286    --        I : Integer;
3287
3288    --     begin
3289    --        C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
3290
3291    --        if C = Ada.Tags.POK_Procedure
3292    --          or else C = Ada.Tags.POK_Protected_Procedure
3293    --          or else C = Ada.Tags.POK_Task_Procedure
3294    --        then
3295    --           F := True;
3296    --           return;
3297    --        end if;
3298
3299    --        I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3300    --        System.Tasking.Protected_Objects.Operations.
3301    --          Timed_Protected_Entry_Call
3302    --            (T._object'Access,
3303    --             System.Tasking.Protected_Objects.Protected_Entry_Index (I),
3304    --             P,
3305    --             D,
3306    --             M,
3307    --             F);
3308    --     end _Disp_Timed_Select;
3309
3310    --  For task types, generate:
3311
3312    --     procedure _Disp_Timed_Select
3313    --       (T : in out <Typ>;
3314    --        S : Integer;
3315    --        P : System.Address;
3316    --        D : Duration;
3317    --        M : Integer;
3318    --        C : out Ada.Tags.Prim_Op_Kind;
3319    --        F : out Boolean)
3320    --     is
3321    --        I : Integer;
3322
3323    --     begin
3324    --        I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3325    --        System.Tasking.Rendezvous.Timed_Task_Entry_Call
3326    --          (T._task_id,
3327    --           System.Tasking.Task_Entry_Index (I),
3328    --           P,
3329    --           D,
3330    --           M,
3331    --           F);
3332    --     end _Disp_Time_Select;
3333
3334    function Make_Disp_Timed_Select_Body
3335      (Typ : Entity_Id) return Node_Id
3336    is
3337       Loc      : constant Source_Ptr := Sloc (Typ);
3338       Conc_Typ : Entity_Id           := Empty;
3339       Decls    : constant List_Id    := New_List;
3340       Obj_Ref  : Node_Id;
3341       Stmts    : constant List_Id    := New_List;
3342       Tag_Node : Node_Id;
3343
3344    begin
3345       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3346
3347       --  Null body is generated for interface types
3348
3349       if Is_Interface (Typ) then
3350          return
3351            Make_Subprogram_Body (Loc,
3352              Specification =>
3353                Make_Disp_Timed_Select_Spec (Typ),
3354              Declarations =>
3355                New_List,
3356              Handled_Statement_Sequence =>
3357                Make_Handled_Sequence_Of_Statements (Loc,
3358                  New_List (
3359                    Make_Assignment_Statement (Loc,
3360                      Name       => Make_Identifier (Loc, Name_uF),
3361                      Expression => New_Reference_To (Standard_False, Loc)))));
3362       end if;
3363
3364       if Is_Concurrent_Record_Type (Typ) then
3365          Conc_Typ := Corresponding_Concurrent_Type (Typ);
3366
3367          --  Generate:
3368          --    I : Integer;
3369
3370          --  where I will be used to capture the entry index of the primitive
3371          --  wrapper at position S.
3372
3373          Append_To (Decls,
3374            Make_Object_Declaration (Loc,
3375              Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
3376              Object_Definition   => New_Reference_To (Standard_Integer, Loc)));
3377
3378          --  Generate:
3379          --    C := Get_Prim_Op_Kind (tag! (<type>VP), S);
3380
3381          --    if C = POK_Procedure
3382          --      or else C = POK_Protected_Procedure
3383          --      or else C = POK_Task_Procedure;
3384          --    then
3385          --       F := True;
3386          --       return;
3387          --    end if;
3388
3389          Build_Common_Dispatching_Select_Statements (Typ, Stmts);
3390
3391          --  Generate:
3392          --    I := Get_Entry_Index (tag! (<type>VP), S);
3393
3394          --  I is the entry index and S is the dispatch table slot
3395
3396          if Tagged_Type_Expansion then
3397             Tag_Node :=
3398               Unchecked_Convert_To (RTE (RE_Tag),
3399                 New_Reference_To
3400                   (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
3401
3402          else
3403             Tag_Node :=
3404               Make_Attribute_Reference (Loc,
3405                 Prefix         => New_Reference_To (Typ, Loc),
3406                 Attribute_Name => Name_Tag);
3407          end if;
3408
3409          Append_To (Stmts,
3410            Make_Assignment_Statement (Loc,
3411              Name       => Make_Identifier (Loc, Name_uI),
3412              Expression =>
3413                Make_Function_Call (Loc,
3414                  Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
3415                  Parameter_Associations =>
3416                    New_List (
3417                      Tag_Node,
3418                      Make_Identifier (Loc, Name_uS)))));
3419
3420          --  Protected case
3421
3422          if Ekind (Conc_Typ) = E_Protected_Type then
3423
3424             --  Build T._object'Access
3425
3426             Obj_Ref :=
3427                Make_Attribute_Reference (Loc,
3428                   Attribute_Name => Name_Unchecked_Access,
3429                   Prefix         =>
3430                     Make_Selected_Component (Loc,
3431                       Prefix        => Make_Identifier (Loc, Name_uT),
3432                       Selector_Name => Make_Identifier (Loc, Name_uObject)));
3433
3434             --  Normal case, No_Entry_Queue restriction not active. In this
3435             --  case we generate:
3436
3437             --   Timed_Protected_Entry_Call
3438             --     (T._object'access,
3439             --      Protected_Entry_Index! (I),
3440             --      P, D, M, F);
3441
3442             --  where T is the protected object, I is the entry index, P are
3443             --  the wrapped parameters, D is the delay amount, M is the delay
3444             --  mode and F is the status flag.
3445
3446             case Corresponding_Runtime_Package (Conc_Typ) is
3447                when System_Tasking_Protected_Objects_Entries =>
3448                   Append_To (Stmts,
3449                     Make_Procedure_Call_Statement (Loc,
3450                       Name =>
3451                         New_Reference_To
3452                           (RTE (RE_Timed_Protected_Entry_Call), Loc),
3453                       Parameter_Associations =>
3454                         New_List (
3455                           Obj_Ref,
3456
3457                           Make_Unchecked_Type_Conversion (Loc,  --  entry index
3458                             Subtype_Mark =>
3459                               New_Reference_To
3460                                 (RTE (RE_Protected_Entry_Index), Loc),
3461                             Expression =>
3462                               Make_Identifier (Loc, Name_uI)),
3463
3464                           Make_Identifier (Loc, Name_uP),   --  parameter block
3465                           Make_Identifier (Loc, Name_uD),   --  delay
3466                           Make_Identifier (Loc, Name_uM),   --  delay mode
3467                           Make_Identifier (Loc, Name_uF)))); --  status flag
3468
3469                when System_Tasking_Protected_Objects_Single_Entry =>
3470                   --  Generate:
3471
3472                   --   Timed_Protected_Single_Entry_Call
3473                   --     (T._object'access, P, D, M, F);
3474
3475                   --  where T is the protected object, P is the wrapped
3476                   --  parameters, D is the delay amount, M is the delay mode, F
3477                   --  is the status flag.
3478
3479                   Append_To (Stmts,
3480                     Make_Procedure_Call_Statement (Loc,
3481                       Name =>
3482                         New_Reference_To
3483                           (RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
3484                       Parameter_Associations =>
3485                         New_List (
3486                           Obj_Ref,
3487                           Make_Identifier (Loc, Name_uP),   --  parameter block
3488                           Make_Identifier (Loc, Name_uD),   --  delay
3489                           Make_Identifier (Loc, Name_uM),   --  delay mode
3490                           Make_Identifier (Loc, Name_uF)))); --  status flag
3491
3492                when others =>
3493                   raise Program_Error;
3494             end case;
3495
3496          --  Task case
3497
3498          else
3499             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
3500
3501             --  Generate:
3502             --    Timed_Task_Entry_Call (
3503             --      T._task_id,
3504             --      Task_Entry_Index! (I),
3505             --      P,
3506             --      D,
3507             --      M,
3508             --      F);
3509
3510             --  where T is the task object, I is the entry index, P are the
3511             --  wrapped parameters, D is the delay amount, M is the delay
3512             --  mode and F is the status flag.
3513
3514             Append_To (Stmts,
3515               Make_Procedure_Call_Statement (Loc,
3516                 Name =>
3517                   New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
3518                 Parameter_Associations =>
3519                   New_List (
3520
3521                     Make_Selected_Component (Loc,         --  T._task_id
3522                       Prefix        => Make_Identifier (Loc, Name_uT),
3523                       Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3524
3525                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
3526                       Subtype_Mark =>
3527                         New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
3528                       Expression   => Make_Identifier (Loc, Name_uI)),
3529
3530                     Make_Identifier (Loc, Name_uP),       --  parameter block
3531                     Make_Identifier (Loc, Name_uD),       --  delay
3532                     Make_Identifier (Loc, Name_uM),       --  delay mode
3533                     Make_Identifier (Loc, Name_uF))));    --  status flag
3534          end if;
3535
3536       else
3537          --  Initialize out parameters
3538
3539          Append_To (Stmts,
3540            Make_Assignment_Statement (Loc,
3541              Name       => Make_Identifier (Loc, Name_uF),
3542              Expression => New_Reference_To (Standard_False, Loc)));
3543          Append_To (Stmts,
3544            Make_Assignment_Statement (Loc,
3545              Name       => Make_Identifier (Loc, Name_uC),
3546              Expression => New_Reference_To (RTE (RE_POK_Function), Loc)));
3547       end if;
3548
3549       return
3550         Make_Subprogram_Body (Loc,
3551           Specification              => Make_Disp_Timed_Select_Spec (Typ),
3552           Declarations               => Decls,
3553           Handled_Statement_Sequence =>
3554             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3555    end Make_Disp_Timed_Select_Body;
3556
3557    ---------------------------------
3558    -- Make_Disp_Timed_Select_Spec --
3559    ---------------------------------
3560
3561    function Make_Disp_Timed_Select_Spec
3562      (Typ : Entity_Id) return Node_Id
3563    is
3564       Loc    : constant Source_Ptr := Sloc (Typ);
3565       Def_Id : constant Node_Id    :=
3566                  Make_Defining_Identifier (Loc,
3567                    Name_uDisp_Timed_Select);
3568       Params : constant List_Id    := New_List;
3569
3570    begin
3571       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3572
3573       --  T : in out Typ;        --  Object parameter
3574       --  S : Integer;           --  Primitive operation slot
3575       --  P : Address;           --  Wrapped parameters
3576       --  D : Duration;          --  Delay
3577       --  M : Integer;           --  Delay Mode
3578       --  C : out Prim_Op_Kind;  --  Call kind
3579       --  F : out Boolean;       --  Status flag
3580
3581       Append_List_To (Params, New_List (
3582
3583         Make_Parameter_Specification (Loc,
3584           Defining_Identifier =>
3585             Make_Defining_Identifier (Loc, Name_uT),
3586           Parameter_Type =>
3587             New_Reference_To (Typ, Loc),
3588           In_Present  => True,
3589           Out_Present => True),
3590
3591         Make_Parameter_Specification (Loc,
3592           Defining_Identifier =>
3593             Make_Defining_Identifier (Loc, Name_uS),
3594           Parameter_Type =>
3595             New_Reference_To (Standard_Integer, Loc)),
3596
3597         Make_Parameter_Specification (Loc,
3598           Defining_Identifier =>
3599             Make_Defining_Identifier (Loc, Name_uP),
3600           Parameter_Type =>
3601             New_Reference_To (RTE (RE_Address), Loc)),
3602
3603         Make_Parameter_Specification (Loc,
3604           Defining_Identifier =>
3605             Make_Defining_Identifier (Loc, Name_uD),
3606           Parameter_Type =>
3607             New_Reference_To (Standard_Duration, Loc)),
3608
3609         Make_Parameter_Specification (Loc,
3610           Defining_Identifier =>
3611             Make_Defining_Identifier (Loc, Name_uM),
3612           Parameter_Type =>
3613             New_Reference_To (Standard_Integer, Loc)),
3614
3615         Make_Parameter_Specification (Loc,
3616           Defining_Identifier =>
3617             Make_Defining_Identifier (Loc, Name_uC),
3618           Parameter_Type =>
3619             New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
3620           Out_Present => True)));
3621
3622       Append_To (Params,
3623         Make_Parameter_Specification (Loc,
3624           Defining_Identifier =>
3625             Make_Defining_Identifier (Loc, Name_uF),
3626           Parameter_Type =>
3627             New_Reference_To (Standard_Boolean, Loc),
3628           Out_Present => True));
3629
3630       return
3631         Make_Procedure_Specification (Loc,
3632           Defining_Unit_Name       => Def_Id,
3633           Parameter_Specifications => Params);
3634    end Make_Disp_Timed_Select_Spec;
3635
3636    -------------
3637    -- Make_DT --
3638    -------------
3639
3640    --  The frontend supports two models for expanding dispatch tables
3641    --  associated with library-level defined tagged types: statically
3642    --  and non-statically allocated dispatch tables. In the former case
3643    --  the object containing the dispatch table is constant and it is
3644    --  initialized by means of a positional aggregate. In the latter case,
3645    --  the object containing the dispatch table is a variable which is
3646    --  initialized by means of assignments.
3647
3648    --  In case of locally defined tagged types, the object containing the
3649    --  object containing the dispatch table is always a variable (instead
3650    --  of a constant). This is currently required to give support to late
3651    --  overriding of primitives. For example:
3652
3653    --     procedure Example is
3654    --        package Pkg is
3655    --           type T1 is tagged null record;
3656    --           procedure Prim (O : T1);
3657    --        end Pkg;
3658
3659    --        type T2 is new Pkg.T1 with null record;
3660    --        procedure Prim (X : T2) is    -- late overriding
3661    --        begin
3662    --           ...
3663    --     ...
3664    --     end;
3665
3666    function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
3667       Loc : constant Source_Ptr := Sloc (Typ);
3668
3669       Max_Predef_Prims : constant Int :=
3670                            UI_To_Int
3671                              (Intval
3672                                (Expression
3673                                  (Parent (RTE (RE_Max_Predef_Prims)))));
3674
3675       DT_Decl : constant Elist_Id := New_Elmt_List;
3676       DT_Aggr : constant Elist_Id := New_Elmt_List;
3677       --  Entities marked with attribute Is_Dispatch_Table_Entity
3678
3679       procedure Check_Premature_Freezing
3680         (Subp        : Entity_Id;
3681          Tagged_Type : Entity_Id;
3682          Typ         : Entity_Id);
3683       --  Verify that all non-tagged types in the profile of a subprogram
3684       --  are frozen at the point the subprogram is frozen. This enforces
3685       --  the rule on RM 13.14 (14) as modified by AI05-019. At the point a
3686       --  subprogram is frozen, enough must be known about it to build the
3687       --  activation record for it, which requires at least that the size of
3688       --  all parameters be known. Controlling arguments are by-reference,
3689       --  and therefore the rule only applies to non-tagged types.
3690       --  Typical violation of the rule involves an object declaration that
3691       --  freezes a tagged type, when one of its primitive operations has a
3692       --  type in its profile whose full view has not been analyzed yet.
3693       --  More complex cases involve composite types that have one private
3694       --  unfrozen subcomponent.
3695
3696       procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
3697       --  Export the dispatch table DT of tagged type Typ. Required to generate
3698       --  forward references and statically allocate the table. For primary
3699       --  dispatch tables Index is 0; for secondary dispatch tables the value
3700       --  of index must match the Suffix_Index value assigned to the table by
3701       --  Make_Tags when generating its unique external name, and it is used to
3702       --  retrieve from the Dispatch_Table_Wrappers list associated with Typ
3703       --  the external name generated by Import_DT.
3704
3705       procedure Make_Secondary_DT
3706         (Typ              : Entity_Id;
3707          Iface            : Entity_Id;
3708          Suffix_Index     : Int;
3709          Num_Iface_Prims  : Nat;
3710          Iface_DT_Ptr     : Entity_Id;
3711          Predef_Prims_Ptr : Entity_Id;
3712          Build_Thunks     : Boolean;