OSDN Git Service

* exp_disp.adb (Expand_Dispatching_Call): Propagate the convention on
[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       Set_Convention     (Subp_Typ, Convention (Subp));
807
808       --  Notify gigi that the designated type is a dispatching primitive
809
810       Set_Is_Dispatch_Table_Entity (Subp_Typ);
811
812       --  Create a new list of parameters which is a copy of the old formal
813       --  list including the creation of a new set of matching entities.
814
815       declare
816          Old_Formal : Entity_Id := First_Formal (Subp);
817          New_Formal : Entity_Id;
818          Extra      : Entity_Id := Empty;
819
820       begin
821          if Present (Old_Formal) then
822             New_Formal := New_Copy (Old_Formal);
823             Set_First_Entity (Subp_Typ, New_Formal);
824             Param := First_Actual (Call_Node);
825
826             loop
827                Set_Scope (New_Formal, Subp_Typ);
828
829                --  Change all the controlling argument types to be class-wide
830                --  to avoid a recursion in dispatching.
831
832                if Is_Controlling_Formal (New_Formal) then
833                   Set_Etype (New_Formal, Etype (Param));
834                end if;
835
836                --  If the type of the formal is an itype, there was code here
837                --  introduced in 1998 in revision 1.46, to create a new itype
838                --  by copy. This seems useless, and in fact leads to semantic
839                --  errors when the itype is the completion of a type derived
840                --  from a private type.
841
842                Extra := New_Formal;
843                Next_Formal (Old_Formal);
844                exit when No (Old_Formal);
845
846                Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
847                Next_Entity (New_Formal);
848                Next_Actual (Param);
849             end loop;
850
851             Set_Next_Entity (New_Formal, Empty);
852             Set_Last_Entity (Subp_Typ, Extra);
853          end if;
854
855          --  Now that the explicit formals have been duplicated, any extra
856          --  formals needed by the subprogram must be created.
857
858          if Present (Extra) then
859             Set_Extra_Formal (Extra, Empty);
860          end if;
861
862          Create_Extra_Formals (Subp_Typ);
863       end;
864
865       --  Complete description of pointer type, including size information, as
866       --  must be done with itypes to prevent order-of-elaboration anomalies
867       --  in gigi.
868
869       Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
870       Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
871       Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ));
872       Layout_Type    (Subp_Ptr_Typ);
873
874       --  If the controlling argument is a value of type Ada.Tag or an abstract
875       --  interface class-wide type then use it directly. Otherwise, the tag
876       --  must be extracted from the controlling object.
877
878       if Ctrl_Typ = RTE (RE_Tag)
879         or else (RTE_Available (RE_Interface_Tag)
880                   and then Ctrl_Typ = RTE (RE_Interface_Tag))
881       then
882          Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
883
884       --  Extract the tag from an unchecked type conversion. Done to avoid
885       --  the expansion of additional code just to obtain the value of such
886       --  tag because the current management of interface type conversions
887       --  generates in some cases this unchecked type conversion with the
888       --  tag of the object (see Expand_Interface_Conversion).
889
890       elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
891         and then
892           (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
893             or else
894               (RTE_Available (RE_Interface_Tag)
895                 and then
896                   Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
897       then
898          Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
899
900       --  Ada 2005 (AI-251): Abstract interface class-wide type
901
902       elsif Is_Interface (Ctrl_Typ)
903         and then Is_Class_Wide_Type (Ctrl_Typ)
904       then
905          Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
906
907       else
908          Controlling_Tag :=
909            Make_Selected_Component (Loc,
910              Prefix        => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
911              Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
912       end if;
913
914       --  Handle dispatching calls to predefined primitives
915
916       if Is_Predefined_Dispatching_Operation (Subp)
917         or else Is_Predefined_Dispatching_Alias (Subp)
918       then
919          Build_Get_Predefined_Prim_Op_Address (Loc,
920            Tag_Node => Controlling_Tag,
921            Position => DT_Position (Subp),
922            New_Node => New_Node);
923
924       --  Handle dispatching calls to user-defined primitives
925
926       else
927          Build_Get_Prim_Op_Address (Loc,
928            Typ      => Underlying_Type (Find_Dispatching_Type (Subp)),
929            Tag_Node => Controlling_Tag,
930            Position => DT_Position (Subp),
931            New_Node => New_Node);
932       end if;
933
934       New_Call_Name :=
935         Unchecked_Convert_To (Subp_Ptr_Typ, New_Node);
936
937       --  Generate the SCIL node for this dispatching call. Done now because
938       --  attribute SCIL_Controlling_Tag must be set after the new call name
939       --  is built to reference the nodes that will see the SCIL backend
940       --  (because Build_Get_Prim_Op_Address generates an unchecked type
941       --  conversion which relocates the controlling tag node).
942
943       if Generate_SCIL then
944          SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node));
945          Set_SCIL_Entity      (SCIL_Node, Typ);
946          Set_SCIL_Target_Prim (SCIL_Node, Subp);
947
948          --  Common case: the controlling tag is the tag of an object
949          --  (for example, obj.tag)
950
951          if Nkind (Controlling_Tag) = N_Selected_Component then
952             Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
953
954          --  Handle renaming of selected component
955
956          elsif Nkind (Controlling_Tag) = N_Identifier
957            and then Nkind (Parent (Entity (Controlling_Tag))) =
958                                              N_Object_Renaming_Declaration
959            and then Nkind (Name (Parent (Entity (Controlling_Tag)))) =
960                                              N_Selected_Component
961          then
962             Set_SCIL_Controlling_Tag (SCIL_Node,
963               Name (Parent (Entity (Controlling_Tag))));
964
965          --  If the controlling tag is an identifier, the SCIL node references
966          --  the corresponding object or parameter declaration
967
968          elsif Nkind (Controlling_Tag) = N_Identifier
969            and then Nkind_In (Parent (Entity (Controlling_Tag)),
970                               N_Object_Declaration,
971                               N_Parameter_Specification)
972          then
973             Set_SCIL_Controlling_Tag (SCIL_Node,
974               Parent (Entity (Controlling_Tag)));
975
976          --  If the controlling tag is a dereference, the SCIL node references
977          --  the corresponding object or parameter declaration
978
979          elsif Nkind (Controlling_Tag) = N_Explicit_Dereference
980             and then Nkind (Prefix (Controlling_Tag)) = N_Identifier
981             and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))),
982                                N_Object_Declaration,
983                                N_Parameter_Specification)
984          then
985             Set_SCIL_Controlling_Tag (SCIL_Node,
986               Parent (Entity (Prefix (Controlling_Tag))));
987
988          --  For a direct reference of the tag of the type the SCIL node
989          --  references the internal object declaration containing the tag
990          --  of the type.
991
992          elsif Nkind (Controlling_Tag) = N_Attribute_Reference
993             and then Attribute_Name (Controlling_Tag) = Name_Tag
994          then
995             Set_SCIL_Controlling_Tag (SCIL_Node,
996               Parent
997                 (Node
998                   (First_Elmt
999                     (Access_Disp_Table (Entity (Prefix (Controlling_Tag)))))));
1000
1001          --  Interfaces are not supported. For now we leave the SCIL node
1002          --  decorated with the Controlling_Tag. More work needed here???
1003
1004          elsif Is_Interface (Etype (Controlling_Tag)) then
1005             Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
1006
1007          else
1008             pragma Assert (False);
1009             null;
1010          end if;
1011       end if;
1012
1013       if Nkind (Call_Node) = N_Function_Call then
1014          New_Call :=
1015            Make_Function_Call (Loc,
1016              Name                   => New_Call_Name,
1017              Parameter_Associations => New_Params);
1018
1019          --  If this is a dispatching "=", we must first compare the tags so
1020          --  we generate: x.tag = y.tag and then x = y
1021
1022          if Subp = Eq_Prim_Op then
1023             Param := First_Actual (Call_Node);
1024             New_Call :=
1025               Make_And_Then (Loc,
1026                 Left_Opnd =>
1027                      Make_Op_Eq (Loc,
1028                        Left_Opnd =>
1029                          Make_Selected_Component (Loc,
1030                            Prefix        => New_Value (Param),
1031                            Selector_Name =>
1032                              New_Reference_To (First_Tag_Component (Typ),
1033                                                Loc)),
1034
1035                        Right_Opnd =>
1036                          Make_Selected_Component (Loc,
1037                            Prefix        =>
1038                              Unchecked_Convert_To (Typ,
1039                                New_Value (Next_Actual (Param))),
1040                            Selector_Name =>
1041                              New_Reference_To
1042                                (First_Tag_Component (Typ), Loc))),
1043                 Right_Opnd => New_Call);
1044
1045             SCIL_Related_Node := Right_Opnd (New_Call);
1046          end if;
1047
1048       else
1049          New_Call :=
1050            Make_Procedure_Call_Statement (Loc,
1051              Name                   => New_Call_Name,
1052              Parameter_Associations => New_Params);
1053       end if;
1054
1055       --  Register the dispatching call in the call graph nodes table
1056
1057       Register_CG_Node (Call_Node);
1058
1059       Rewrite (Call_Node, New_Call);
1060
1061       --  Associate the SCIL node of this dispatching call
1062
1063       if Generate_SCIL then
1064          Set_SCIL_Node (SCIL_Related_Node, SCIL_Node);
1065       end if;
1066
1067       --  Suppress all checks during the analysis of the expanded code
1068       --  to avoid the generation of spurious warnings under ZFP run-time.
1069
1070       Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
1071    end Expand_Dispatching_Call;
1072
1073    ---------------------------------
1074    -- Expand_Interface_Conversion --
1075    ---------------------------------
1076
1077    procedure Expand_Interface_Conversion
1078      (N         : Node_Id;
1079       Is_Static : Boolean := True)
1080    is
1081       Loc         : constant Source_Ptr := Sloc (N);
1082       Etyp        : constant Entity_Id  := Etype (N);
1083       Operand     : constant Node_Id    := Expression (N);
1084       Operand_Typ : Entity_Id           := Etype (Operand);
1085       Func        : Node_Id;
1086       Iface_Typ   : Entity_Id           := Etype (N);
1087       Iface_Tag   : Entity_Id;
1088
1089    begin
1090       --  Ada 2005 (AI-345): Handle synchronized interface type derivations
1091
1092       if Is_Concurrent_Type (Operand_Typ) then
1093          Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
1094       end if;
1095
1096       --  Handle access to class-wide interface types
1097
1098       if Is_Access_Type (Iface_Typ) then
1099          Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
1100       end if;
1101
1102       --  Handle class-wide interface types. This conversion can appear
1103       --  explicitly in the source code. Example: I'Class (Obj)
1104
1105       if Is_Class_Wide_Type (Iface_Typ) then
1106          Iface_Typ := Root_Type (Iface_Typ);
1107       end if;
1108
1109       --  If the target type is a tagged synchronized type, the dispatch table
1110       --  info is in the corresponding record type.
1111
1112       if Is_Concurrent_Type (Iface_Typ) then
1113          Iface_Typ := Corresponding_Record_Type (Iface_Typ);
1114       end if;
1115
1116       --  Handle private types
1117
1118       Iface_Typ := Underlying_Type (Iface_Typ);
1119
1120       --  Freeze the entity associated with the target interface to have
1121       --  available the attribute Access_Disp_Table.
1122
1123       Freeze_Before (N, Iface_Typ);
1124
1125       pragma Assert (not Is_Static
1126         or else (not Is_Class_Wide_Type (Iface_Typ)
1127                   and then Is_Interface (Iface_Typ)));
1128
1129       if not Tagged_Type_Expansion then
1130          if VM_Target /= No_VM then
1131             if Is_Access_Type (Operand_Typ) then
1132                Operand_Typ := Designated_Type (Operand_Typ);
1133             end if;
1134
1135             if Is_Class_Wide_Type (Operand_Typ) then
1136                Operand_Typ := Root_Type (Operand_Typ);
1137             end if;
1138
1139             if not Is_Static
1140               and then Operand_Typ /= Iface_Typ
1141             then
1142                Insert_Action (N,
1143                  Make_Procedure_Call_Statement (Loc,
1144                    Name => New_Occurrence_Of
1145                             (RTE (RE_Check_Interface_Conversion), Loc),
1146                    Parameter_Associations => New_List (
1147                      Make_Attribute_Reference (Loc,
1148                        Prefix => Duplicate_Subexpr (Expression (N)),
1149                        Attribute_Name => Name_Tag),
1150                      Make_Attribute_Reference (Loc,
1151                        Prefix         => New_Reference_To (Iface_Typ, Loc),
1152                        Attribute_Name => Name_Tag))));
1153             end if;
1154
1155             --  Just do a conversion ???
1156
1157             Rewrite (N, Unchecked_Convert_To (Etype (N), N));
1158             Analyze (N);
1159          end if;
1160
1161          return;
1162       end if;
1163
1164       if not Is_Static then
1165
1166          --  Give error if configurable run time and Displace not available
1167
1168          if not RTE_Available (RE_Displace) then
1169             Error_Msg_CRT ("dynamic interface conversion", N);
1170             return;
1171          end if;
1172
1173          --  Handle conversion of access-to-class-wide interface types. Target
1174          --  can be an access to an object or an access to another class-wide
1175          --  interface (see -1- and -2- in the following example):
1176
1177          --     type Iface1_Ref is access all Iface1'Class;
1178          --     type Iface2_Ref is access all Iface1'Class;
1179
1180          --     Acc1 : Iface1_Ref := new ...
1181          --     Obj  : Obj_Ref    := Obj_Ref (Acc);    -- 1
1182          --     Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
1183
1184          if Is_Access_Type (Operand_Typ) then
1185             Rewrite (N,
1186               Unchecked_Convert_To (Etype (N),
1187                 Make_Function_Call (Loc,
1188                   Name => New_Reference_To (RTE (RE_Displace), Loc),
1189                   Parameter_Associations => New_List (
1190
1191                     Unchecked_Convert_To (RTE (RE_Address),
1192                       Relocate_Node (Expression (N))),
1193
1194                     New_Occurrence_Of
1195                       (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1196                        Loc)))));
1197
1198             Analyze (N);
1199             return;
1200          end if;
1201
1202          Rewrite (N,
1203            Make_Function_Call (Loc,
1204              Name => New_Reference_To (RTE (RE_Displace), Loc),
1205              Parameter_Associations => New_List (
1206                Make_Attribute_Reference (Loc,
1207                  Prefix => Relocate_Node (Expression (N)),
1208                  Attribute_Name => Name_Address),
1209
1210                New_Occurrence_Of
1211                  (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1212                   Loc))));
1213
1214          Analyze (N);
1215
1216          --  If the target is a class-wide interface we change the type of the
1217          --  data returned by IW_Convert to indicate that this is a dispatching
1218          --  call.
1219
1220          declare
1221             New_Itype : Entity_Id;
1222
1223          begin
1224             New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
1225             Set_Etype (New_Itype, New_Itype);
1226             Set_Directly_Designated_Type (New_Itype, Etyp);
1227
1228             Rewrite (N,
1229               Make_Explicit_Dereference (Loc,
1230                 Prefix =>
1231                   Unchecked_Convert_To (New_Itype, Relocate_Node (N))));
1232             Analyze (N);
1233             Freeze_Itype (New_Itype, N);
1234
1235             return;
1236          end;
1237       end if;
1238
1239       Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
1240       pragma Assert (Iface_Tag /= Empty);
1241
1242       --  Keep separate access types to interfaces because one internal
1243       --  function is used to handle the null value (see following comments)
1244
1245       if not Is_Access_Type (Etype (N)) then
1246
1247          --  Statically displace the pointer to the object to reference
1248          --  the component containing the secondary dispatch table.
1249
1250          Rewrite (N,
1251            Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ),
1252              Make_Selected_Component (Loc,
1253                Prefix => Relocate_Node (Expression (N)),
1254                Selector_Name => New_Occurrence_Of (Iface_Tag, Loc))));
1255
1256       else
1257          --  Build internal function to handle the case in which the
1258          --  actual is null. If the actual is null returns null because
1259          --  no displacement is required; otherwise performs a type
1260          --  conversion that will be expanded in the code that returns
1261          --  the value of the displaced actual. That is:
1262
1263          --     function Func (O : Address) return Iface_Typ is
1264          --        type Op_Typ is access all Operand_Typ;
1265          --        Aux : Op_Typ := To_Op_Typ (O);
1266          --     begin
1267          --        if O = Null_Address then
1268          --           return null;
1269          --        else
1270          --           return Iface_Typ!(Aux.Iface_Tag'Address);
1271          --        end if;
1272          --     end Func;
1273
1274          declare
1275             Desig_Typ    : Entity_Id;
1276             Fent         : Entity_Id;
1277             New_Typ_Decl : Node_Id;
1278             Stats        : List_Id;
1279
1280          begin
1281             Desig_Typ := Etype (Expression (N));
1282
1283             if Is_Access_Type (Desig_Typ) then
1284                Desig_Typ :=
1285                  Available_View (Directly_Designated_Type (Desig_Typ));
1286             end if;
1287
1288             if Is_Concurrent_Type (Desig_Typ) then
1289                Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ));
1290             end if;
1291
1292             New_Typ_Decl :=
1293               Make_Full_Type_Declaration (Loc,
1294                 Defining_Identifier => Make_Temporary (Loc, 'T'),
1295                 Type_Definition =>
1296                   Make_Access_To_Object_Definition (Loc,
1297                     All_Present            => True,
1298                     Null_Exclusion_Present => False,
1299                     Constant_Present       => False,
1300                     Subtype_Indication     =>
1301                       New_Reference_To (Desig_Typ, Loc)));
1302
1303             Stats := New_List (
1304               Make_Simple_Return_Statement (Loc,
1305                 Unchecked_Convert_To (Etype (N),
1306                   Make_Attribute_Reference (Loc,
1307                     Prefix =>
1308                       Make_Selected_Component (Loc,
1309                         Prefix =>
1310                           Unchecked_Convert_To
1311                             (Defining_Identifier (New_Typ_Decl),
1312                              Make_Identifier (Loc, Name_uO)),
1313                         Selector_Name =>
1314                           New_Occurrence_Of (Iface_Tag, Loc)),
1315                     Attribute_Name => Name_Address))));
1316
1317             --  If the type is null-excluding, no need for the null branch.
1318             --  Otherwise we need to check for it and return null.
1319
1320             if not Can_Never_Be_Null (Etype (N)) then
1321                Stats := New_List (
1322                  Make_If_Statement (Loc,
1323                   Condition       =>
1324                     Make_Op_Eq (Loc,
1325                        Left_Opnd  => Make_Identifier (Loc, Name_uO),
1326                        Right_Opnd => New_Reference_To
1327                                        (RTE (RE_Null_Address), Loc)),
1328
1329                  Then_Statements => New_List (
1330                    Make_Simple_Return_Statement (Loc,
1331                      Make_Null (Loc))),
1332                  Else_Statements => Stats));
1333             end if;
1334
1335             Fent := Make_Temporary (Loc, 'F');
1336             Func :=
1337               Make_Subprogram_Body (Loc,
1338                 Specification =>
1339                   Make_Function_Specification (Loc,
1340                     Defining_Unit_Name => Fent,
1341
1342                     Parameter_Specifications => New_List (
1343                       Make_Parameter_Specification (Loc,
1344                         Defining_Identifier =>
1345                           Make_Defining_Identifier (Loc, Name_uO),
1346                         Parameter_Type =>
1347                           New_Reference_To (RTE (RE_Address), Loc))),
1348
1349                     Result_Definition =>
1350                       New_Reference_To (Etype (N), Loc)),
1351
1352                 Declarations => New_List (New_Typ_Decl),
1353
1354                 Handled_Statement_Sequence =>
1355                   Make_Handled_Sequence_Of_Statements (Loc, Stats));
1356
1357             --  Place function body before the expression containing the
1358             --  conversion. We suppress all checks because the body of the
1359             --  internally generated function already takes care of the case
1360             --  in which the actual is null; therefore there is no need to
1361             --  double check that the pointer is not null when the program
1362             --  executes the alternative that performs the type conversion).
1363
1364             Insert_Action (N, Func, Suppress => All_Checks);
1365
1366             if Is_Access_Type (Etype (Expression (N))) then
1367
1368                --  Generate: Func (Address!(Expression))
1369
1370                Rewrite (N,
1371                  Make_Function_Call (Loc,
1372                    Name => New_Reference_To (Fent, Loc),
1373                    Parameter_Associations => New_List (
1374                      Unchecked_Convert_To (RTE (RE_Address),
1375                        Relocate_Node (Expression (N))))));
1376
1377             else
1378                --  Generate: Func (Operand_Typ!(Expression)'Address)
1379
1380                Rewrite (N,
1381                  Make_Function_Call (Loc,
1382                    Name => New_Reference_To (Fent, Loc),
1383                    Parameter_Associations => New_List (
1384                      Make_Attribute_Reference (Loc,
1385                        Prefix  => Unchecked_Convert_To (Operand_Typ,
1386                                     Relocate_Node (Expression (N))),
1387                        Attribute_Name => Name_Address))));
1388             end if;
1389          end;
1390       end if;
1391
1392       Analyze (N);
1393    end Expand_Interface_Conversion;
1394
1395    ------------------------------
1396    -- Expand_Interface_Actuals --
1397    ------------------------------
1398
1399    procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
1400       Actual     : Node_Id;
1401       Actual_Dup : Node_Id;
1402       Actual_Typ : Entity_Id;
1403       Anon       : Entity_Id;
1404       Conversion : Node_Id;
1405       Formal     : Entity_Id;
1406       Formal_Typ : Entity_Id;
1407       Subp       : Entity_Id;
1408       Formal_DDT : Entity_Id;
1409       Actual_DDT : Entity_Id;
1410
1411    begin
1412       --  This subprogram is called directly from the semantics, so we need a
1413       --  check to see whether expansion is active before proceeding.
1414
1415       if not Expander_Active then
1416          return;
1417       end if;
1418
1419       --  Call using access to subprogram with explicit dereference
1420
1421       if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
1422          Subp := Etype (Name (Call_Node));
1423
1424       --  Call using selected component
1425
1426       elsif Nkind (Name (Call_Node)) = N_Selected_Component then
1427          Subp := Entity (Selector_Name (Name (Call_Node)));
1428
1429       --  Call using direct name
1430
1431       else
1432          Subp := Entity (Name (Call_Node));
1433       end if;
1434
1435       --  Ada 2005 (AI-251): Look for interface type formals to force "this"
1436       --  displacement
1437
1438       Formal := First_Formal (Subp);
1439       Actual := First_Actual (Call_Node);
1440       while Present (Formal) loop
1441          Formal_Typ := Etype (Formal);
1442
1443          if Ekind (Formal_Typ) = E_Record_Type_With_Private then
1444             Formal_Typ := Full_View (Formal_Typ);
1445          end if;
1446
1447          if Is_Access_Type (Formal_Typ) then
1448             Formal_DDT := Directly_Designated_Type (Formal_Typ);
1449          end if;
1450
1451          Actual_Typ := Etype (Actual);
1452
1453          if Is_Access_Type (Actual_Typ) then
1454             Actual_DDT := Directly_Designated_Type (Actual_Typ);
1455          end if;
1456
1457          if Is_Interface (Formal_Typ)
1458            and then Is_Class_Wide_Type (Formal_Typ)
1459          then
1460             --  No need to displace the pointer if the type of the actual
1461             --  coincides with the type of the formal.
1462
1463             if Actual_Typ = Formal_Typ then
1464                null;
1465
1466             --  No need to displace the pointer if the interface type is
1467             --  a parent of the type of the actual because in this case the
1468             --  interface primitives are located in the primary dispatch table.
1469
1470             elsif Is_Ancestor (Formal_Typ, Actual_Typ,
1471                                Use_Full_View => True)
1472             then
1473                null;
1474
1475             --  Implicit conversion to the class-wide formal type to force
1476             --  the displacement of the pointer.
1477
1478             else
1479                --  Normally, expansion of actuals for calls to build-in-place
1480                --  functions happens as part of Expand_Actuals, but in this
1481                --  case the call will be wrapped in a conversion and soon after
1482                --  expanded further to handle the displacement for a class-wide
1483                --  interface conversion, so if this is a BIP call then we need
1484                --  to handle it now.
1485
1486                if Ada_Version >= Ada_2005
1487                  and then Is_Build_In_Place_Function_Call (Actual)
1488                then
1489                   Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
1490                end if;
1491
1492                Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
1493                Rewrite (Actual, Conversion);
1494                Analyze_And_Resolve (Actual, Formal_Typ);
1495             end if;
1496
1497          --  Access to class-wide interface type
1498
1499          elsif Is_Access_Type (Formal_Typ)
1500            and then Is_Interface (Formal_DDT)
1501            and then Is_Class_Wide_Type (Formal_DDT)
1502            and then Interface_Present_In_Ancestor
1503                       (Typ   => Actual_DDT,
1504                        Iface => Etype (Formal_DDT))
1505          then
1506             --  Handle attributes 'Access and 'Unchecked_Access
1507
1508             if Nkind (Actual) = N_Attribute_Reference
1509               and then
1510                (Attribute_Name (Actual) = Name_Access
1511                  or else Attribute_Name (Actual) = Name_Unchecked_Access)
1512             then
1513                --  This case must have been handled by the analysis and
1514                --  expansion of 'Access. The only exception is when types
1515                --  match and no further expansion is required.
1516
1517                pragma Assert (Base_Type (Etype (Prefix (Actual)))
1518                                = Base_Type (Formal_DDT));
1519                null;
1520
1521             --  No need to displace the pointer if the type of the actual
1522             --  coincides with the type of the formal.
1523
1524             elsif Actual_DDT = Formal_DDT then
1525                null;
1526
1527             --  No need to displace the pointer if the interface type is
1528             --  a parent of the type of the actual because in this case the
1529             --  interface primitives are located in the primary dispatch table.
1530
1531             elsif Is_Ancestor (Formal_DDT, Actual_DDT,
1532                                Use_Full_View => True)
1533             then
1534                null;
1535
1536             else
1537                Actual_Dup := Relocate_Node (Actual);
1538
1539                if From_With_Type (Actual_Typ) then
1540
1541                   --  If the type of the actual parameter comes from a limited
1542                   --  with-clause and the non-limited view is already available
1543                   --  we replace the anonymous access type by a duplicate
1544                   --  declaration whose designated type is the non-limited view
1545
1546                   if Ekind (Actual_DDT) = E_Incomplete_Type
1547                     and then Present (Non_Limited_View (Actual_DDT))
1548                   then
1549                      Anon := New_Copy (Actual_Typ);
1550
1551                      if Is_Itype (Anon) then
1552                         Set_Scope (Anon, Current_Scope);
1553                      end if;
1554
1555                      Set_Directly_Designated_Type (Anon,
1556                        Non_Limited_View (Actual_DDT));
1557                      Set_Etype (Actual_Dup, Anon);
1558
1559                   elsif Is_Class_Wide_Type (Actual_DDT)
1560                     and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type
1561                     and then Present (Non_Limited_View (Etype (Actual_DDT)))
1562                   then
1563                      Anon := New_Copy (Actual_Typ);
1564
1565                      if Is_Itype (Anon) then
1566                         Set_Scope (Anon, Current_Scope);
1567                      end if;
1568
1569                      Set_Directly_Designated_Type (Anon,
1570                        New_Copy (Actual_DDT));
1571                      Set_Class_Wide_Type (Directly_Designated_Type (Anon),
1572                        New_Copy (Class_Wide_Type (Actual_DDT)));
1573                      Set_Etype (Directly_Designated_Type (Anon),
1574                        Non_Limited_View (Etype (Actual_DDT)));
1575                      Set_Etype (
1576                        Class_Wide_Type (Directly_Designated_Type (Anon)),
1577                        Non_Limited_View (Etype (Actual_DDT)));
1578                      Set_Etype (Actual_Dup, Anon);
1579                   end if;
1580                end if;
1581
1582                Conversion := Convert_To (Formal_Typ, Actual_Dup);
1583                Rewrite (Actual, Conversion);
1584                Analyze_And_Resolve (Actual, Formal_Typ);
1585             end if;
1586          end if;
1587
1588          Next_Actual (Actual);
1589          Next_Formal (Formal);
1590       end loop;
1591    end Expand_Interface_Actuals;
1592
1593    ----------------------------
1594    -- Expand_Interface_Thunk --
1595    ----------------------------
1596
1597    procedure Expand_Interface_Thunk
1598      (Prim       : Node_Id;
1599       Thunk_Id   : out Entity_Id;
1600       Thunk_Code : out Node_Id)
1601    is
1602       Loc     : constant Source_Ptr := Sloc (Prim);
1603       Actuals : constant List_Id    := New_List;
1604       Decl    : constant List_Id    := New_List;
1605       Formals : constant List_Id    := New_List;
1606       Target  : constant Entity_Id  := Ultimate_Alias (Prim);
1607
1608       Controlling_Typ : Entity_Id;
1609       Decl_1          : Node_Id;
1610       Decl_2          : Node_Id;
1611       Expr            : Node_Id;
1612       Formal          : Node_Id;
1613       Ftyp            : Entity_Id;
1614       Iface_Formal    : Node_Id;
1615       New_Arg         : Node_Id;
1616       Offset_To_Top   : Node_Id;
1617       Target_Formal   : Entity_Id;
1618
1619    begin
1620       Thunk_Id   := Empty;
1621       Thunk_Code := Empty;
1622
1623       --  No thunk needed if the primitive has been eliminated
1624
1625       if Is_Eliminated (Ultimate_Alias (Prim)) then
1626          return;
1627
1628       --  In case of primitives that are functions without formals and a
1629       --  controlling result there is no need to build the thunk.
1630
1631       elsif not Present (First_Formal (Target)) then
1632          pragma Assert (Ekind (Target) = E_Function
1633            and then Has_Controlling_Result (Target));
1634          return;
1635       end if;
1636
1637       --  Duplicate the formals of the Target primitive. In the thunk, the type
1638       --  of the controlling formal is the covered interface type (instead of
1639       --  the target tagged type). Done to avoid problems with discriminated
1640       --  tagged types because, if the controlling type has discriminants with
1641       --  default values, then the type conversions done inside the body of
1642       --  the thunk (after the displacement of the pointer to the base of the
1643       --  actual object) generate code that modify its contents.
1644
1645       --  Note: This special management is not done for predefined primitives
1646       --  because???
1647
1648       if not Is_Predefined_Dispatching_Operation (Prim) then
1649          Iface_Formal := First_Formal (Interface_Alias (Prim));
1650       end if;
1651
1652       Formal := First_Formal (Target);
1653       while Present (Formal) loop
1654          Ftyp := Etype (Formal);
1655
1656          --  Use the interface type as the type of the controlling formal (see
1657          --  comment above).
1658
1659          if not Is_Controlling_Formal (Formal)
1660            or else Is_Predefined_Dispatching_Operation (Prim)
1661          then
1662             Ftyp := Etype (Formal);
1663             Expr := New_Copy_Tree (Expression (Parent (Formal)));
1664          else
1665             Ftyp := Etype (Iface_Formal);
1666             Expr := Empty;
1667          end if;
1668
1669          Append_To (Formals,
1670            Make_Parameter_Specification (Loc,
1671              Defining_Identifier =>
1672                Make_Defining_Identifier (Sloc (Formal),
1673                  Chars => Chars (Formal)),
1674              In_Present => In_Present (Parent (Formal)),
1675              Out_Present => Out_Present (Parent (Formal)),
1676              Parameter_Type => New_Reference_To (Ftyp, Loc),
1677              Expression => Expr));
1678
1679          if not Is_Predefined_Dispatching_Operation (Prim) then
1680             Next_Formal (Iface_Formal);
1681          end if;
1682
1683          Next_Formal (Formal);
1684       end loop;
1685
1686       Controlling_Typ := Find_Dispatching_Type (Target);
1687
1688       Target_Formal := First_Formal (Target);
1689       Formal        := First (Formals);
1690       while Present (Formal) loop
1691
1692          --  If the parent is a constrained discriminated type, then the
1693          --  primitive operation will have been defined on a first subtype.
1694          --  For proper matching with controlling type, use base type.
1695
1696          if Ekind (Target_Formal) = E_In_Parameter
1697            and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1698          then
1699             Ftyp :=
1700               Base_Type (Directly_Designated_Type (Etype (Target_Formal)));
1701          else
1702             Ftyp := Base_Type (Etype (Target_Formal));
1703          end if;
1704
1705          --  For concurrent types, the relevant information is found in the
1706          --  Corresponding_Record_Type, rather than the type entity itself.
1707
1708          if Is_Concurrent_Type (Ftyp) then
1709             Ftyp := Corresponding_Record_Type (Ftyp);
1710          end if;
1711
1712          if Ekind (Target_Formal) = E_In_Parameter
1713            and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1714            and then Ftyp = Controlling_Typ
1715          then
1716             --  Generate:
1717             --     type T is access all <<type of the target formal>>
1718             --     S : Storage_Offset := Storage_Offset!(Formal)
1719             --                            - Offset_To_Top (address!(Formal))
1720
1721             Decl_2 :=
1722               Make_Full_Type_Declaration (Loc,
1723                 Defining_Identifier => Make_Temporary (Loc, 'T'),
1724                 Type_Definition =>
1725                   Make_Access_To_Object_Definition (Loc,
1726                     All_Present            => True,
1727                     Null_Exclusion_Present => False,
1728                     Constant_Present       => False,
1729                     Subtype_Indication     =>
1730                       New_Reference_To (Ftyp, Loc)));
1731
1732             New_Arg :=
1733               Unchecked_Convert_To (RTE (RE_Address),
1734                 New_Reference_To (Defining_Identifier (Formal), Loc));
1735
1736             if not RTE_Available (RE_Offset_To_Top) then
1737                Offset_To_Top :=
1738                  Build_Offset_To_Top (Loc, New_Arg);
1739             else
1740                Offset_To_Top :=
1741                  Make_Function_Call (Loc,
1742                    Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1743                    Parameter_Associations => New_List (New_Arg));
1744             end if;
1745
1746             Decl_1 :=
1747               Make_Object_Declaration (Loc,
1748                 Defining_Identifier => Make_Temporary (Loc, 'S'),
1749                 Constant_Present    => True,
1750                 Object_Definition   =>
1751                   New_Reference_To (RTE (RE_Storage_Offset), Loc),
1752                 Expression          =>
1753                   Make_Op_Subtract (Loc,
1754                     Left_Opnd  =>
1755                       Unchecked_Convert_To
1756                         (RTE (RE_Storage_Offset),
1757                          New_Reference_To (Defining_Identifier (Formal), Loc)),
1758                      Right_Opnd =>
1759                        Offset_To_Top));
1760
1761             Append_To (Decl, Decl_2);
1762             Append_To (Decl, Decl_1);
1763
1764             --  Reference the new actual. Generate:
1765             --    T!(S)
1766
1767             Append_To (Actuals,
1768               Unchecked_Convert_To
1769                 (Defining_Identifier (Decl_2),
1770                  New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1771
1772          elsif Ftyp = Controlling_Typ then
1773
1774             --  Generate:
1775             --     S1 : Storage_Offset := Storage_Offset!(Formal'Address)
1776             --                             - Offset_To_Top (Formal'Address)
1777             --     S2 : Addr_Ptr := Addr_Ptr!(S1)
1778
1779             New_Arg :=
1780               Make_Attribute_Reference (Loc,
1781                 Prefix =>
1782                   New_Reference_To (Defining_Identifier (Formal), Loc),
1783                 Attribute_Name =>
1784                   Name_Address);
1785
1786             if not RTE_Available (RE_Offset_To_Top) then
1787                Offset_To_Top :=
1788                  Build_Offset_To_Top (Loc, New_Arg);
1789             else
1790                Offset_To_Top :=
1791                  Make_Function_Call (Loc,
1792                    Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1793                    Parameter_Associations => New_List (New_Arg));
1794             end if;
1795
1796             Decl_1 :=
1797               Make_Object_Declaration (Loc,
1798                 Defining_Identifier => Make_Temporary (Loc, 'S'),
1799                 Constant_Present    => True,
1800                 Object_Definition   =>
1801                   New_Reference_To (RTE (RE_Storage_Offset), Loc),
1802                 Expression          =>
1803                   Make_Op_Subtract (Loc,
1804                     Left_Opnd =>
1805                       Unchecked_Convert_To
1806                         (RTE (RE_Storage_Offset),
1807                          Make_Attribute_Reference (Loc,
1808                            Prefix =>
1809                              New_Reference_To
1810                                (Defining_Identifier (Formal), Loc),
1811                            Attribute_Name => Name_Address)),
1812                     Right_Opnd =>
1813                       Offset_To_Top));
1814
1815             Decl_2 :=
1816               Make_Object_Declaration (Loc,
1817                 Defining_Identifier => Make_Temporary (Loc, 'S'),
1818                 Constant_Present    => True,
1819                 Object_Definition   =>
1820                   New_Reference_To (RTE (RE_Addr_Ptr), Loc),
1821                 Expression          =>
1822                   Unchecked_Convert_To
1823                     (RTE (RE_Addr_Ptr),
1824                      New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1825
1826             Append_To (Decl, Decl_1);
1827             Append_To (Decl, Decl_2);
1828
1829             --  Reference the new actual, generate:
1830             --    Target_Formal (S2.all)
1831
1832             Append_To (Actuals,
1833               Unchecked_Convert_To (Ftyp,
1834                  Make_Explicit_Dereference (Loc,
1835                    New_Reference_To (Defining_Identifier (Decl_2), Loc))));
1836
1837          --  No special management required for this actual
1838
1839          else
1840             Append_To (Actuals,
1841                New_Reference_To (Defining_Identifier (Formal), Loc));
1842          end if;
1843
1844          Next_Formal (Target_Formal);
1845          Next (Formal);
1846       end loop;
1847
1848       Thunk_Id := Make_Temporary (Loc, 'T');
1849       Set_Is_Thunk (Thunk_Id);
1850       Set_Convention (Thunk_Id, Convention (Prim));
1851
1852       --  Procedure case
1853
1854       if Ekind (Target) = E_Procedure then
1855          Thunk_Code :=
1856            Make_Subprogram_Body (Loc,
1857               Specification =>
1858                 Make_Procedure_Specification (Loc,
1859                   Defining_Unit_Name       => Thunk_Id,
1860                   Parameter_Specifications => Formals),
1861               Declarations => Decl,
1862               Handled_Statement_Sequence =>
1863                 Make_Handled_Sequence_Of_Statements (Loc,
1864                   Statements => New_List (
1865                     Make_Procedure_Call_Statement (Loc,
1866                       Name => New_Occurrence_Of (Target, Loc),
1867                       Parameter_Associations => Actuals))));
1868
1869       --  Function case
1870
1871       else pragma Assert (Ekind (Target) = E_Function);
1872          Thunk_Code :=
1873            Make_Subprogram_Body (Loc,
1874               Specification =>
1875                 Make_Function_Specification (Loc,
1876                   Defining_Unit_Name       => Thunk_Id,
1877                   Parameter_Specifications => Formals,
1878                   Result_Definition =>
1879                     New_Copy (Result_Definition (Parent (Target)))),
1880               Declarations => Decl,
1881               Handled_Statement_Sequence =>
1882                 Make_Handled_Sequence_Of_Statements (Loc,
1883                   Statements => New_List (
1884                     Make_Simple_Return_Statement (Loc,
1885                       Make_Function_Call (Loc,
1886                         Name => New_Occurrence_Of (Target, Loc),
1887                         Parameter_Associations => Actuals)))));
1888       end if;
1889    end Expand_Interface_Thunk;
1890
1891    ------------------------
1892    -- Find_Specific_Type --
1893    ------------------------
1894
1895    function Find_Specific_Type (CW : Entity_Id) return Entity_Id is
1896       Typ : Entity_Id := Root_Type (CW);
1897
1898    begin
1899       if Ekind (Typ) = E_Incomplete_Type then
1900          if From_With_Type (Typ) then
1901             Typ := Non_Limited_View (Typ);
1902          else
1903             Typ := Full_View (Typ);
1904          end if;
1905       end if;
1906
1907       return Typ;
1908    end Find_Specific_Type;
1909
1910    --------------------------
1911    -- Has_CPP_Constructors --
1912    --------------------------
1913
1914    function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is
1915       E : Entity_Id;
1916
1917    begin
1918       --  Look for the constructor entities
1919
1920       E := Next_Entity (Typ);
1921       while Present (E) loop
1922          if Ekind (E) = E_Function
1923            and then Is_Constructor (E)
1924          then
1925             return True;
1926          end if;
1927
1928          Next_Entity (E);
1929       end loop;
1930
1931       return False;
1932    end Has_CPP_Constructors;
1933
1934    ------------
1935    -- Has_DT --
1936    ------------
1937
1938    function Has_DT (Typ : Entity_Id) return Boolean is
1939    begin
1940       return not Is_Interface (Typ)
1941                and then not Restriction_Active (No_Dispatching_Calls);
1942    end Has_DT;
1943
1944    -----------------------------------------
1945    -- Is_Predefined_Dispatching_Operation --
1946    -----------------------------------------
1947
1948    function Is_Predefined_Dispatching_Operation
1949      (E : Entity_Id) return Boolean
1950    is
1951       TSS_Name : TSS_Name_Type;
1952
1953    begin
1954       if not Is_Dispatching_Operation (E) then
1955          return False;
1956       end if;
1957
1958       Get_Name_String (Chars (E));
1959
1960       --  Most predefined primitives have internally generated names. Equality
1961       --  must be treated differently; the predefined operation is recognized
1962       --  as a homogeneous binary operator that returns Boolean.
1963
1964       if Name_Len > TSS_Name_Type'Last then
1965          TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
1966                                      .. Name_Len));
1967          if        Chars (E) = Name_uSize
1968            or else TSS_Name  = TSS_Stream_Read
1969            or else TSS_Name  = TSS_Stream_Write
1970            or else TSS_Name  = TSS_Stream_Input
1971            or else TSS_Name  = TSS_Stream_Output
1972            or else
1973              (Chars (E) = Name_Op_Eq
1974                 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
1975            or else Chars (E) = Name_uAssign
1976            or else TSS_Name  = TSS_Deep_Adjust
1977            or else TSS_Name  = TSS_Deep_Finalize
1978            or else Is_Predefined_Interface_Primitive (E)
1979          then
1980             return True;
1981          end if;
1982       end if;
1983
1984       return False;
1985    end Is_Predefined_Dispatching_Operation;
1986
1987    ---------------------------------------
1988    -- Is_Predefined_Internal_Operation  --
1989    ---------------------------------------
1990
1991    function Is_Predefined_Internal_Operation
1992      (E : Entity_Id) return Boolean
1993    is
1994       TSS_Name : TSS_Name_Type;
1995
1996    begin
1997       if not Is_Dispatching_Operation (E) then
1998          return False;
1999       end if;
2000
2001       Get_Name_String (Chars (E));
2002
2003       --  Most predefined primitives have internally generated names. Equality
2004       --  must be treated differently; the predefined operation is recognized
2005       --  as a homogeneous binary operator that returns Boolean.
2006
2007       if Name_Len > TSS_Name_Type'Last then
2008          TSS_Name :=
2009            TSS_Name_Type
2010              (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
2011
2012          if        Chars (E) = Name_uSize
2013            or else
2014              (Chars (E) = Name_Op_Eq
2015                 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
2016            or else Chars (E) = Name_uAssign
2017            or else TSS_Name  = TSS_Deep_Adjust
2018            or else TSS_Name  = TSS_Deep_Finalize
2019            or else Is_Predefined_Interface_Primitive (E)
2020          then
2021             return True;
2022          end if;
2023       end if;
2024
2025       return False;
2026    end Is_Predefined_Internal_Operation;
2027
2028    -------------------------------------
2029    -- Is_Predefined_Dispatching_Alias --
2030    -------------------------------------
2031
2032    function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
2033    is
2034    begin
2035       return not Is_Predefined_Dispatching_Operation (Prim)
2036         and then Present (Alias (Prim))
2037         and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim));
2038    end Is_Predefined_Dispatching_Alias;
2039
2040    ---------------------------------------
2041    -- Is_Predefined_Interface_Primitive --
2042    ---------------------------------------
2043
2044    function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
2045    begin
2046       --  In VM targets we don't restrict the functionality of this test to
2047       --  compiling in Ada 2005 mode since in VM targets any tagged type has
2048       --  these primitives
2049
2050       return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
2051         and then (Chars (E) = Name_uDisp_Asynchronous_Select or else
2052                   Chars (E) = Name_uDisp_Conditional_Select  or else
2053                   Chars (E) = Name_uDisp_Get_Prim_Op_Kind    or else
2054                   Chars (E) = Name_uDisp_Get_Task_Id         or else
2055                   Chars (E) = Name_uDisp_Requeue             or else
2056                   Chars (E) = Name_uDisp_Timed_Select);
2057    end Is_Predefined_Interface_Primitive;
2058
2059    ----------------------------------------
2060    -- Make_Disp_Asynchronous_Select_Body --
2061    ----------------------------------------
2062
2063    --  For interface types, generate:
2064
2065    --     procedure _Disp_Asynchronous_Select
2066    --       (T : in out <Typ>;
2067    --        S : Integer;
2068    --        P : System.Address;
2069    --        B : out System.Storage_Elements.Dummy_Communication_Block;
2070    --        F : out Boolean)
2071    --     is
2072    --     begin
2073    --        F := False;
2074    --        C := Ada.Tags.POK_Function;
2075    --     end _Disp_Asynchronous_Select;
2076
2077    --  For protected types, generate:
2078
2079    --     procedure _Disp_Asynchronous_Select
2080    --       (T : in out <Typ>;
2081    --        S : Integer;
2082    --        P : System.Address;
2083    --        B : out System.Storage_Elements.Dummy_Communication_Block;
2084    --        F : out Boolean)
2085    --     is
2086    --        I   : Integer :=
2087    --                Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2088    --        Bnn : System.Tasking.Protected_Objects.Operations.
2089    --                Communication_Block;
2090    --     begin
2091    --        System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2092    --          (T._object'Access,
2093    --           System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2094    --           P,
2095    --           System.Tasking.Asynchronous_Call,
2096    --           Bnn);
2097    --        B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
2098    --     end _Disp_Asynchronous_Select;
2099
2100    --  For task types, generate:
2101
2102    --     procedure _Disp_Asynchronous_Select
2103    --       (T : in out <Typ>;
2104    --        S : Integer;
2105    --        P : System.Address;
2106    --        B : out System.Storage_Elements.Dummy_Communication_Block;
2107    --        F : out Boolean)
2108    --     is
2109    --        I   : Integer :=
2110    --                Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2111    --     begin
2112    --        System.Tasking.Rendezvous.Task_Entry_Call
2113    --          (T._task_id,
2114    --           System.Tasking.Task_Entry_Index (I),
2115    --           P,
2116    --           System.Tasking.Asynchronous_Call,
2117    --           F);
2118    --     end _Disp_Asynchronous_Select;
2119
2120    function Make_Disp_Asynchronous_Select_Body
2121      (Typ : Entity_Id) return Node_Id
2122    is
2123       Com_Block : Entity_Id;
2124       Conc_Typ  : Entity_Id           := Empty;
2125       Decls     : constant List_Id    := New_List;
2126       Loc       : constant Source_Ptr := Sloc (Typ);
2127       Obj_Ref   : Node_Id;
2128       Stmts     : constant List_Id    := New_List;
2129       Tag_Node  : Node_Id;
2130
2131    begin
2132       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2133
2134       --  Null body is generated for interface types
2135
2136       if Is_Interface (Typ) then
2137          return
2138            Make_Subprogram_Body (Loc,
2139              Specification => Make_Disp_Asynchronous_Select_Spec (Typ),
2140              Declarations  => New_List,
2141              Handled_Statement_Sequence =>
2142                Make_Handled_Sequence_Of_Statements (Loc,
2143                  New_List (Make_Assignment_Statement (Loc,
2144                    Name       => Make_Identifier (Loc, Name_uF),
2145                    Expression => New_Reference_To (Standard_False, Loc)))));
2146       end if;
2147
2148       if Is_Concurrent_Record_Type (Typ) then
2149          Conc_Typ := Corresponding_Concurrent_Type (Typ);
2150
2151          --  Generate:
2152          --    I : Integer :=
2153          --          Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2154
2155          --  where I will be used to capture the entry index of the primitive
2156          --  wrapper at position S.
2157
2158          if Tagged_Type_Expansion then
2159             Tag_Node :=
2160               Unchecked_Convert_To (RTE (RE_Tag),
2161                 New_Reference_To
2162                   (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2163          else
2164             Tag_Node :=
2165               Make_Attribute_Reference (Loc,
2166                 Prefix => New_Reference_To (Typ, Loc),
2167                 Attribute_Name => Name_Tag);
2168          end if;
2169
2170          Append_To (Decls,
2171            Make_Object_Declaration (Loc,
2172              Defining_Identifier =>
2173                Make_Defining_Identifier (Loc, Name_uI),
2174              Object_Definition =>
2175                New_Reference_To (Standard_Integer, Loc),
2176              Expression =>
2177                Make_Function_Call (Loc,
2178                  Name =>
2179                    New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
2180                  Parameter_Associations =>
2181                    New_List (
2182                      Tag_Node,
2183                      Make_Identifier (Loc, Name_uS)))));
2184
2185          if Ekind (Conc_Typ) = E_Protected_Type then
2186
2187             --  Generate:
2188             --    Bnn : Communication_Block;
2189
2190             Com_Block := Make_Temporary (Loc, 'B');
2191             Append_To (Decls,
2192               Make_Object_Declaration (Loc,
2193                 Defining_Identifier =>
2194                   Com_Block,
2195                 Object_Definition =>
2196                   New_Reference_To (RTE (RE_Communication_Block), Loc)));
2197
2198             --  Build T._object'Access for calls below
2199
2200             Obj_Ref :=
2201                Make_Attribute_Reference (Loc,
2202                  Attribute_Name => Name_Unchecked_Access,
2203                  Prefix         =>
2204                    Make_Selected_Component (Loc,
2205                      Prefix        => Make_Identifier (Loc, Name_uT),
2206                      Selector_Name => Make_Identifier (Loc, Name_uObject)));
2207
2208             case Corresponding_Runtime_Package (Conc_Typ) is
2209                when System_Tasking_Protected_Objects_Entries =>
2210
2211                   --  Generate:
2212                   --    Protected_Entry_Call
2213                   --      (T._object'Access,            --  Object
2214                   --       Protected_Entry_Index! (I),  --  E
2215                   --       P,                           --  Uninterpreted_Data
2216                   --       Asynchronous_Call,           --  Mode
2217                   --       Bnn);                        --  Communication_Block
2218
2219                   --  where T is the protected object, I is the entry index, P
2220                   --  is the wrapped parameters and B is the name of the
2221                   --  communication block.
2222
2223                   Append_To (Stmts,
2224                     Make_Procedure_Call_Statement (Loc,
2225                       Name =>
2226                         New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
2227                       Parameter_Associations =>
2228                         New_List (
2229                           Obj_Ref,
2230
2231                           Make_Unchecked_Type_Conversion (Loc,  --  entry index
2232                             Subtype_Mark =>
2233                               New_Reference_To
2234                                 (RTE (RE_Protected_Entry_Index), Loc),
2235                             Expression => Make_Identifier (Loc, Name_uI)),
2236
2237                           Make_Identifier (Loc, Name_uP), --  parameter block
2238                           New_Reference_To                --  Asynchronous_Call
2239                             (RTE (RE_Asynchronous_Call), Loc),
2240
2241                           New_Reference_To (Com_Block, Loc)))); -- comm block
2242
2243                when System_Tasking_Protected_Objects_Single_Entry =>
2244
2245                   --  Generate:
2246                   --    procedure Protected_Single_Entry_Call
2247                   --      (Object              : Protection_Entry_Access;
2248                   --       Uninterpreted_Data  : System.Address;
2249                   --       Mode                : Call_Modes);
2250
2251                   Append_To (Stmts,
2252                     Make_Procedure_Call_Statement (Loc,
2253                       Name =>
2254                         New_Reference_To
2255                           (RTE (RE_Protected_Single_Entry_Call), Loc),
2256                       Parameter_Associations =>
2257                         New_List (
2258                           Obj_Ref,
2259
2260                           Make_Attribute_Reference (Loc,
2261                             Prefix         => Make_Identifier (Loc, Name_uP),
2262                             Attribute_Name => Name_Address),
2263
2264                             New_Reference_To
2265                              (RTE (RE_Asynchronous_Call), Loc))));
2266
2267                when others =>
2268                   raise Program_Error;
2269             end case;
2270
2271             --  Generate:
2272             --    B := Dummy_Communication_Block (Bnn);
2273
2274             Append_To (Stmts,
2275               Make_Assignment_Statement (Loc,
2276                 Name => Make_Identifier (Loc, Name_uB),
2277                 Expression =>
2278                   Make_Unchecked_Type_Conversion (Loc,
2279                     Subtype_Mark =>
2280                       New_Reference_To (
2281                         RTE (RE_Dummy_Communication_Block), Loc),
2282                     Expression =>
2283                       New_Reference_To (Com_Block, Loc))));
2284
2285             --  Generate:
2286             --    F := False;
2287
2288             Append_To (Stmts,
2289               Make_Assignment_Statement (Loc,
2290                 Name       => Make_Identifier (Loc, Name_uF),
2291                 Expression => New_Reference_To (Standard_False, Loc)));
2292
2293          else
2294             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2295
2296             --  Generate:
2297             --    Task_Entry_Call
2298             --      (T._task_id,             --  Acceptor
2299             --       Task_Entry_Index! (I),  --  E
2300             --       P,                      --  Uninterpreted_Data
2301             --       Asynchronous_Call,      --  Mode
2302             --       F);                     --  Rendezvous_Successful
2303
2304             --  where T is the task object, I is the entry index, P is the
2305             --  wrapped parameters and F is the status flag.
2306
2307             Append_To (Stmts,
2308               Make_Procedure_Call_Statement (Loc,
2309                 Name =>
2310                   New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
2311                 Parameter_Associations =>
2312                   New_List (
2313                     Make_Selected_Component (Loc,         -- T._task_id
2314                       Prefix        => Make_Identifier (Loc, Name_uT),
2315                       Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2316
2317                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
2318                       Subtype_Mark =>
2319                         New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2320                       Expression => Make_Identifier (Loc, Name_uI)),
2321
2322                     Make_Identifier (Loc, Name_uP),       --  parameter block
2323                     New_Reference_To                      --  Asynchronous_Call
2324                       (RTE (RE_Asynchronous_Call), Loc),
2325                     Make_Identifier (Loc, Name_uF))));    --  status flag
2326          end if;
2327
2328       else
2329          --  Ensure that the statements list is non-empty
2330
2331          Append_To (Stmts,
2332            Make_Assignment_Statement (Loc,
2333              Name       => Make_Identifier (Loc, Name_uF),
2334              Expression => New_Reference_To (Standard_False, Loc)));
2335       end if;
2336
2337       return
2338         Make_Subprogram_Body (Loc,
2339           Specification              =>
2340             Make_Disp_Asynchronous_Select_Spec (Typ),
2341           Declarations               => Decls,
2342           Handled_Statement_Sequence =>
2343             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2344    end Make_Disp_Asynchronous_Select_Body;
2345
2346    ----------------------------------------
2347    -- Make_Disp_Asynchronous_Select_Spec --
2348    ----------------------------------------
2349
2350    function Make_Disp_Asynchronous_Select_Spec
2351      (Typ : Entity_Id) return Node_Id
2352    is
2353       Loc    : constant Source_Ptr := Sloc (Typ);
2354       Def_Id : constant Node_Id    :=
2355                  Make_Defining_Identifier (Loc,
2356                    Name_uDisp_Asynchronous_Select);
2357       Params : constant List_Id    := New_List;
2358
2359    begin
2360       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2361
2362       --  T : in out Typ;                     --  Object parameter
2363       --  S : Integer;                        --  Primitive operation slot
2364       --  P : Address;                        --  Wrapped parameters
2365       --  B : out Dummy_Communication_Block;  --  Communication block dummy
2366       --  F : out Boolean;                    --  Status flag
2367
2368       Append_List_To (Params, New_List (
2369
2370         Make_Parameter_Specification (Loc,
2371           Defining_Identifier =>
2372             Make_Defining_Identifier (Loc, Name_uT),
2373           Parameter_Type =>
2374             New_Reference_To (Typ, Loc),
2375           In_Present  => True,
2376           Out_Present => True),
2377
2378         Make_Parameter_Specification (Loc,
2379           Defining_Identifier =>
2380             Make_Defining_Identifier (Loc, Name_uS),
2381           Parameter_Type =>
2382             New_Reference_To (Standard_Integer, Loc)),
2383
2384         Make_Parameter_Specification (Loc,
2385           Defining_Identifier =>
2386             Make_Defining_Identifier (Loc, Name_uP),
2387           Parameter_Type =>
2388             New_Reference_To (RTE (RE_Address), Loc)),
2389
2390         Make_Parameter_Specification (Loc,
2391           Defining_Identifier =>
2392             Make_Defining_Identifier (Loc, Name_uB),
2393           Parameter_Type =>
2394             New_Reference_To (RTE (RE_Dummy_Communication_Block), Loc),
2395           Out_Present => True),
2396
2397         Make_Parameter_Specification (Loc,
2398           Defining_Identifier =>
2399             Make_Defining_Identifier (Loc, Name_uF),
2400           Parameter_Type =>
2401             New_Reference_To (Standard_Boolean, Loc),
2402           Out_Present => True)));
2403
2404       return
2405         Make_Procedure_Specification (Loc,
2406           Defining_Unit_Name       => Def_Id,
2407           Parameter_Specifications => Params);
2408    end Make_Disp_Asynchronous_Select_Spec;
2409
2410    ---------------------------------------
2411    -- Make_Disp_Conditional_Select_Body --
2412    ---------------------------------------
2413
2414    --  For interface types, generate:
2415
2416    --     procedure _Disp_Conditional_Select
2417    --       (T : in out <Typ>;
2418    --        S : Integer;
2419    --        P : System.Address;
2420    --        C : out Ada.Tags.Prim_Op_Kind;
2421    --        F : out Boolean)
2422    --     is
2423    --     begin
2424    --        F := False;
2425    --        C := Ada.Tags.POK_Function;
2426    --     end _Disp_Conditional_Select;
2427
2428    --  For protected types, generate:
2429
2430    --     procedure _Disp_Conditional_Select
2431    --       (T : in out <Typ>;
2432    --        S : Integer;
2433    --        P : System.Address;
2434    --        C : out Ada.Tags.Prim_Op_Kind;
2435    --        F : out Boolean)
2436    --     is
2437    --        I   : Integer;
2438    --        Bnn : System.Tasking.Protected_Objects.Operations.
2439    --                Communication_Block;
2440
2441    --     begin
2442    --        C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
2443
2444    --        if C = Ada.Tags.POK_Procedure
2445    --          or else C = Ada.Tags.POK_Protected_Procedure
2446    --          or else C = Ada.Tags.POK_Task_Procedure
2447    --        then
2448    --           F := True;
2449    --           return;
2450    --        end if;
2451
2452    --        I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2453    --        System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2454    --          (T.object'Access,
2455    --           System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2456    --           P,
2457    --           System.Tasking.Conditional_Call,
2458    --           Bnn);
2459    --        F := not Cancelled (Bnn);
2460    --     end _Disp_Conditional_Select;
2461
2462    --  For task types, generate:
2463
2464    --     procedure _Disp_Conditional_Select
2465    --       (T : in out <Typ>;
2466    --        S : Integer;
2467    --        P : System.Address;
2468    --        C : out Ada.Tags.Prim_Op_Kind;
2469    --        F : out Boolean)
2470    --     is
2471    --        I : Integer;
2472
2473    --     begin
2474    --        I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2475    --        System.Tasking.Rendezvous.Task_Entry_Call
2476    --          (T._task_id,
2477    --           System.Tasking.Task_Entry_Index (I),
2478    --           P,
2479    --           System.Tasking.Conditional_Call,
2480    --           F);
2481    --     end _Disp_Conditional_Select;
2482
2483    function Make_Disp_Conditional_Select_Body
2484      (Typ : Entity_Id) return Node_Id
2485    is
2486       Loc      : constant Source_Ptr := Sloc (Typ);
2487       Blk_Nam  : Entity_Id;
2488       Conc_Typ : Entity_Id           := Empty;
2489       Decls    : constant List_Id    := New_List;
2490       Obj_Ref  : Node_Id;
2491       Stmts    : constant List_Id    := New_List;
2492       Tag_Node : Node_Id;
2493
2494    begin
2495       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2496
2497       --  Null body is generated for interface types
2498
2499       if Is_Interface (Typ) then
2500          return
2501            Make_Subprogram_Body (Loc,
2502              Specification =>
2503                Make_Disp_Conditional_Select_Spec (Typ),
2504              Declarations =>
2505                No_List,
2506              Handled_Statement_Sequence =>
2507                Make_Handled_Sequence_Of_Statements (Loc,
2508                  New_List (Make_Assignment_Statement (Loc,
2509                    Name       => Make_Identifier (Loc, Name_uF),
2510                    Expression => New_Reference_To (Standard_False, Loc)))));
2511       end if;
2512
2513       if Is_Concurrent_Record_Type (Typ) then
2514          Conc_Typ := Corresponding_Concurrent_Type (Typ);
2515
2516          --  Generate:
2517          --    I : Integer;
2518
2519          --  where I will be used to capture the entry index of the primitive
2520          --  wrapper at position S.
2521
2522          Append_To (Decls,
2523            Make_Object_Declaration (Loc,
2524              Defining_Identifier =>
2525                Make_Defining_Identifier (Loc, Name_uI),
2526              Object_Definition =>
2527                New_Reference_To (Standard_Integer, Loc)));
2528
2529          --  Generate:
2530          --    C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2531
2532          --    if C = POK_Procedure
2533          --      or else C = POK_Protected_Procedure
2534          --      or else C = POK_Task_Procedure;
2535          --    then
2536          --       F := True;
2537          --       return;
2538          --    end if;
2539
2540          Build_Common_Dispatching_Select_Statements (Typ, Stmts);
2541
2542          --  Generate:
2543          --    Bnn : Communication_Block;
2544
2545          --  where Bnn is the name of the communication block used in the
2546          --  call to Protected_Entry_Call.
2547
2548          Blk_Nam := Make_Temporary (Loc, 'B');
2549          Append_To (Decls,
2550            Make_Object_Declaration (Loc,
2551              Defining_Identifier =>
2552                Blk_Nam,
2553              Object_Definition =>
2554                New_Reference_To (RTE (RE_Communication_Block), Loc)));
2555
2556          --  Generate:
2557          --    I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2558
2559          --  I is the entry index and S is the dispatch table slot
2560
2561          if Tagged_Type_Expansion then
2562             Tag_Node :=
2563               Unchecked_Convert_To (RTE (RE_Tag),
2564                 New_Reference_To
2565                   (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2566
2567          else
2568             Tag_Node :=
2569               Make_Attribute_Reference (Loc,
2570                 Prefix => New_Reference_To (Typ, Loc),
2571                 Attribute_Name => Name_Tag);
2572          end if;
2573
2574          Append_To (Stmts,
2575            Make_Assignment_Statement (Loc,
2576              Name => Make_Identifier (Loc, Name_uI),
2577              Expression =>
2578                Make_Function_Call (Loc,
2579                  Name =>
2580                    New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
2581                  Parameter_Associations =>
2582                    New_List (
2583                      Tag_Node,
2584                      Make_Identifier (Loc, Name_uS)))));
2585
2586          if Ekind (Conc_Typ) = E_Protected_Type then
2587
2588             Obj_Ref :=                                  -- T._object'Access
2589                Make_Attribute_Reference (Loc,
2590                  Attribute_Name => Name_Unchecked_Access,
2591                  Prefix         =>
2592                    Make_Selected_Component (Loc,
2593                      Prefix        => Make_Identifier (Loc, Name_uT),
2594                      Selector_Name => Make_Identifier (Loc, Name_uObject)));
2595
2596             case Corresponding_Runtime_Package (Conc_Typ) is
2597                when System_Tasking_Protected_Objects_Entries =>
2598                   --  Generate:
2599
2600                   --    Protected_Entry_Call
2601                   --      (T._object'Access,            --  Object
2602                   --       Protected_Entry_Index! (I),  --  E
2603                   --       P,                           --  Uninterpreted_Data
2604                   --       Conditional_Call,            --  Mode
2605                   --       Bnn);                        --  Block
2606
2607                   --  where T is the protected object, I is the entry index, P
2608                   --  are the wrapped parameters and Bnn is the name of the
2609                   --  communication block.
2610
2611                   Append_To (Stmts,
2612                     Make_Procedure_Call_Statement (Loc,
2613                       Name =>
2614                         New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
2615                       Parameter_Associations =>
2616                         New_List (
2617                           Obj_Ref,
2618
2619                           Make_Unchecked_Type_Conversion (Loc,  --  entry index
2620                             Subtype_Mark =>
2621                               New_Reference_To
2622                                  (RTE (RE_Protected_Entry_Index), Loc),
2623                             Expression => Make_Identifier (Loc, Name_uI)),
2624
2625                           Make_Identifier (Loc, Name_uP),  --  parameter block
2626
2627                           New_Reference_To (               --  Conditional_Call
2628                             RTE (RE_Conditional_Call), Loc),
2629                           New_Reference_To (               --  Bnn
2630                             Blk_Nam, Loc))));
2631
2632                when System_Tasking_Protected_Objects_Single_Entry =>
2633
2634                   --    If we are compiling for a restricted run-time, the call
2635                   --    uses the simpler form.
2636
2637                   Append_To (Stmts,
2638                     Make_Procedure_Call_Statement (Loc,
2639                       Name =>
2640                         New_Reference_To
2641                           (RTE (RE_Protected_Single_Entry_Call), Loc),
2642                       Parameter_Associations =>
2643                         New_List (
2644                           Obj_Ref,
2645
2646                           Make_Attribute_Reference (Loc,
2647                             Prefix         => Make_Identifier (Loc, Name_uP),
2648                             Attribute_Name => Name_Address),
2649
2650                             New_Reference_To
2651                              (RTE (RE_Conditional_Call), Loc))));
2652                when others =>
2653                   raise Program_Error;
2654             end case;
2655
2656             --  Generate:
2657             --    F := not Cancelled (Bnn);
2658
2659             --  where F is the success flag. The status of Cancelled is negated
2660             --  in order to match the behaviour of the version for task types.
2661
2662             Append_To (Stmts,
2663               Make_Assignment_Statement (Loc,
2664                 Name       => Make_Identifier (Loc, Name_uF),
2665                 Expression =>
2666                   Make_Op_Not (Loc,
2667                     Right_Opnd =>
2668                       Make_Function_Call (Loc,
2669                         Name =>
2670                           New_Reference_To (RTE (RE_Cancelled), Loc),
2671                         Parameter_Associations =>
2672                           New_List (
2673                             New_Reference_To (Blk_Nam, Loc))))));
2674          else
2675             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2676
2677             --  Generate:
2678             --    Task_Entry_Call
2679             --      (T._task_id,             --  Acceptor
2680             --       Task_Entry_Index! (I),  --  E
2681             --       P,                      --  Uninterpreted_Data
2682             --       Conditional_Call,       --  Mode
2683             --       F);                     --  Rendezvous_Successful
2684
2685             --  where T is the task object, I is the entry index, P are the
2686             --  wrapped parameters and F is the status flag.
2687
2688             Append_To (Stmts,
2689               Make_Procedure_Call_Statement (Loc,
2690                 Name =>
2691                   New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
2692                 Parameter_Associations =>
2693                   New_List (
2694
2695                     Make_Selected_Component (Loc,         -- T._task_id
2696                       Prefix        => Make_Identifier (Loc, Name_uT),
2697                       Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2698
2699                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
2700                       Subtype_Mark =>
2701                         New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2702                       Expression   => Make_Identifier (Loc, Name_uI)),
2703
2704                     Make_Identifier (Loc, Name_uP),       --  parameter block
2705                     New_Reference_To                      --  Conditional_Call
2706                       (RTE (RE_Conditional_Call), Loc),
2707                     Make_Identifier (Loc, Name_uF))));    --  status flag
2708          end if;
2709
2710       else
2711          --  Initialize out parameters
2712
2713          Append_To (Stmts,
2714            Make_Assignment_Statement (Loc,
2715              Name       => Make_Identifier (Loc, Name_uF),
2716              Expression => New_Reference_To (Standard_False, Loc)));
2717          Append_To (Stmts,
2718            Make_Assignment_Statement (Loc,
2719              Name       => Make_Identifier (Loc, Name_uC),
2720              Expression => New_Reference_To (RTE (RE_POK_Function), Loc)));
2721       end if;
2722
2723       return
2724         Make_Subprogram_Body (Loc,
2725           Specification              =>
2726             Make_Disp_Conditional_Select_Spec (Typ),
2727           Declarations               => Decls,
2728           Handled_Statement_Sequence =>
2729             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2730    end Make_Disp_Conditional_Select_Body;
2731
2732    ---------------------------------------
2733    -- Make_Disp_Conditional_Select_Spec --
2734    ---------------------------------------
2735
2736    function Make_Disp_Conditional_Select_Spec
2737      (Typ : Entity_Id) return Node_Id
2738    is
2739       Loc    : constant Source_Ptr := Sloc (Typ);
2740       Def_Id : constant Node_Id    :=
2741                  Make_Defining_Identifier (Loc,
2742                    Name_uDisp_Conditional_Select);
2743       Params : constant List_Id    := New_List;
2744
2745    begin
2746       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2747
2748       --  T : in out Typ;        --  Object parameter
2749       --  S : Integer;           --  Primitive operation slot
2750       --  P : Address;           --  Wrapped parameters
2751       --  C : out Prim_Op_Kind;  --  Call kind
2752       --  F : out Boolean;       --  Status flag
2753
2754       Append_List_To (Params, New_List (
2755
2756         Make_Parameter_Specification (Loc,
2757           Defining_Identifier =>
2758             Make_Defining_Identifier (Loc, Name_uT),
2759           Parameter_Type =>
2760             New_Reference_To (Typ, Loc),
2761           In_Present  => True,
2762           Out_Present => True),
2763
2764         Make_Parameter_Specification (Loc,
2765           Defining_Identifier =>
2766             Make_Defining_Identifier (Loc, Name_uS),
2767           Parameter_Type =>
2768             New_Reference_To (Standard_Integer, Loc)),
2769
2770         Make_Parameter_Specification (Loc,
2771           Defining_Identifier =>
2772             Make_Defining_Identifier (Loc, Name_uP),
2773           Parameter_Type =>
2774             New_Reference_To (RTE (RE_Address), Loc)),
2775
2776         Make_Parameter_Specification (Loc,
2777           Defining_Identifier =>
2778             Make_Defining_Identifier (Loc, Name_uC),
2779           Parameter_Type =>
2780             New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
2781           Out_Present => True),
2782
2783         Make_Parameter_Specification (Loc,
2784           Defining_Identifier =>
2785             Make_Defining_Identifier (Loc, Name_uF),
2786           Parameter_Type =>
2787             New_Reference_To (Standard_Boolean, Loc),
2788           Out_Present => True)));
2789
2790       return
2791         Make_Procedure_Specification (Loc,
2792           Defining_Unit_Name       => Def_Id,
2793           Parameter_Specifications => Params);
2794    end Make_Disp_Conditional_Select_Spec;
2795
2796    -------------------------------------
2797    -- Make_Disp_Get_Prim_Op_Kind_Body --
2798    -------------------------------------
2799
2800    function Make_Disp_Get_Prim_Op_Kind_Body
2801      (Typ : Entity_Id) return Node_Id
2802    is
2803       Loc      : constant Source_Ptr := Sloc (Typ);
2804       Tag_Node : Node_Id;
2805
2806    begin
2807       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2808
2809       if Is_Interface (Typ) then
2810          return
2811            Make_Subprogram_Body (Loc,
2812              Specification =>
2813                Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2814              Declarations =>
2815                New_List,
2816              Handled_Statement_Sequence =>
2817                Make_Handled_Sequence_Of_Statements (Loc,
2818                  New_List (Make_Null_Statement (Loc))));
2819       end if;
2820
2821       --  Generate:
2822       --    C := get_prim_op_kind (tag! (<type>VP), S);
2823
2824       --  where C is the out parameter capturing the call kind and S is the
2825       --  dispatch table slot number.
2826
2827       if Tagged_Type_Expansion then
2828          Tag_Node :=
2829            Unchecked_Convert_To (RTE (RE_Tag),
2830              New_Reference_To
2831               (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2832
2833       else
2834          Tag_Node :=
2835            Make_Attribute_Reference (Loc,
2836              Prefix => New_Reference_To (Typ, Loc),
2837              Attribute_Name => Name_Tag);
2838       end if;
2839
2840       return
2841         Make_Subprogram_Body (Loc,
2842           Specification =>
2843             Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2844           Declarations =>
2845             New_List,
2846           Handled_Statement_Sequence =>
2847             Make_Handled_Sequence_Of_Statements (Loc,
2848               New_List (
2849                 Make_Assignment_Statement (Loc,
2850                   Name =>
2851                     Make_Identifier (Loc, Name_uC),
2852                   Expression =>
2853                     Make_Function_Call (Loc,
2854                       Name =>
2855                         New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc),
2856                       Parameter_Associations => New_List (
2857                         Tag_Node,
2858                         Make_Identifier (Loc, Name_uS)))))));
2859    end Make_Disp_Get_Prim_Op_Kind_Body;
2860
2861    -------------------------------------
2862    -- Make_Disp_Get_Prim_Op_Kind_Spec --
2863    -------------------------------------
2864
2865    function Make_Disp_Get_Prim_Op_Kind_Spec
2866      (Typ : Entity_Id) return Node_Id
2867    is
2868       Loc    : constant Source_Ptr := Sloc (Typ);
2869       Def_Id : constant Node_Id    :=
2870                  Make_Defining_Identifier (Loc,
2871                    Name_uDisp_Get_Prim_Op_Kind);
2872       Params : constant List_Id    := New_List;
2873
2874    begin
2875       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2876
2877       --  T : in out Typ;       --  Object parameter
2878       --  S : Integer;          --  Primitive operation slot
2879       --  C : out Prim_Op_Kind; --  Call kind
2880
2881       Append_List_To (Params, New_List (
2882
2883         Make_Parameter_Specification (Loc,
2884           Defining_Identifier =>
2885             Make_Defining_Identifier (Loc, Name_uT),
2886           Parameter_Type =>
2887             New_Reference_To (Typ, Loc),
2888           In_Present  => True,
2889           Out_Present => True),
2890
2891         Make_Parameter_Specification (Loc,
2892           Defining_Identifier =>
2893             Make_Defining_Identifier (Loc, Name_uS),
2894           Parameter_Type =>
2895             New_Reference_To (Standard_Integer, Loc)),
2896
2897         Make_Parameter_Specification (Loc,
2898           Defining_Identifier =>
2899             Make_Defining_Identifier (Loc, Name_uC),
2900           Parameter_Type =>
2901             New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
2902           Out_Present => True)));
2903
2904       return
2905         Make_Procedure_Specification (Loc,
2906            Defining_Unit_Name       => Def_Id,
2907            Parameter_Specifications => Params);
2908    end Make_Disp_Get_Prim_Op_Kind_Spec;
2909
2910    --------------------------------
2911    -- Make_Disp_Get_Task_Id_Body --
2912    --------------------------------
2913
2914    function Make_Disp_Get_Task_Id_Body
2915      (Typ : Entity_Id) return Node_Id
2916    is
2917       Loc : constant Source_Ptr := Sloc (Typ);
2918       Ret : Node_Id;
2919
2920    begin
2921       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2922
2923       if Is_Concurrent_Record_Type (Typ)
2924         and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
2925       then
2926          --  Generate:
2927          --    return To_Address (_T._task_id);
2928
2929          Ret :=
2930            Make_Simple_Return_Statement (Loc,
2931              Expression =>
2932                Make_Unchecked_Type_Conversion (Loc,
2933                  Subtype_Mark =>
2934                    New_Reference_To (RTE (RE_Address), Loc),
2935                  Expression =>
2936                    Make_Selected_Component (Loc,
2937                      Prefix        => Make_Identifier (Loc, Name_uT),
2938                      Selector_Name => Make_Identifier (Loc, Name_uTask_Id))));
2939
2940       --  A null body is constructed for non-task types
2941
2942       else
2943          --  Generate:
2944          --    return Null_Address;
2945
2946          Ret :=
2947            Make_Simple_Return_Statement (Loc,
2948              Expression =>
2949                New_Reference_To (RTE (RE_Null_Address), Loc));
2950       end if;
2951
2952       return
2953         Make_Subprogram_Body (Loc,
2954           Specification =>
2955             Make_Disp_Get_Task_Id_Spec (Typ),
2956           Declarations =>
2957             New_List,
2958           Handled_Statement_Sequence =>
2959             Make_Handled_Sequence_Of_Statements (Loc,
2960               New_List (Ret)));
2961    end Make_Disp_Get_Task_Id_Body;
2962
2963    --------------------------------
2964    -- Make_Disp_Get_Task_Id_Spec --
2965    --------------------------------
2966
2967    function Make_Disp_Get_Task_Id_Spec
2968      (Typ : Entity_Id) return Node_Id
2969    is
2970       Loc : constant Source_Ptr := Sloc (Typ);
2971
2972    begin
2973       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2974
2975       return
2976         Make_Function_Specification (Loc,
2977           Defining_Unit_Name =>
2978             Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
2979           Parameter_Specifications => New_List (
2980             Make_Parameter_Specification (Loc,
2981               Defining_Identifier =>
2982                 Make_Defining_Identifier (Loc, Name_uT),
2983               Parameter_Type =>
2984                 New_Reference_To (Typ, Loc))),
2985           Result_Definition =>
2986             New_Reference_To (RTE (RE_Address), Loc));
2987    end Make_Disp_Get_Task_Id_Spec;
2988
2989    ----------------------------
2990    -- Make_Disp_Requeue_Body --
2991    ----------------------------
2992
2993    function Make_Disp_Requeue_Body
2994      (Typ : Entity_Id) return Node_Id
2995    is
2996       Loc      : constant Source_Ptr := Sloc (Typ);
2997       Conc_Typ : Entity_Id           := Empty;
2998       Stmts    : constant List_Id    := New_List;
2999
3000    begin
3001       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3002
3003       --  Null body is generated for interface types and non-concurrent
3004       --  tagged types.
3005
3006       if Is_Interface (Typ)
3007         or else not Is_Concurrent_Record_Type (Typ)
3008       then
3009          return
3010            Make_Subprogram_Body (Loc,
3011              Specification =>
3012                Make_Disp_Requeue_Spec (Typ),
3013              Declarations =>
3014                No_List,
3015              Handled_Statement_Sequence =>
3016                Make_Handled_Sequence_Of_Statements (Loc,
3017                  New_List (Make_Null_Statement (Loc))));
3018       end if;
3019
3020       Conc_Typ := Corresponding_Concurrent_Type (Typ);
3021
3022       if Ekind (Conc_Typ) = E_Protected_Type then
3023
3024          --  Generate statements:
3025          --    if F then
3026          --       System.Tasking.Protected_Objects.Operations.
3027          --         Requeue_Protected_Entry
3028          --           (Protection_Entries_Access (P),
3029          --            O._object'Unchecked_Access,
3030          --            Protected_Entry_Index (I),
3031          --            A);
3032          --    else
3033          --       System.Tasking.Protected_Objects.Operations.
3034          --         Requeue_Task_To_Protected_Entry
3035          --           (O._object'Unchecked_Access,
3036          --            Protected_Entry_Index (I),
3037          --            A);
3038          --    end if;
3039
3040          if Restriction_Active (No_Entry_Queue) then
3041             Append_To (Stmts, Make_Null_Statement (Loc));
3042          else
3043             Append_To (Stmts,
3044               Make_If_Statement (Loc,
3045                 Condition       => Make_Identifier (Loc, Name_uF),
3046
3047                 Then_Statements =>
3048                   New_List (
3049
3050                      --  Call to Requeue_Protected_Entry
3051
3052                     Make_Procedure_Call_Statement (Loc,
3053                       Name =>
3054                         New_Reference_To (
3055                           RTE (RE_Requeue_Protected_Entry), Loc),
3056                       Parameter_Associations =>
3057                         New_List (
3058
3059                           Make_Unchecked_Type_Conversion (Loc,  -- PEA (P)
3060                             Subtype_Mark =>
3061                               New_Reference_To (
3062                                 RTE (RE_Protection_Entries_Access), Loc),
3063                             Expression =>
3064                               Make_Identifier (Loc, Name_uP)),
3065
3066                           Make_Attribute_Reference (Loc,      -- O._object'Acc
3067                             Attribute_Name =>
3068                               Name_Unchecked_Access,
3069                             Prefix =>
3070                               Make_Selected_Component (Loc,
3071                                 Prefix        =>
3072                                   Make_Identifier (Loc, Name_uO),
3073                                 Selector_Name =>
3074                                   Make_Identifier (Loc, Name_uObject))),
3075
3076                           Make_Unchecked_Type_Conversion (Loc,  -- entry index
3077                             Subtype_Mark =>
3078                               New_Reference_To (
3079                                 RTE (RE_Protected_Entry_Index), Loc),
3080                             Expression => Make_Identifier (Loc, Name_uI)),
3081
3082                           Make_Identifier (Loc, Name_uA)))),   -- abort status
3083
3084                 Else_Statements =>
3085                   New_List (
3086
3087                      --  Call to Requeue_Task_To_Protected_Entry
3088
3089                     Make_Procedure_Call_Statement (Loc,
3090                       Name =>
3091                         New_Reference_To (
3092                           RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
3093                       Parameter_Associations =>
3094                         New_List (
3095
3096                           Make_Attribute_Reference (Loc,     -- O._object'Acc
3097                             Attribute_Name =>
3098                               Name_Unchecked_Access,
3099                             Prefix =>
3100                               Make_Selected_Component (Loc,
3101                                 Prefix =>
3102                                   Make_Identifier (Loc, Name_uO),
3103                                 Selector_Name =>
3104                                   Make_Identifier (Loc, Name_uObject))),
3105
3106                           Make_Unchecked_Type_Conversion (Loc, -- entry index
3107                             Subtype_Mark =>
3108                               New_Reference_To (
3109                                 RTE (RE_Protected_Entry_Index), Loc),
3110                             Expression =>
3111                               Make_Identifier (Loc, Name_uI)),
3112
3113                           Make_Identifier (Loc, Name_uA)))))); -- abort status
3114          end if;
3115       else
3116          pragma Assert (Is_Task_Type (Conc_Typ));
3117
3118          --  Generate:
3119          --    if F then
3120          --       System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
3121          --         (Protection_Entries_Access (P),
3122          --          O._task_id,
3123          --          Task_Entry_Index (I),
3124          --          A);
3125          --    else
3126          --       System.Tasking.Rendezvous.Requeue_Task_Entry
3127          --         (O._task_id,
3128          --          Task_Entry_Index (I),
3129          --          A);
3130          --    end if;
3131
3132          Append_To (Stmts,
3133            Make_If_Statement (Loc,
3134              Condition       => Make_Identifier (Loc, Name_uF),
3135
3136              Then_Statements => New_List (
3137
3138                --  Call to Requeue_Protected_To_Task_Entry
3139
3140                Make_Procedure_Call_Statement (Loc,
3141                  Name =>
3142                    New_Reference_To
3143                      (RTE (RE_Requeue_Protected_To_Task_Entry), Loc),
3144
3145                  Parameter_Associations => New_List (
3146
3147                    Make_Unchecked_Type_Conversion (Loc,  -- PEA (P)
3148                      Subtype_Mark =>
3149                        New_Reference_To
3150                          (RTE (RE_Protection_Entries_Access), Loc),
3151                           Expression => Make_Identifier (Loc, Name_uP)),
3152
3153                    Make_Selected_Component (Loc,         -- O._task_id
3154                      Prefix        => Make_Identifier (Loc, Name_uO),
3155                      Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3156
3157                    Make_Unchecked_Type_Conversion (Loc,  -- entry index
3158                      Subtype_Mark =>
3159                        New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
3160                      Expression   => Make_Identifier (Loc, Name_uI)),
3161
3162                    Make_Identifier (Loc, Name_uA)))),    -- abort status
3163
3164              Else_Statements => New_List (
3165
3166                --  Call to Requeue_Task_Entry
3167
3168                Make_Procedure_Call_Statement (Loc,
3169                  Name => New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc),
3170
3171                  Parameter_Associations => New_List (
3172
3173                    Make_Selected_Component (Loc,         -- O._task_id
3174                      Prefix        => Make_Identifier (Loc, Name_uO),
3175                      Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3176
3177                    Make_Unchecked_Type_Conversion (Loc,  -- entry index
3178                      Subtype_Mark =>
3179                        New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
3180                      Expression   => Make_Identifier (Loc, Name_uI)),
3181
3182                    Make_Identifier (Loc, Name_uA))))));  -- abort status
3183       end if;
3184
3185       --  Even though no declarations are needed in both cases, we allocate
3186       --  a list for entities added by Freeze.
3187
3188       return
3189         Make_Subprogram_Body (Loc,
3190           Specification =>
3191             Make_Disp_Requeue_Spec (Typ),
3192           Declarations =>
3193             New_List,
3194           Handled_Statement_Sequence =>
3195             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3196    end Make_Disp_Requeue_Body;
3197
3198    ----------------------------
3199    -- Make_Disp_Requeue_Spec --
3200    ----------------------------
3201
3202    function Make_Disp_Requeue_Spec
3203      (Typ : Entity_Id) return Node_Id
3204    is
3205       Loc : constant Source_Ptr := Sloc (Typ);
3206
3207    begin
3208       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3209
3210       --  O : in out Typ;   -  Object parameter
3211       --  F : Boolean;      -  Protected (True) / task (False) flag
3212       --  P : Address;      -  Protection_Entries_Access value
3213       --  I : Entry_Index   -  Index of entry call
3214       --  A : Boolean       -  Abort flag