| ee6ba406 |
1 | ------------------------------------------------------------------------------ |
| 2 | -- -- |
| 3 | -- GNAT COMPILER COMPONENTS -- |
| 4 | -- -- |
| 5 | -- E X P _ D I S P -- |
| 6 | -- -- |
| 7 | -- B o d y -- |
| 8 | -- -- |
| 9ced80be |
9 | -- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- |
| ee6ba406 |
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- -- |
| 24971415 |
13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| ee6ba406 |
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 -- |
| 24971415 |
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. -- |
| ee6ba406 |
20 | -- -- |
| 21 | -- GNAT was originally developed by the GNAT team at New York University. -- |
| e78e8c8e |
22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| ee6ba406 |
23 | -- -- |
| 24 | ------------------------------------------------------------------------------ |
| 25 | |
| 26 | with Atree; use Atree; |
| 27 | with Checks; use Checks; |
| aad6babd |
28 | with Debug; use Debug; |
| ee6ba406 |
29 | with Einfo; use Einfo; |
| 30 | with Elists; use Elists; |
| 31 | with Errout; use Errout; |
| 343d35dc |
32 | with Exp_Atag; use Exp_Atag; |
| ee6ba406 |
33 | with Exp_Ch7; use Exp_Ch7; |
| 76a1c25b |
34 | with Exp_Dbug; use Exp_Dbug; |
| ee6ba406 |
35 | with Exp_Tss; use Exp_Tss; |
| 36 | with Exp_Util; use Exp_Util; |
| af647dc7 |
37 | with Freeze; use Freeze; |
| ee6ba406 |
38 | with Itypes; use Itypes; |
| ee6ba406 |
39 | with Nlists; use Nlists; |
| 40 | with Nmake; use Nmake; |
| aad6babd |
41 | with Namet; use Namet; |
| ee6ba406 |
42 | with Opt; use Opt; |
| aad6babd |
43 | with Output; use Output; |
| 68f95949 |
44 | with Restrict; use Restrict; |
| 45 | with Rident; use Rident; |
| ee6ba406 |
46 | with Rtsfind; use Rtsfind; |
| aad6babd |
47 | with Sem; use Sem; |
| 725a69d2 |
48 | with Sem_Ch6; use Sem_Ch6; |
| acf97c11 |
49 | with Sem_Ch7; use Sem_Ch7; |
| 725a69d2 |
50 | with Sem_Ch8; use Sem_Ch8; |
| ee6ba406 |
51 | with Sem_Disp; use Sem_Disp; |
| 725a69d2 |
52 | with Sem_Eval; use Sem_Eval; |
| ee6ba406 |
53 | with Sem_Res; use Sem_Res; |
| aad6babd |
54 | with Sem_Type; use Sem_Type; |
| ee6ba406 |
55 | with Sem_Util; use Sem_Util; |
| 56 | with Sinfo; use Sinfo; |
| 57 | with Snames; use Snames; |
| 58 | with Stand; use Stand; |
| 725a69d2 |
59 | with Stringt; use Stringt; |
| 60 | with Targparm; use Targparm; |
| ee6ba406 |
61 | with Tbuild; use Tbuild; |
| 62 | with Uintp; use Uintp; |
| 63 | |
| 64 | package body Exp_Disp is |
| 65 | |
| 725a69d2 |
66 | ----------------------- |
| 67 | -- Local Subprograms -- |
| 68 | ----------------------- |
| ee6ba406 |
69 | |
| 68f95949 |
70 | function Default_Prim_Op_Position (E : Entity_Id) return Uint; |
| aad6babd |
71 | -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table |
| 72 | -- of the default primitive operations. |
| 73 | |
| 24971415 |
74 | function Has_DT (Typ : Entity_Id) return Boolean; |
| 75 | pragma Inline (Has_DT); |
| 76 | -- Returns true if we generate a dispatch table for tagged type Typ |
| 77 | |
| af647dc7 |
78 | function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean; |
| 79 | -- Returns true if Prim is not a predefined dispatching primitive but it is |
| 36b938a3 |
80 | -- an alias of a predefined dispatching primitive (i.e. through a renaming) |
| af647dc7 |
81 | |
| ee6ba406 |
82 | function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; |
| 83 | -- Check if the type has a private view or if the public view appears |
| 84 | -- in the visible part of a package spec. |
| 85 | |
| d62940bf |
86 | function Prim_Op_Kind |
| 87 | (Prim : Entity_Id; |
| 88 | Typ : Entity_Id) return Node_Id; |
| 89 | -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim |
| 952af0b9 |
90 | -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind |
| d62940bf |
91 | -- enumeration value. |
| aad6babd |
92 | |
| 952af0b9 |
93 | function Tagged_Kind (T : Entity_Id) return Node_Id; |
| 94 | -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference |
| 95 | -- to an RE_Tagged_Kind enumeration value. |
| 96 | |
| 24971415 |
97 | ------------------------ |
| 98 | -- Building_Static_DT -- |
| 99 | ------------------------ |
| 100 | |
| 101 | function Building_Static_DT (Typ : Entity_Id) return Boolean is |
| cc60bd16 |
102 | Root_Typ : Entity_Id := Root_Type (Typ); |
| 103 | |
| 24971415 |
104 | begin |
| cc60bd16 |
105 | -- Handle private types |
| 106 | |
| 107 | if Present (Full_View (Root_Typ)) then |
| 108 | Root_Typ := Full_View (Root_Typ); |
| 109 | end if; |
| 110 | |
| 24971415 |
111 | return Static_Dispatch_Tables |
| e7e688dd |
112 | and then Is_Library_Level_Tagged_Type (Typ) |
| 113 | |
| 114 | -- If the type is derived from a CPP class we cannot statically |
| 115 | -- build the dispatch tables because we must inherit primitives |
| 116 | -- from the CPP side. |
| 117 | |
| cc60bd16 |
118 | and then not Is_CPP_Class (Root_Typ); |
| 24971415 |
119 | end Building_Static_DT; |
| 120 | |
| 17e14451 |
121 | ---------------------------------- |
| 122 | -- Build_Static_Dispatch_Tables -- |
| 123 | ---------------------------------- |
| 124 | |
| 125 | procedure Build_Static_Dispatch_Tables (N : Entity_Id) is |
| 126 | Target_List : List_Id; |
| 127 | |
| 128 | procedure Build_Dispatch_Tables (List : List_Id); |
| 129 | -- Build the static dispatch table of tagged types found in the list of |
| 130 | -- declarations. The generated nodes are added at the end of Target_List |
| 131 | |
| 132 | procedure Build_Package_Dispatch_Tables (N : Node_Id); |
| 133 | -- Build static dispatch tables associated with package declaration N |
| 134 | |
| 135 | --------------------------- |
| 136 | -- Build_Dispatch_Tables -- |
| 137 | --------------------------- |
| 138 | |
| 139 | procedure Build_Dispatch_Tables (List : List_Id) is |
| 140 | D : Node_Id; |
| 141 | |
| 142 | begin |
| 143 | D := First (List); |
| 144 | while Present (D) loop |
| 145 | |
| 146 | -- Handle nested packages and package bodies recursively. The |
| 147 | -- generated code is placed on the Target_List established for |
| 148 | -- the enclosing compilation unit. |
| 149 | |
| 150 | if Nkind (D) = N_Package_Declaration then |
| 151 | Build_Package_Dispatch_Tables (D); |
| 152 | |
| 153 | elsif Nkind (D) = N_Package_Body then |
| 154 | Build_Dispatch_Tables (Declarations (D)); |
| 155 | |
| 156 | elsif Nkind (D) = N_Package_Body_Stub |
| 157 | and then Present (Library_Unit (D)) |
| 158 | then |
| 159 | Build_Dispatch_Tables |
| 160 | (Declarations (Proper_Body (Unit (Library_Unit (D))))); |
| 161 | |
| 162 | -- Handle full type declarations and derivations of library |
| 163 | -- level tagged types |
| 164 | |
| 165 | elsif (Nkind (D) = N_Full_Type_Declaration |
| 166 | or else Nkind (D) = N_Derived_Type_Definition) |
| 167 | and then Is_Library_Level_Tagged_Type (Defining_Entity (D)) |
| 168 | and then Ekind (Defining_Entity (D)) /= E_Record_Subtype |
| 169 | and then not Is_Private_Type (Defining_Entity (D)) |
| 170 | then |
| 171 | Insert_List_After_And_Analyze (Last (Target_List), |
| 172 | Make_DT (Defining_Entity (D))); |
| 173 | |
| 174 | -- Handle private types of library level tagged types. We must |
| 175 | -- exchange the private and full-view to ensure the correct |
| 176 | -- expansion. |
| 177 | |
| 178 | elsif (Nkind (D) = N_Private_Type_Declaration |
| 179 | or else Nkind (D) = N_Private_Extension_Declaration) |
| 180 | and then Present (Full_View (Defining_Entity (D))) |
| 181 | and then Is_Library_Level_Tagged_Type |
| 182 | (Full_View (Defining_Entity (D))) |
| 183 | and then Ekind (Full_View (Defining_Entity (D))) |
| 184 | /= E_Record_Subtype |
| 185 | then |
| 186 | declare |
| acf97c11 |
187 | E1 : constant Entity_Id := Defining_Entity (D); |
| 188 | E2 : constant Entity_Id := Full_View (Defining_Entity (D)); |
| 189 | |
| 17e14451 |
190 | begin |
| acf97c11 |
191 | Exchange_Declarations (E1); |
| 17e14451 |
192 | Insert_List_After_And_Analyze (Last (Target_List), |
| 193 | Make_DT (E1)); |
| acf97c11 |
194 | Exchange_Declarations (E2); |
| 17e14451 |
195 | end; |
| 196 | end if; |
| 197 | |
| 198 | Next (D); |
| 199 | end loop; |
| 200 | end Build_Dispatch_Tables; |
| 201 | |
| 202 | ----------------------------------- |
| 203 | -- Build_Package_Dispatch_Tables -- |
| 204 | ----------------------------------- |
| 205 | |
| 206 | procedure Build_Package_Dispatch_Tables (N : Node_Id) is |
| 207 | Spec : constant Node_Id := Specification (N); |
| 208 | Id : constant Entity_Id := Defining_Entity (N); |
| 209 | Vis_Decls : constant List_Id := Visible_Declarations (Spec); |
| 210 | Priv_Decls : constant List_Id := Private_Declarations (Spec); |
| 211 | |
| 212 | begin |
| 213 | Push_Scope (Id); |
| 214 | |
| 215 | if Present (Priv_Decls) then |
| 216 | Build_Dispatch_Tables (Vis_Decls); |
| 217 | Build_Dispatch_Tables (Priv_Decls); |
| 218 | |
| 219 | elsif Present (Vis_Decls) then |
| 220 | Build_Dispatch_Tables (Vis_Decls); |
| 221 | end if; |
| 222 | |
| 223 | Pop_Scope; |
| 224 | end Build_Package_Dispatch_Tables; |
| 225 | |
| 226 | -- Start of processing for Build_Static_Dispatch_Tables |
| 227 | |
| 228 | begin |
| 229 | if not Expander_Active |
| 230 | or else VM_Target /= No_VM |
| 231 | then |
| 232 | return; |
| 233 | end if; |
| 234 | |
| 235 | if Nkind (N) = N_Package_Declaration then |
| 236 | declare |
| 237 | Spec : constant Node_Id := Specification (N); |
| 238 | Vis_Decls : constant List_Id := Visible_Declarations (Spec); |
| 239 | Priv_Decls : constant List_Id := Private_Declarations (Spec); |
| 240 | |
| 241 | begin |
| 242 | if Present (Priv_Decls) |
| 243 | and then Is_Non_Empty_List (Priv_Decls) |
| 244 | then |
| 245 | Target_List := Priv_Decls; |
| 246 | |
| 247 | elsif not Present (Vis_Decls) then |
| 248 | Target_List := New_List; |
| 249 | Set_Private_Declarations (Spec, Target_List); |
| 250 | else |
| 251 | Target_List := Vis_Decls; |
| 252 | end if; |
| 253 | |
| 254 | Build_Package_Dispatch_Tables (N); |
| 255 | end; |
| 256 | |
| 257 | else pragma Assert (Nkind (N) = N_Package_Body); |
| 258 | Target_List := Declarations (N); |
| 259 | Build_Dispatch_Tables (Target_List); |
| 260 | end if; |
| 261 | end Build_Static_Dispatch_Tables; |
| 262 | |
| aad6babd |
263 | ------------------------------ |
| 264 | -- Default_Prim_Op_Position -- |
| 265 | ------------------------------ |
| 266 | |
| 68f95949 |
267 | function Default_Prim_Op_Position (E : Entity_Id) return Uint is |
| aad6babd |
268 | TSS_Name : TSS_Name_Type; |
| aad6babd |
269 | |
| 270 | begin |
| aad6babd |
271 | Get_Name_String (Chars (E)); |
| 272 | TSS_Name := |
| 273 | TSS_Name_Type |
| 274 | (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); |
| 275 | |
| 276 | if Chars (E) = Name_uSize then |
| 277 | return Uint_1; |
| 278 | |
| 279 | elsif Chars (E) = Name_uAlignment then |
| 280 | return Uint_2; |
| 281 | |
| 282 | elsif TSS_Name = TSS_Stream_Read then |
| 283 | return Uint_3; |
| 284 | |
| 285 | elsif TSS_Name = TSS_Stream_Write then |
| 286 | return Uint_4; |
| 287 | |
| 288 | elsif TSS_Name = TSS_Stream_Input then |
| 289 | return Uint_5; |
| 290 | |
| 291 | elsif TSS_Name = TSS_Stream_Output then |
| 292 | return Uint_6; |
| 293 | |
| 294 | elsif Chars (E) = Name_Op_Eq then |
| 295 | return Uint_7; |
| 296 | |
| 297 | elsif Chars (E) = Name_uAssign then |
| 298 | return Uint_8; |
| 299 | |
| 300 | elsif TSS_Name = TSS_Deep_Adjust then |
| 301 | return Uint_9; |
| 302 | |
| 303 | elsif TSS_Name = TSS_Deep_Finalize then |
| 304 | return Uint_10; |
| 305 | |
| 76a1c25b |
306 | elsif Ada_Version >= Ada_05 then |
| 307 | if Chars (E) = Name_uDisp_Asynchronous_Select then |
| 308 | return Uint_11; |
| d62940bf |
309 | |
| 76a1c25b |
310 | elsif Chars (E) = Name_uDisp_Conditional_Select then |
| 311 | return Uint_12; |
| d62940bf |
312 | |
| 76a1c25b |
313 | elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then |
| 314 | return Uint_13; |
| d62940bf |
315 | |
| 76a1c25b |
316 | elsif Chars (E) = Name_uDisp_Get_Task_Id then |
| 317 | return Uint_14; |
| d62940bf |
318 | |
| cdb1c38f |
319 | elsif Chars (E) = Name_uDisp_Requeue then |
| 76a1c25b |
320 | return Uint_15; |
| cdb1c38f |
321 | |
| 322 | elsif Chars (E) = Name_uDisp_Timed_Select then |
| 323 | return Uint_16; |
| 76a1c25b |
324 | end if; |
| aad6babd |
325 | end if; |
| 76a1c25b |
326 | |
| 327 | raise Program_Error; |
| aad6babd |
328 | end Default_Prim_Op_Position; |
| 329 | |
| 7189d17f |
330 | ----------------------------- |
| 331 | -- Expand_Dispatching_Call -- |
| 332 | ----------------------------- |
| ee6ba406 |
333 | |
| 7189d17f |
334 | procedure Expand_Dispatching_Call (Call_Node : Node_Id) is |
| ee6ba406 |
335 | Loc : constant Source_Ptr := Sloc (Call_Node); |
| 336 | Call_Typ : constant Entity_Id := Etype (Call_Node); |
| 337 | |
| 338 | Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); |
| 339 | Param_List : constant List_Id := Parameter_Associations (Call_Node); |
| ee6ba406 |
340 | |
| af647dc7 |
341 | Subp : Entity_Id; |
| 7189d17f |
342 | CW_Typ : Entity_Id; |
| 343 | New_Call : Node_Id; |
| 344 | New_Call_Name : Node_Id; |
| 345 | New_Params : List_Id := No_List; |
| 346 | Param : Node_Id; |
| 347 | Res_Typ : Entity_Id; |
| 348 | Subp_Ptr_Typ : Entity_Id; |
| 349 | Subp_Typ : Entity_Id; |
| 350 | Typ : Entity_Id; |
| 351 | Eq_Prim_Op : Entity_Id := Empty; |
| 352 | Controlling_Tag : Node_Id; |
| ee6ba406 |
353 | |
| 354 | function New_Value (From : Node_Id) return Node_Id; |
| 9dfe12ae |
355 | -- From is the original Expression. New_Value is equivalent to a call |
| 356 | -- to Duplicate_Subexpr with an explicit dereference when From is an |
| 7189d17f |
357 | -- access parameter. |
| 358 | |
| 9dfe12ae |
359 | --------------- |
| 360 | -- New_Value -- |
| 361 | --------------- |
| 362 | |
| ee6ba406 |
363 | function New_Value (From : Node_Id) return Node_Id is |
| 364 | Res : constant Node_Id := Duplicate_Subexpr (From); |
| ee6ba406 |
365 | begin |
| 366 | if Is_Access_Type (Etype (From)) then |
| af647dc7 |
367 | return |
| 368 | Make_Explicit_Dereference (Sloc (From), |
| 369 | Prefix => Res); |
| ee6ba406 |
370 | else |
| 371 | return Res; |
| 372 | end if; |
| 373 | end New_Value; |
| 374 | |
| 7189d17f |
375 | -- Start of processing for Expand_Dispatching_Call |
| ee6ba406 |
376 | |
| 377 | begin |
| 725a69d2 |
378 | if No_Run_Time_Mode then |
| 379 | Error_Msg_CRT ("tagged types", Call_Node); |
| 380 | return; |
| 381 | end if; |
| 382 | |
| 343d35dc |
383 | -- Expand_Dispatching_Call is called directly from the semantics, |
| 384 | -- so we need a check to see whether expansion is active before |
| 385 | -- proceeding. In addition, there is no need to expand the call |
| 386 | -- if we are compiling under restriction No_Dispatching_Calls; |
| 387 | -- the semantic analyzer has previously notified the violation |
| 388 | -- of this restriction. |
| 389 | |
| 390 | if not Expander_Active |
| 391 | or else Restriction_Active (No_Dispatching_Calls) |
| 392 | then |
| 393 | return; |
| 394 | end if; |
| 68f95949 |
395 | |
| af647dc7 |
396 | -- Set subprogram. If this is an inherited operation that was |
| 397 | -- overridden, the body that is being called is its alias. |
| 398 | |
| 399 | Subp := Entity (Name (Call_Node)); |
| ee6ba406 |
400 | |
| 401 | if Present (Alias (Subp)) |
| 402 | and then Is_Inherited_Operation (Subp) |
| 403 | and then No (DTC_Entity (Subp)) |
| 404 | then |
| 405 | Subp := Alias (Subp); |
| 406 | end if; |
| 407 | |
| 7189d17f |
408 | -- Definition of the class-wide type and the tagged type |
| ee6ba406 |
409 | |
| 7189d17f |
410 | -- If the controlling argument is itself a tag rather than a tagged |
| 411 | -- object, then use the class-wide type associated with the subprogram's |
| 412 | -- controlling type. This case can occur when a call to an inherited |
| 413 | -- primitive has an actual that originated from a default parameter |
| 414 | -- given by a tag-indeterminate call and when there is no other |
| 415 | -- controlling argument providing the tag (AI-239 requires dispatching). |
| 416 | -- This capability of dispatching directly by tag is also needed by the |
| 417 | -- implementation of AI-260 (for the generic dispatching constructors). |
| 418 | |
| aad6babd |
419 | if Etype (Ctrl_Arg) = RTE (RE_Tag) |
| 68f95949 |
420 | or else (RTE_Available (RE_Interface_Tag) |
| 421 | and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)) |
| aad6babd |
422 | then |
| af647dc7 |
423 | CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp)); |
| 7189d17f |
424 | |
| 725a69d2 |
425 | -- Class_Wide_Type is applied to the expressions used to initialize |
| 426 | -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since |
| 427 | -- there are cases where the controlling type is resolved to a specific |
| 428 | -- type (such as for designated types of arguments such as CW'Access). |
| 429 | |
| 7189d17f |
430 | elsif Is_Access_Type (Etype (Ctrl_Arg)) then |
| 725a69d2 |
431 | CW_Typ := Class_Wide_Type (Designated_Type (Etype (Ctrl_Arg))); |
| 7189d17f |
432 | |
| ee6ba406 |
433 | else |
| 725a69d2 |
434 | CW_Typ := Class_Wide_Type (Etype (Ctrl_Arg)); |
| ee6ba406 |
435 | end if; |
| 436 | |
| 437 | Typ := Root_Type (CW_Typ); |
| 438 | |
| d62940bf |
439 | if Ekind (Typ) = E_Incomplete_Type then |
| 440 | Typ := Non_Limited_View (Typ); |
| 441 | end if; |
| 442 | |
| ee6ba406 |
443 | if not Is_Limited_Type (Typ) then |
| 444 | Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); |
| 445 | end if; |
| 446 | |
| 343d35dc |
447 | -- Dispatching call to C++ primitive. Create a new parameter list |
| 448 | -- with no tag checks. |
| ee6ba406 |
449 | |
| 343d35dc |
450 | if Is_CPP_Class (Typ) then |
| ee6ba406 |
451 | New_Params := New_List; |
| 452 | Param := First_Actual (Call_Node); |
| 453 | while Present (Param) loop |
| aad6babd |
454 | Append_To (New_Params, Relocate_Node (Param)); |
| ee6ba406 |
455 | Next_Actual (Param); |
| 456 | end loop; |
| 457 | |
| 343d35dc |
458 | -- Dispatching call to Ada primitive |
| 459 | |
| ee6ba406 |
460 | elsif Present (Param_List) then |
| 461 | |
| 462 | -- Generate the Tag checks when appropriate |
| 463 | |
| 464 | New_Params := New_List; |
| ee6ba406 |
465 | Param := First_Actual (Call_Node); |
| 466 | while Present (Param) loop |
| 467 | |
| 468 | -- No tag check with itself |
| 469 | |
| 470 | if Param = Ctrl_Arg then |
| 9dfe12ae |
471 | Append_To (New_Params, |
| 472 | Duplicate_Subexpr_Move_Checks (Param)); |
| ee6ba406 |
473 | |
| 474 | -- No tag check for parameter whose type is neither tagged nor |
| 475 | -- access to tagged (for access parameters) |
| 476 | |
| 477 | elsif No (Find_Controlling_Arg (Param)) then |
| 478 | Append_To (New_Params, Relocate_Node (Param)); |
| 479 | |
| 7189d17f |
480 | -- No tag check for function dispatching on result if the |
| ee6ba406 |
481 | -- Tag given by the context is this one |
| 482 | |
| 483 | elsif Find_Controlling_Arg (Param) = Ctrl_Arg then |
| 484 | Append_To (New_Params, Relocate_Node (Param)); |
| 485 | |
| 486 | -- "=" is the only dispatching operation allowed to get |
| 487 | -- operands with incompatible tags (it just returns false). |
| 9dfe12ae |
488 | -- We use Duplicate_Subexpr_Move_Checks instead of calling |
| 489 | -- Relocate_Node because the value will be duplicated to |
| 490 | -- check the tags. |
| ee6ba406 |
491 | |
| 492 | elsif Subp = Eq_Prim_Op then |
| 9dfe12ae |
493 | Append_To (New_Params, |
| 494 | Duplicate_Subexpr_Move_Checks (Param)); |
| ee6ba406 |
495 | |
| 496 | -- No check in presence of suppress flags |
| 497 | |
| 498 | elsif Tag_Checks_Suppressed (Etype (Param)) |
| 499 | or else (Is_Access_Type (Etype (Param)) |
| 500 | and then Tag_Checks_Suppressed |
| 501 | (Designated_Type (Etype (Param)))) |
| 502 | then |
| 503 | Append_To (New_Params, Relocate_Node (Param)); |
| 504 | |
| 505 | -- Optimization: no tag checks if the parameters are identical |
| 506 | |
| 507 | elsif Is_Entity_Name (Param) |
| 508 | and then Is_Entity_Name (Ctrl_Arg) |
| 509 | and then Entity (Param) = Entity (Ctrl_Arg) |
| 510 | then |
| 511 | Append_To (New_Params, Relocate_Node (Param)); |
| 512 | |
| 513 | -- Now we need to generate the Tag check |
| 514 | |
| 515 | else |
| 516 | -- Generate code for tag equality check |
| 517 | -- Perhaps should have Checks.Apply_Tag_Equality_Check??? |
| 518 | |
| 519 | Insert_Action (Ctrl_Arg, |
| 520 | Make_Implicit_If_Statement (Call_Node, |
| 521 | Condition => |
| 522 | Make_Op_Ne (Loc, |
| 523 | Left_Opnd => |
| 524 | Make_Selected_Component (Loc, |
| 525 | Prefix => New_Value (Ctrl_Arg), |
| 526 | Selector_Name => |
| 4660e715 |
527 | New_Reference_To |
| 528 | (First_Tag_Component (Typ), Loc)), |
| ee6ba406 |
529 | |
| 530 | Right_Opnd => |
| 531 | Make_Selected_Component (Loc, |
| 532 | Prefix => |
| 533 | Unchecked_Convert_To (Typ, New_Value (Param)), |
| 534 | Selector_Name => |
| 4660e715 |
535 | New_Reference_To |
| 536 | (First_Tag_Component (Typ), Loc))), |
| ee6ba406 |
537 | |
| 538 | Then_Statements => |
| 539 | New_List (New_Constraint_Error (Loc)))); |
| 540 | |
| 541 | Append_To (New_Params, Relocate_Node (Param)); |
| 542 | end if; |
| 543 | |
| 544 | Next_Actual (Param); |
| 545 | end loop; |
| 546 | end if; |
| 547 | |
| 548 | -- Generate the appropriate subprogram pointer type |
| 549 | |
| 68f95949 |
550 | if Etype (Subp) = Typ then |
| ee6ba406 |
551 | Res_Typ := CW_Typ; |
| 552 | else |
| 7189d17f |
553 | Res_Typ := Etype (Subp); |
| ee6ba406 |
554 | end if; |
| 555 | |
| 556 | Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node); |
| 557 | Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node); |
| 558 | Set_Etype (Subp_Typ, Res_Typ); |
| ee6ba406 |
559 | Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); |
| 560 | |
| 561 | -- Create a new list of parameters which is a copy of the old formal |
| 562 | -- list including the creation of a new set of matching entities. |
| 563 | |
| 564 | declare |
| 565 | Old_Formal : Entity_Id := First_Formal (Subp); |
| 566 | New_Formal : Entity_Id; |
| 725a69d2 |
567 | Extra : Entity_Id := Empty; |
| ee6ba406 |
568 | |
| 569 | begin |
| 570 | if Present (Old_Formal) then |
| 571 | New_Formal := New_Copy (Old_Formal); |
| 572 | Set_First_Entity (Subp_Typ, New_Formal); |
| 573 | Param := First_Actual (Call_Node); |
| 574 | |
| 575 | loop |
| 576 | Set_Scope (New_Formal, Subp_Typ); |
| 577 | |
| 578 | -- Change all the controlling argument types to be class-wide |
| 7189d17f |
579 | -- to avoid a recursion in dispatching. |
| ee6ba406 |
580 | |
| 7189d17f |
581 | if Is_Controlling_Formal (New_Formal) then |
| ee6ba406 |
582 | Set_Etype (New_Formal, Etype (Param)); |
| 583 | end if; |
| 584 | |
| cc60bd16 |
585 | -- If the type of the formal is an itype, there was code here |
| 586 | -- introduced in 1998 in revision 1.46, to create a new itype |
| 587 | -- by copy. This seems useless, and in fact leads to semantic |
| 588 | -- errors when the itype is the completion of a type derived |
| 589 | -- from a private type. |
| ee6ba406 |
590 | |
| 591 | Extra := New_Formal; |
| 592 | Next_Formal (Old_Formal); |
| 593 | exit when No (Old_Formal); |
| 594 | |
| 595 | Set_Next_Entity (New_Formal, New_Copy (Old_Formal)); |
| 596 | Next_Entity (New_Formal); |
| 597 | Next_Actual (Param); |
| 598 | end loop; |
| af647dc7 |
599 | |
| 600 | Set_Next_Entity (New_Formal, Empty); |
| ee6ba406 |
601 | Set_Last_Entity (Subp_Typ, Extra); |
| 725a69d2 |
602 | end if; |
| ee6ba406 |
603 | |
| 725a69d2 |
604 | -- Now that the explicit formals have been duplicated, any extra |
| 605 | -- formals needed by the subprogram must be created. |
| ee6ba406 |
606 | |
| 725a69d2 |
607 | if Present (Extra) then |
| 608 | Set_Extra_Formal (Extra, Empty); |
| ee6ba406 |
609 | end if; |
| 725a69d2 |
610 | |
| 611 | Create_Extra_Formals (Subp_Typ); |
| ee6ba406 |
612 | end; |
| 613 | |
| 614 | Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); |
| 615 | Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ); |
| acf97c11 |
616 | Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ)); |
| ee6ba406 |
617 | |
| 68f95949 |
618 | -- If the controlling argument is a value of type Ada.Tag or an abstract |
| 619 | -- interface class-wide type then use it directly. Otherwise, the tag |
| 620 | -- must be extracted from the controlling object. |
| 7189d17f |
621 | |
| aad6babd |
622 | if Etype (Ctrl_Arg) = RTE (RE_Tag) |
| 68f95949 |
623 | or else (RTE_Available (RE_Interface_Tag) |
| 624 | and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)) |
| 625 | then |
| 626 | Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); |
| 627 | |
| 343d35dc |
628 | -- Extract the tag from an unchecked type conversion. Done to avoid |
| 629 | -- the expansion of additional code just to obtain the value of such |
| 630 | -- tag because the current management of interface type conversions |
| 631 | -- generates in some cases this unchecked type conversion with the |
| 632 | -- tag of the object (see Expand_Interface_Conversion). |
| 633 | |
| 634 | elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion |
| 635 | and then |
| 636 | (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag) |
| 637 | or else |
| 638 | (RTE_Available (RE_Interface_Tag) |
| 639 | and then |
| 640 | Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag))) |
| 641 | then |
| 642 | Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg)); |
| 643 | |
| 68f95949 |
644 | -- Ada 2005 (AI-251): Abstract interface class-wide type |
| 645 | |
| 646 | elsif Is_Interface (Etype (Ctrl_Arg)) |
| 647 | and then Is_Class_Wide_Type (Etype (Ctrl_Arg)) |
| aad6babd |
648 | then |
| 7189d17f |
649 | Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); |
| 650 | |
| 651 | else |
| 652 | Controlling_Tag := |
| 653 | Make_Selected_Component (Loc, |
| 654 | Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg), |
| 655 | Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc)); |
| 656 | end if; |
| 657 | |
| 343d35dc |
658 | -- Handle dispatching calls to predefined primitives |
| ee6ba406 |
659 | |
| af647dc7 |
660 | if Is_Predefined_Dispatching_Operation (Subp) |
| 661 | or else Is_Predefined_Dispatching_Alias (Subp) |
| 662 | then |
| 68f95949 |
663 | New_Call_Name := |
| 664 | Unchecked_Convert_To (Subp_Ptr_Typ, |
| 343d35dc |
665 | Build_Get_Predefined_Prim_Op_Address (Loc, |
| 666 | Tag_Node => Controlling_Tag, |
| 725a69d2 |
667 | Position => DT_Position (Subp))); |
| ee6ba406 |
668 | |
| 343d35dc |
669 | -- Handle dispatching calls to user-defined primitives |
| 68f95949 |
670 | |
| 671 | else |
| 672 | New_Call_Name := |
| 673 | Unchecked_Convert_To (Subp_Ptr_Typ, |
| 343d35dc |
674 | Build_Get_Prim_Op_Address (Loc, |
| 725a69d2 |
675 | Typ => Find_Dispatching_Type (Subp), |
| 676 | Tag_Node => Controlling_Tag, |
| 677 | Position => DT_Position (Subp))); |
| 68f95949 |
678 | end if; |
| ee6ba406 |
679 | |
| 680 | if Nkind (Call_Node) = N_Function_Call then |
| ee6ba406 |
681 | |
| 725a69d2 |
682 | New_Call := |
| 683 | Make_Function_Call (Loc, |
| 684 | Name => New_Call_Name, |
| 685 | Parameter_Associations => New_Params); |
| ee6ba406 |
686 | |
| 725a69d2 |
687 | -- If this is a dispatching "=", we must first compare the tags so |
| 688 | -- we generate: x.tag = y.tag and then x = y |
| ee6ba406 |
689 | |
| 725a69d2 |
690 | if Subp = Eq_Prim_Op then |
| 691 | Param := First_Actual (Call_Node); |
| aad6babd |
692 | New_Call := |
| 725a69d2 |
693 | Make_And_Then (Loc, |
| 694 | Left_Opnd => |
| 695 | Make_Op_Eq (Loc, |
| 696 | Left_Opnd => |
| 697 | Make_Selected_Component (Loc, |
| 698 | Prefix => New_Value (Param), |
| 699 | Selector_Name => |
| 700 | New_Reference_To (First_Tag_Component (Typ), |
| 701 | Loc)), |
| ee6ba406 |
702 | |
| 725a69d2 |
703 | Right_Opnd => |
| 704 | Make_Selected_Component (Loc, |
| 705 | Prefix => |
| 706 | Unchecked_Convert_To (Typ, |
| 707 | New_Value (Next_Actual (Param))), |
| 708 | Selector_Name => |
| 709 | New_Reference_To (First_Tag_Component (Typ), |
| 710 | Loc))), |
| 711 | Right_Opnd => New_Call); |
| ee6ba406 |
712 | end if; |
| 713 | |
| 714 | else |
| 715 | New_Call := |
| 716 | Make_Procedure_Call_Statement (Loc, |
| 717 | Name => New_Call_Name, |
| 718 | Parameter_Associations => New_Params); |
| 719 | end if; |
| 720 | |
| 721 | Rewrite (Call_Node, New_Call); |
| 725a69d2 |
722 | |
| 723 | -- Suppress all checks during the analysis of the expanded code |
| 36b938a3 |
724 | -- to avoid the generation of spurious warnings under ZFP run-time. |
| 725a69d2 |
725 | |
| 726 | Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks); |
| 7189d17f |
727 | end Expand_Dispatching_Call; |
| ee6ba406 |
728 | |
| aad6babd |
729 | --------------------------------- |
| 730 | -- Expand_Interface_Conversion -- |
| 731 | --------------------------------- |
| 732 | |
| 952af0b9 |
733 | procedure Expand_Interface_Conversion |
| 734 | (N : Node_Id; |
| 735 | Is_Static : Boolean := True) |
| 736 | is |
| aad6babd |
737 | Loc : constant Source_Ptr := Sloc (N); |
| af647dc7 |
738 | Etyp : constant Entity_Id := Etype (N); |
| aad6babd |
739 | Operand : constant Node_Id := Expression (N); |
| 740 | Operand_Typ : Entity_Id := Etype (Operand); |
| d62940bf |
741 | Func : Node_Id; |
| af647dc7 |
742 | Iface_Typ : Entity_Id := Etype (N); |
| 743 | Iface_Tag : Entity_Id; |
| aad6babd |
744 | |
| 745 | begin |
| 343d35dc |
746 | -- Ada 2005 (AI-345): Handle synchronized interface type derivations |
| aad6babd |
747 | |
| 343d35dc |
748 | if Is_Concurrent_Type (Operand_Typ) then |
| 749 | Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ)); |
| aad6babd |
750 | end if; |
| 751 | |
| e7e688dd |
752 | -- Handle access to class-wide interface types |
| aad6babd |
753 | |
| d62940bf |
754 | if Is_Access_Type (Iface_Typ) then |
| 755 | Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ)); |
| aad6babd |
756 | end if; |
| 757 | |
| d62940bf |
758 | -- Handle class-wide interface types. This conversion can appear |
| 759 | -- explicitly in the source code. Example: I'Class (Obj) |
| aad6babd |
760 | |
| d62940bf |
761 | if Is_Class_Wide_Type (Iface_Typ) then |
| 725a69d2 |
762 | Iface_Typ := Root_Type (Iface_Typ); |
| d62940bf |
763 | end if; |
| 764 | |
| af647dc7 |
765 | pragma Assert (not Is_Static |
| 766 | or else (not Is_Class_Wide_Type (Iface_Typ) |
| 767 | and then Is_Interface (Iface_Typ))); |
| aad6babd |
768 | |
| 725a69d2 |
769 | if VM_Target /= No_VM then |
| 770 | |
| 771 | -- For VM, just do a conversion ??? |
| 772 | |
| 773 | Rewrite (N, Unchecked_Convert_To (Etype (N), N)); |
| 774 | Analyze (N); |
| 775 | return; |
| 776 | end if; |
| 777 | |
| 952af0b9 |
778 | if not Is_Static then |
| 68f95949 |
779 | |
| 780 | -- Give error if configurable run time and Displace not available |
| 781 | |
| 782 | if not RTE_Available (RE_Displace) then |
| cc60bd16 |
783 | Error_Msg_CRT ("dynamic interface conversion", N); |
| 68f95949 |
784 | return; |
| 785 | end if; |
| 786 | |
| 725a69d2 |
787 | -- Handle conversion of access-to-class-wide interface types. Target |
| 788 | -- can be an access to an object or an access to another class-wide |
| 789 | -- interface (see -1- and -2- in the following example): |
| af647dc7 |
790 | |
| 791 | -- type Iface1_Ref is access all Iface1'Class; |
| 792 | -- type Iface2_Ref is access all Iface1'Class; |
| 793 | |
| 794 | -- Acc1 : Iface1_Ref := new ... |
| 795 | -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1 |
| 796 | -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2 |
| 797 | |
| 798 | if Is_Access_Type (Operand_Typ) then |
| 799 | pragma Assert |
| 725a69d2 |
800 | (Is_Interface (Directly_Designated_Type (Operand_Typ))); |
| af647dc7 |
801 | |
| 802 | Rewrite (N, |
| 803 | Unchecked_Convert_To (Etype (N), |
| 804 | Make_Function_Call (Loc, |
| 805 | Name => New_Reference_To (RTE (RE_Displace), Loc), |
| 806 | Parameter_Associations => New_List ( |
| 807 | |
| 808 | Unchecked_Convert_To (RTE (RE_Address), |
| 809 | Relocate_Node (Expression (N))), |
| 810 | |
| 811 | New_Occurrence_Of |
| 812 | (Node (First_Elmt (Access_Disp_Table (Iface_Typ))), |
| 813 | Loc))))); |
| 814 | |
| 815 | Analyze (N); |
| 816 | return; |
| 817 | end if; |
| 818 | |
| 952af0b9 |
819 | Rewrite (N, |
| 820 | Make_Function_Call (Loc, |
| 821 | Name => New_Reference_To (RTE (RE_Displace), Loc), |
| 822 | Parameter_Associations => New_List ( |
| 823 | Make_Attribute_Reference (Loc, |
| 824 | Prefix => Relocate_Node (Expression (N)), |
| 825 | Attribute_Name => Name_Address), |
| af647dc7 |
826 | |
| 952af0b9 |
827 | New_Occurrence_Of |
| 828 | (Node (First_Elmt (Access_Disp_Table (Iface_Typ))), |
| 829 | Loc)))); |
| 830 | |
| 831 | Analyze (N); |
| 832 | |
| af647dc7 |
833 | -- If the target is a class-wide interface we change the type of the |
| 834 | -- data returned by IW_Convert to indicate that this is a dispatching |
| 835 | -- call. |
| 952af0b9 |
836 | |
| 17e14451 |
837 | declare |
| 838 | New_Itype : Entity_Id; |
| 952af0b9 |
839 | |
| 17e14451 |
840 | begin |
| 841 | New_Itype := Create_Itype (E_Anonymous_Access_Type, N); |
| cc60bd16 |
842 | Set_Etype (New_Itype, New_Itype); |
| 17e14451 |
843 | Set_Directly_Designated_Type (New_Itype, Etyp); |
| 952af0b9 |
844 | |
| 17e14451 |
845 | Rewrite (N, |
| 846 | Make_Explicit_Dereference (Loc, |
| 847 | Prefix => |
| 848 | Unchecked_Convert_To (New_Itype, Relocate_Node (N)))); |
| 849 | Analyze (N); |
| 850 | Freeze_Itype (New_Itype, N); |
| 851 | |
| 852 | return; |
| 853 | end; |
| 952af0b9 |
854 | end if; |
| 855 | |
| d62940bf |
856 | Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ); |
| aad6babd |
857 | pragma Assert (Iface_Tag /= Empty); |
| 858 | |
| d62940bf |
859 | -- Keep separate access types to interfaces because one internal |
| 860 | -- function is used to handle the null value (see following comment) |
| 861 | |
| 862 | if not Is_Access_Type (Etype (N)) then |
| 863 | Rewrite (N, |
| 864 | Unchecked_Convert_To (Etype (N), |
| 865 | Make_Selected_Component (Loc, |
| 866 | Prefix => Relocate_Node (Expression (N)), |
| 867 | Selector_Name => |
| 868 | New_Occurrence_Of (Iface_Tag, Loc)))); |
| 869 | |
| 870 | else |
| 871 | -- Build internal function to handle the case in which the |
| 872 | -- actual is null. If the actual is null returns null because |
| 873 | -- no displacement is required; otherwise performs a type |
| 874 | -- conversion that will be expanded in the code that returns |
| 875 | -- the value of the displaced actual. That is: |
| 876 | |
| af647dc7 |
877 | -- function Func (O : Address) return Iface_Typ is |
| 17e14451 |
878 | -- type Op_Typ is access all Operand_Typ; |
| 879 | -- Aux : Op_Typ := To_Op_Typ (O); |
| d62940bf |
880 | -- begin |
| af647dc7 |
881 | -- if O = Null_Address then |
| d62940bf |
882 | -- return null; |
| 883 | -- else |
| 17e14451 |
884 | -- return Iface_Typ!(Aux.Iface_Tag'Address); |
| d62940bf |
885 | -- end if; |
| 886 | -- end Func; |
| 887 | |
| af647dc7 |
888 | declare |
| 17e14451 |
889 | Desig_Typ : Entity_Id; |
| 890 | Fent : Entity_Id; |
| 891 | New_Typ_Decl : Node_Id; |
| 17e14451 |
892 | Stats : List_Id; |
| 893 | |
| af647dc7 |
894 | begin |
| 895 | Desig_Typ := Etype (Expression (N)); |
| d62940bf |
896 | |
| af647dc7 |
897 | if Is_Access_Type (Desig_Typ) then |
| 898 | Desig_Typ := Directly_Designated_Type (Desig_Typ); |
| 899 | end if; |
| d62940bf |
900 | |
| e7e688dd |
901 | if Is_Concurrent_Type (Desig_Typ) then |
| 902 | Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ)); |
| 903 | end if; |
| 904 | |
| 17e14451 |
905 | New_Typ_Decl := |
| 906 | Make_Full_Type_Declaration (Loc, |
| 907 | Defining_Identifier => |
| 908 | Make_Defining_Identifier (Loc, New_Internal_Name ('T')), |
| 909 | Type_Definition => |
| 910 | Make_Access_To_Object_Definition (Loc, |
| 911 | All_Present => True, |
| 912 | Null_Exclusion_Present => False, |
| 913 | Constant_Present => False, |
| 914 | Subtype_Indication => |
| 915 | New_Reference_To (Desig_Typ, Loc))); |
| d62940bf |
916 | |
| 725a69d2 |
917 | Stats := New_List ( |
| 17e14451 |
918 | Make_Simple_Return_Statement (Loc, |
| 919 | Unchecked_Convert_To (Etype (N), |
| 920 | Make_Attribute_Reference (Loc, |
| 921 | Prefix => |
| 922 | Make_Selected_Component (Loc, |
| 923 | Prefix => |
| e7e688dd |
924 | Unchecked_Convert_To |
| 925 | (Defining_Identifier (New_Typ_Decl), |
| 926 | Make_Identifier (Loc, Name_uO)), |
| 17e14451 |
927 | Selector_Name => |
| 928 | New_Occurrence_Of (Iface_Tag, Loc)), |
| 929 | Attribute_Name => Name_Address)))); |
| 725a69d2 |
930 | |
| 17e14451 |
931 | -- If the type is null-excluding, no need for the null branch. |
| 932 | -- Otherwise we need to check for it and return null. |
| 933 | |
| 934 | if not Can_Never_Be_Null (Etype (N)) then |
| 935 | Stats := New_List ( |
| 936 | Make_If_Statement (Loc, |
| 937 | Condition => |
| 938 | Make_Op_Eq (Loc, |
| 939 | Left_Opnd => Make_Identifier (Loc, Name_uO), |
| 940 | Right_Opnd => New_Reference_To |
| 941 | (RTE (RE_Null_Address), Loc)), |
| 942 | |
| 943 | Then_Statements => New_List ( |
| 944 | Make_Simple_Return_Statement (Loc, |
| 945 | Make_Null (Loc))), |
| 946 | Else_Statements => Stats)); |
| 947 | end if; |
| d62940bf |
948 | |
| 17e14451 |
949 | Fent := |
| 950 | Make_Defining_Identifier (Loc, |
| 951 | New_Internal_Name ('F')); |
| af647dc7 |
952 | |
| 17e14451 |
953 | Func := |
| 954 | Make_Subprogram_Body (Loc, |
| 955 | Specification => |
| 956 | Make_Function_Specification (Loc, |
| 957 | Defining_Unit_Name => Fent, |
| d62940bf |
958 | |
| 17e14451 |
959 | Parameter_Specifications => New_List ( |
| 960 | Make_Parameter_Specification (Loc, |
| 961 | Defining_Identifier => |
| 962 | Make_Defining_Identifier (Loc, Name_uO), |
| 963 | Parameter_Type => |
| 964 | New_Reference_To (RTE (RE_Address), Loc))), |
| d62940bf |
965 | |
| 17e14451 |
966 | Result_Definition => |
| 967 | New_Reference_To (Etype (N), Loc)), |
| d62940bf |
968 | |
| e7e688dd |
969 | Declarations => New_List (New_Typ_Decl), |
| d62940bf |
970 | |
| 17e14451 |
971 | Handled_Statement_Sequence => |
| 972 | Make_Handled_Sequence_Of_Statements (Loc, Stats)); |
| d62940bf |
973 | |
| 17e14451 |
974 | -- Place function body before the expression containing the |
| 975 | -- conversion. We suppress all checks because the body of the |
| 976 | -- internally generated function already takes care of the case |
| 977 | -- in which the actual is null; therefore there is no need to |
| 978 | -- double check that the pointer is not null when the program |
| 979 | -- executes the alternative that performs the type conversion). |
| af647dc7 |
980 | |
| 17e14451 |
981 | Insert_Action (N, Func, Suppress => All_Checks); |
| af647dc7 |
982 | |
| 17e14451 |
983 | if Is_Access_Type (Etype (Expression (N))) then |
| af647dc7 |
984 | |
| e7e688dd |
985 | -- Generate: Func (Address!(Expression)) |
| af647dc7 |
986 | |
| 17e14451 |
987 | Rewrite (N, |
| 988 | Make_Function_Call (Loc, |
| 989 | Name => New_Reference_To (Fent, Loc), |
| 990 | Parameter_Associations => New_List ( |
| e7e688dd |
991 | Unchecked_Convert_To (RTE (RE_Address), |
| 992 | Relocate_Node (Expression (N)))))); |
| 17e14451 |
993 | |
| 994 | else |
| e7e688dd |
995 | -- Generate: Func (Operand_Typ!(Expression)'Address) |
| 17e14451 |
996 | |
| 997 | Rewrite (N, |
| 998 | Make_Function_Call (Loc, |
| 999 | Name => New_Reference_To (Fent, Loc), |
| 1000 | Parameter_Associations => New_List ( |
| 1001 | Make_Attribute_Reference (Loc, |
| 1002 | Prefix => Unchecked_Convert_To (Operand_Typ, |
| 1003 | Relocate_Node (Expression (N))), |
| 1004 | Attribute_Name => Name_Address)))); |
| 1005 | end if; |
| 1006 | end; |
| d62940bf |
1007 | end if; |
| aad6babd |
1008 | |
| 1009 | Analyze (N); |
| 1010 | end Expand_Interface_Conversion; |
| 1011 | |
| 1012 | ------------------------------ |
| 1013 | -- Expand_Interface_Actuals -- |
| 1014 | ------------------------------ |
| 1015 | |
| 1016 | procedure Expand_Interface_Actuals (Call_Node : Node_Id) is |
| aad6babd |
1017 | Actual : Node_Id; |
| d62940bf |
1018 | Actual_Dup : Node_Id; |
| aad6babd |
1019 | Actual_Typ : Entity_Id; |
| d62940bf |
1020 | Anon : Entity_Id; |
| aad6babd |
1021 | Conversion : Node_Id; |
| 1022 | Formal : Entity_Id; |
| 1023 | Formal_Typ : Entity_Id; |
| 1024 | Subp : Entity_Id; |
| d62940bf |
1025 | Formal_DDT : Entity_Id; |
| 1026 | Actual_DDT : Entity_Id; |
| aad6babd |
1027 | |
| 1028 | begin |
| 1029 | -- This subprogram is called directly from the semantics, so we need a |
| 1030 | -- check to see whether expansion is active before proceeding. |
| 1031 | |
| 1032 | if not Expander_Active then |
| 1033 | return; |
| 1034 | end if; |
| 1035 | |
| 1036 | -- Call using access to subprogram with explicit dereference |
| 1037 | |
| 1038 | if Nkind (Name (Call_Node)) = N_Explicit_Dereference then |
| 1039 | Subp := Etype (Name (Call_Node)); |
| 1040 | |
| 1041 | -- Normal case |
| 1042 | |
| 1043 | else |
| 1044 | Subp := Entity (Name (Call_Node)); |
| 1045 | end if; |
| 1046 | |
| 725a69d2 |
1047 | -- Ada 2005 (AI-251): Look for interface type formals to force "this" |
| 1048 | -- displacement |
| 1049 | |
| aad6babd |
1050 | Formal := First_Formal (Subp); |
| 1051 | Actual := First_Actual (Call_Node); |
| aad6babd |
1052 | while Present (Formal) loop |
| 725a69d2 |
1053 | Formal_Typ := Etype (Formal); |
| d62940bf |
1054 | |
| 1055 | if Ekind (Formal_Typ) = E_Record_Type_With_Private then |
| 1056 | Formal_Typ := Full_View (Formal_Typ); |
| 1057 | end if; |
| 1058 | |
| 1059 | if Is_Access_Type (Formal_Typ) then |
| 1060 | Formal_DDT := Directly_Designated_Type (Formal_Typ); |
| 1061 | end if; |
| 1062 | |
| aad6babd |
1063 | Actual_Typ := Etype (Actual); |
| 1064 | |
| d62940bf |
1065 | if Is_Access_Type (Actual_Typ) then |
| 1066 | Actual_DDT := Directly_Designated_Type (Actual_Typ); |
| 1067 | end if; |
| 1068 | |
| 725a69d2 |
1069 | if Is_Interface (Formal_Typ) |
| 1070 | and then Is_Class_Wide_Type (Formal_Typ) |
| 1071 | then |
| d62940bf |
1072 | -- No need to displace the pointer if the type of the actual |
| 725a69d2 |
1073 | -- coindices with the type of the formal. |
| aad6babd |
1074 | |
| 725a69d2 |
1075 | if Actual_Typ = Formal_Typ then |
| d62940bf |
1076 | null; |
| 1077 | |
| 725a69d2 |
1078 | -- No need to displace the pointer if the interface type is |
| 1079 | -- a parent of the type of the actual because in this case the |
| 1080 | -- interface primitives are located in the primary dispatch table. |
| aad6babd |
1081 | |
| 343d35dc |
1082 | elsif Is_Parent (Formal_Typ, Actual_Typ) then |
| d62940bf |
1083 | null; |
| 1084 | |
| 725a69d2 |
1085 | -- Implicit conversion to the class-wide formal type to force |
| 1086 | -- the displacement of the pointer. |
| 1087 | |
| d62940bf |
1088 | else |
| 1089 | Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual)); |
| 725a69d2 |
1090 | Rewrite (Actual, Conversion); |
| d62940bf |
1091 | Analyze_And_Resolve (Actual, Formal_Typ); |
| 1092 | end if; |
| aad6babd |
1093 | |
| 725a69d2 |
1094 | -- Access to class-wide interface type |
| aad6babd |
1095 | |
| 1096 | elsif Is_Access_Type (Formal_Typ) |
| 725a69d2 |
1097 | and then Is_Interface (Formal_DDT) |
| 1098 | and then Is_Class_Wide_Type (Formal_DDT) |
| aad6babd |
1099 | and then Interface_Present_In_Ancestor |
| d62940bf |
1100 | (Typ => Actual_DDT, |
| 1101 | Iface => Etype (Formal_DDT)) |
| aad6babd |
1102 | then |
| 725a69d2 |
1103 | -- Handle attributes 'Access and 'Unchecked_Access |
| 1104 | |
| aad6babd |
1105 | if Nkind (Actual) = N_Attribute_Reference |
| 1106 | and then |
| 1107 | (Attribute_Name (Actual) = Name_Access |
| 1108 | or else Attribute_Name (Actual) = Name_Unchecked_Access) |
| 1109 | then |
| 5e82d8fe |
1110 | -- This case must have been handled by the analysis and |
| 1111 | -- expansion of 'Access. The only exception is when types |
| 1112 | -- match and no further expansion is required. |
| aad6babd |
1113 | |
| 5e82d8fe |
1114 | pragma Assert (Base_Type (Etype (Prefix (Actual))) |
| 1115 | = Base_Type (Formal_DDT)); |
| 1116 | null; |
| aad6babd |
1117 | |
| 725a69d2 |
1118 | -- No need to displace the pointer if the type of the actual |
| 1119 | -- coincides with the type of the formal. |
| d62940bf |
1120 | |
| 725a69d2 |
1121 | elsif Actual_DDT = Formal_DDT then |
| d62940bf |
1122 | null; |
| 1123 | |
| 725a69d2 |
1124 | -- No need to displace the pointer if the interface type is |
| 1125 | -- a parent of the type of the actual because in this case the |
| 1126 | -- interface primitives are located in the primary dispatch table. |
| d62940bf |
1127 | |
| 343d35dc |
1128 | elsif Is_Parent (Formal_DDT, Actual_DDT) then |
| d62940bf |
1129 | null; |
| 1130 | |
| aad6babd |
1131 | else |
| d62940bf |
1132 | Actual_Dup := Relocate_Node (Actual); |
| 1133 | |
| 1134 | if From_With_Type (Actual_Typ) then |
| 1135 | |
| 1136 | -- If the type of the actual parameter comes from a limited |
| 1137 | -- with-clause and the non-limited view is already available |
| 9ced80be |
1138 | -- we replace the anonymous access type by a duplicate |
| 1139 | -- declaration whose designated type is the non-limited view |
| d62940bf |
1140 | |
| 1141 | if Ekind (Actual_DDT) = E_Incomplete_Type |
| 1142 | and then Present (Non_Limited_View (Actual_DDT)) |
| 1143 | then |
| 1144 | Anon := New_Copy (Actual_Typ); |
| 1145 | |
| 1146 | if Is_Itype (Anon) then |
| 1147 | Set_Scope (Anon, Current_Scope); |
| 1148 | end if; |
| 1149 | |
| 1150 | Set_Directly_Designated_Type (Anon, |
| 1151 | Non_Limited_View (Actual_DDT)); |
| 1152 | Set_Etype (Actual_Dup, Anon); |
| 1153 | |
| 1154 | elsif Is_Class_Wide_Type (Actual_DDT) |
| 1155 | and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type |
| 1156 | and then Present (Non_Limited_View (Etype (Actual_DDT))) |
| 1157 | then |
| 1158 | Anon := New_Copy (Actual_Typ); |
| 1159 | |
| 1160 | if Is_Itype (Anon) then |
| 1161 | Set_Scope (Anon, Current_Scope); |
| 1162 | end if; |
| 1163 | |
| 1164 | Set_Directly_Designated_Type (Anon, |
| 1165 | New_Copy (Actual_DDT)); |
| 1166 | Set_Class_Wide_Type (Directly_Designated_Type (Anon), |
| 1167 | New_Copy (Class_Wide_Type (Actual_DDT))); |
| 1168 | Set_Etype (Directly_Designated_Type (Anon), |
| 1169 | Non_Limited_View (Etype (Actual_DDT))); |
| 1170 | Set_Etype ( |
| 1171 | Class_Wide_Type (Directly_Designated_Type (Anon)), |
| 1172 | Non_Limited_View (Etype (Actual_DDT))); |
| 1173 | Set_Etype (Actual_Dup, Anon); |
| 1174 | end if; |
| 1175 | end if; |
| 1176 | |
| 1177 | Conversion := Convert_To (Formal_Typ, Actual_Dup); |
| 1178 | Rewrite (Actual, Conversion); |
| aad6babd |
1179 | Analyze_And_Resolve (Actual, Formal_Typ); |
| 1180 | end if; |
| 1181 | end if; |
| 1182 | |
| 1183 | Next_Actual (Actual); |
| 1184 | Next_Formal (Formal); |
| 1185 | end loop; |
| 1186 | end Expand_Interface_Actuals; |
| 1187 | |
| 1188 | ---------------------------- |
| 1189 | -- Expand_Interface_Thunk -- |
| 1190 | ---------------------------- |
| 1191 | |
| 725a69d2 |
1192 | procedure Expand_Interface_Thunk |
| 17e14451 |
1193 | (Prim : Node_Id; |
| 1194 | Thunk_Id : out Entity_Id; |
| 1195 | Thunk_Code : out Node_Id) |
| aad6babd |
1196 | is |
| 17e14451 |
1197 | Loc : constant Source_Ptr := Sloc (Prim); |
| 725a69d2 |
1198 | Actuals : constant List_Id := New_List; |
| 1199 | Decl : constant List_Id := New_List; |
| 1200 | Formals : constant List_Id := New_List; |
| 1201 | |
| 1202 | Controlling_Typ : Entity_Id; |
| 1203 | Decl_1 : Node_Id; |
| 1204 | Decl_2 : Node_Id; |
| 1205 | Formal : Node_Id; |
| cc60bd16 |
1206 | New_Arg : Node_Id; |
| 1207 | Offset_To_Top : Node_Id; |
| 725a69d2 |
1208 | Target : Entity_Id; |
| 1209 | Target_Formal : Entity_Id; |
| aad6babd |
1210 | |
| 1211 | begin |
| 725a69d2 |
1212 | Thunk_Id := Empty; |
| 1213 | Thunk_Code := Empty; |
| 1214 | |
| aad6babd |
1215 | -- Traverse the list of alias to find the final target |
| 1216 | |
| 17e14451 |
1217 | Target := Prim; |
| aad6babd |
1218 | while Present (Alias (Target)) loop |
| 1219 | Target := Alias (Target); |
| 1220 | end loop; |
| 1221 | |
| 725a69d2 |
1222 | -- In case of primitives that are functions without formals and |
| 1223 | -- a controlling result there is no need to build the thunk. |
| 1224 | |
| 1225 | if not Present (First_Formal (Target)) then |
| 1226 | pragma Assert (Ekind (Target) = E_Function |
| 1227 | and then Has_Controlling_Result (Target)); |
| 1228 | return; |
| 1229 | end if; |
| 1230 | |
| aad6babd |
1231 | -- Duplicate the formals |
| 1232 | |
| d62940bf |
1233 | Formal := First_Formal (Target); |
| aad6babd |
1234 | while Present (Formal) loop |
| 725a69d2 |
1235 | Append_To (Formals, |
| 1236 | Make_Parameter_Specification (Loc, |
| 1237 | Defining_Identifier => |
| 1238 | Make_Defining_Identifier (Sloc (Formal), |
| 1239 | Chars => Chars (Formal)), |
| 1240 | In_Present => In_Present (Parent (Formal)), |
| 1241 | Out_Present => Out_Present (Parent (Formal)), |
| 1242 | Parameter_Type => |
| 1243 | New_Reference_To (Etype (Formal), Loc), |
| 1244 | Expression => New_Copy_Tree (Expression (Parent (Formal))))); |
| d62940bf |
1245 | |
| aad6babd |
1246 | Next_Formal (Formal); |
| 1247 | end loop; |
| 1248 | |
| 17e14451 |
1249 | Controlling_Typ := Find_Dispatching_Type (Target); |
| aad6babd |
1250 | |
| 725a69d2 |
1251 | Target_Formal := First_Formal (Target); |
| 1252 | Formal := First (Formals); |
| 1253 | while Present (Formal) loop |
| 1254 | if Ekind (Target_Formal) = E_In_Parameter |
| 1255 | and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type |
| 1256 | and then Directly_Designated_Type (Etype (Target_Formal)) |
| 1257 | = Controlling_Typ |
| 1258 | then |
| 1259 | -- Generate: |
| aad6babd |
1260 | |
| 17e14451 |
1261 | -- type T is access all <<type of the target formal>> |
| 1262 | -- S : Storage_Offset := Storage_Offset!(Formal) |
| 1263 | -- - Offset_To_Top (address!(Formal)) |
| 725a69d2 |
1264 | |
| 1265 | Decl_2 := |
| 1266 | Make_Full_Type_Declaration (Loc, |
| 1267 | Defining_Identifier => |
| 1268 | Make_Defining_Identifier (Loc, |
| 1269 | New_Internal_Name ('T')), |
| 1270 | Type_Definition => |
| 1271 | Make_Access_To_Object_Definition (Loc, |
| 1272 | All_Present => True, |
| 1273 | Null_Exclusion_Present => False, |
| 1274 | Constant_Present => False, |
| 1275 | Subtype_Indication => |
| aad6babd |
1276 | New_Reference_To |
| 725a69d2 |
1277 | (Directly_Designated_Type |
| 1278 | (Etype (Target_Formal)), Loc))); |
| 1279 | |
| cc60bd16 |
1280 | New_Arg := |
| 1281 | Unchecked_Convert_To (RTE (RE_Address), |
| 1282 | New_Reference_To (Defining_Identifier (Formal), Loc)); |
| 1283 | |
| 1284 | if not RTE_Available (RE_Offset_To_Top) then |
| 1285 | Offset_To_Top := |
| 1286 | Build_Offset_To_Top (Loc, New_Arg); |
| 1287 | else |
| 1288 | Offset_To_Top := |
| 1289 | Make_Function_Call (Loc, |
| 1290 | Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), |
| 1291 | Parameter_Associations => New_List (New_Arg)); |
| 1292 | end if; |
| 1293 | |
| 725a69d2 |
1294 | Decl_1 := |
| 1295 | Make_Object_Declaration (Loc, |
| 1296 | Defining_Identifier => |
| 1297 | Make_Defining_Identifier (Loc, |
| 1298 | New_Internal_Name ('S')), |
| 1299 | Constant_Present => True, |
| 1300 | Object_Definition => |
| 1301 | New_Reference_To (RTE (RE_Storage_Offset), Loc), |
| 1302 | Expression => |
| 1303 | Make_Op_Subtract (Loc, |
| 1304 | Left_Opnd => |
| 1305 | Unchecked_Convert_To |
| 1306 | (RTE (RE_Storage_Offset), |
| 1307 | New_Reference_To (Defining_Identifier (Formal), Loc)), |
| 1308 | Right_Opnd => |
| cc60bd16 |
1309 | Offset_To_Top)); |
| 725a69d2 |
1310 | |
| 1311 | Append_To (Decl, Decl_2); |
| 1312 | Append_To (Decl, Decl_1); |
| 1313 | |
| 17e14451 |
1314 | -- Reference the new actual. Generate: |
| 1315 | -- T!(S) |
| 725a69d2 |
1316 | |
| 1317 | Append_To (Actuals, |
| 1318 | Unchecked_Convert_To |
| 1319 | (Defining_Identifier (Decl_2), |
| 1320 | New_Reference_To (Defining_Identifier (Decl_1), Loc))); |
| 1321 | |
| 1322 | elsif Etype (Target_Formal) = Controlling_Typ then |
| 1323 | -- Generate: |
| aad6babd |
1324 | |
| 17e14451 |
1325 | -- S1 : Storage_Offset := Storage_Offset!(Formal'Address) |
| 1326 | -- - Offset_To_Top (Formal'Address) |
| 1327 | -- S2 : Addr_Ptr := Addr_Ptr!(S1) |
| aad6babd |
1328 | |
| cc60bd16 |
1329 | New_Arg := |
| 1330 | Make_Attribute_Reference (Loc, |
| 1331 | Prefix => |
| 1332 | New_Reference_To (Defining_Identifier (Formal), Loc), |
| 1333 | Attribute_Name => |
| 1334 | Name_Address); |
| 1335 | |
| 1336 | if not RTE_Available (RE_Offset_To_Top) then |
| 1337 | Offset_To_Top := |
| 1338 | Build_Offset_To_Top (Loc, New_Arg); |
| 1339 | else |
| 1340 | Offset_To_Top := |
| 1341 | Make_Function_Call (Loc, |
| 1342 | Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), |
| 1343 | Parameter_Associations => New_List (New_Arg)); |
| 1344 | end if; |
| 1345 | |
| 725a69d2 |
1346 | Decl_1 := |
| 1347 | Make_Object_Declaration (Loc, |
| 1348 | Defining_Identifier => |
| 1349 | Make_Defining_Identifier (Loc, New_Internal_Name ('S')), |
| 1350 | Constant_Present => True, |
| 1351 | Object_Definition => |
| 1352 | New_Reference_To (RTE (RE_Storage_Offset), Loc), |
| 1353 | Expression => |
| 1354 | Make_Op_Subtract (Loc, |
| 1355 | Left_Opnd => |
| 1356 | Unchecked_Convert_To |
| 1357 | (RTE (RE_Storage_Offset), |
| 1358 | Make_Attribute_Reference (Loc, |
| 1359 | Prefix => |
| 1360 | New_Reference_To |
| 1361 | (Defining_Identifier (Formal), Loc), |
| 1362 | Attribute_Name => Name_Address)), |
| 1363 | Right_Opnd => |
| cc60bd16 |
1364 | Offset_To_Top)); |
| aad6babd |
1365 | |
| 725a69d2 |
1366 | Decl_2 := |
| 1367 | Make_Object_Declaration (Loc, |
| 1368 | Defining_Identifier => |
| 1369 | Make_Defining_Identifier (Loc, New_Internal_Name ('S')), |
| 1370 | Constant_Present => True, |
| 1371 | Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc), |
| 1372 | Expression => |
| 1373 | Unchecked_Convert_To |
| 1374 | (RTE (RE_Addr_Ptr), |
| 1375 | New_Reference_To (Defining_Identifier (Decl_1), Loc))); |
| aad6babd |
1376 | |
| 725a69d2 |
1377 | Append_To (Decl, Decl_1); |
| 1378 | Append_To (Decl, Decl_2); |
| 952af0b9 |
1379 | |
| 17e14451 |
1380 | -- Reference the new actual. Generate: |
| 1381 | -- Target_Formal (S2.all) |
| aad6babd |
1382 | |
| 725a69d2 |
1383 | Append_To (Actuals, |
| 1384 | Unchecked_Convert_To |
| 17e14451 |
1385 | (Etype (Target_Formal), |
| 725a69d2 |
1386 | Make_Explicit_Dereference (Loc, |
| 1387 | New_Reference_To (Defining_Identifier (Decl_2), Loc)))); |
| aad6babd |
1388 | |
| 725a69d2 |
1389 | -- No special management required for this actual |
| aad6babd |
1390 | |
| 725a69d2 |
1391 | else |
| 1392 | Append_To (Actuals, |
| 1393 | New_Reference_To (Defining_Identifier (Formal), Loc)); |
| 1394 | end if; |
| 1395 | |
| 1396 | Next_Formal (Target_Formal); |
| aad6babd |
1397 | Next (Formal); |
| 1398 | end loop; |
| 1399 | |
| 725a69d2 |
1400 | Thunk_Id := |
| 1401 | Make_Defining_Identifier (Loc, |
| 1402 | Chars => New_Internal_Name ('T')); |
| 1403 | |
| e7e688dd |
1404 | Set_Is_Thunk (Thunk_Id); |
| 1405 | |
| d62940bf |
1406 | if Ekind (Target) = E_Procedure then |
| 725a69d2 |
1407 | Thunk_Code := |
| aad6babd |
1408 | Make_Subprogram_Body (Loc, |
| 1409 | Specification => |
| 1410 | Make_Procedure_Specification (Loc, |
| 1411 | Defining_Unit_Name => Thunk_Id, |
| 1412 | Parameter_Specifications => Formals), |
| 1413 | Declarations => Decl, |
| 1414 | Handled_Statement_Sequence => |
| 1415 | Make_Handled_Sequence_Of_Statements (Loc, |
| 1416 | Statements => New_List ( |
| 1417 | Make_Procedure_Call_Statement (Loc, |
| 725a69d2 |
1418 | Name => New_Occurrence_Of (Target, Loc), |
| 1419 | Parameter_Associations => Actuals)))); |
| aad6babd |
1420 | |
| d62940bf |
1421 | else pragma Assert (Ekind (Target) = E_Function); |
| aad6babd |
1422 | |
| 725a69d2 |
1423 | Thunk_Code := |
| aad6babd |
1424 | Make_Subprogram_Body (Loc, |
| 1425 | Specification => |
| 1426 | Make_Function_Specification (Loc, |
| 1427 | Defining_Unit_Name => Thunk_Id, |
| 1428 | Parameter_Specifications => Formals, |
| d62940bf |
1429 | Result_Definition => |
| 1430 | New_Copy (Result_Definition (Parent (Target)))), |
| aad6babd |
1431 | Declarations => Decl, |
| 1432 | Handled_Statement_Sequence => |
| 1433 | Make_Handled_Sequence_Of_Statements (Loc, |
| 1434 | Statements => New_List ( |
| 17e14451 |
1435 | Make_Simple_Return_Statement (Loc, |
| aad6babd |
1436 | Make_Function_Call (Loc, |
| 1437 | Name => New_Occurrence_Of (Target, Loc), |
| 1438 | Parameter_Associations => Actuals))))); |
| 1439 | end if; |
| aad6babd |
1440 | end Expand_Interface_Thunk; |
| 1441 | |
| 24971415 |
1442 | ------------ |
| 1443 | -- Has_DT -- |
| 1444 | ------------ |
| 1445 | |
| 1446 | function Has_DT (Typ : Entity_Id) return Boolean is |
| 1447 | begin |
| 1448 | return not Is_Interface (Typ) |
| 1449 | and then not Restriction_Active (No_Dispatching_Calls); |
| 1450 | end Has_DT; |
| 1451 | |
| af647dc7 |
1452 | ------------------------------------- |
| 1453 | -- Is_Predefined_Dispatching_Alias -- |
| 1454 | ------------------------------------- |
| 1455 | |
| 1456 | function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean |
| 1457 | is |
| 1458 | E : Entity_Id; |
| 1459 | |
| 1460 | begin |
| 1461 | if not Is_Predefined_Dispatching_Operation (Prim) |
| 1462 | and then Present (Alias (Prim)) |
| 1463 | then |
| 1464 | E := Prim; |
| 1465 | while Present (Alias (E)) loop |
| 1466 | E := Alias (E); |
| 1467 | end loop; |
| 1468 | |
| 1469 | if Is_Predefined_Dispatching_Operation (E) then |
| 1470 | return True; |
| 1471 | end if; |
| 1472 | end if; |
| 1473 | |
| 1474 | return False; |
| 1475 | end Is_Predefined_Dispatching_Alias; |
| 1476 | |
| 76a1c25b |
1477 | ---------------------------------------- |
| 1478 | -- Make_Disp_Asynchronous_Select_Body -- |
| 1479 | ---------------------------------------- |
| ee6ba406 |
1480 | |
| cdb1c38f |
1481 | -- For interface types, generate: |
| 1482 | |
| 1483 | -- procedure _Disp_Asynchronous_Select |
| 1484 | -- (T : in out <Typ>; |
| 1485 | -- S : Integer; |
| 1486 | -- P : System.Address; |
| 1487 | -- B : out System.Storage_Elements.Dummy_Communication_Block; |
| 1488 | -- F : out Boolean) |
| 1489 | -- is |
| 1490 | -- begin |
| 1491 | -- null; |
| 1492 | -- end _Disp_Asynchronous_Select; |
| 1493 | |
| 1494 | -- For protected types, generate: |
| 1495 | |
| 1496 | -- procedure _Disp_Asynchronous_Select |
| 1497 | -- (T : in out <Typ>; |
| 1498 | -- S : Integer; |
| 1499 | -- P : System.Address; |
| 1500 | -- B : out System.Storage_Elements.Dummy_Communication_Block; |
| 1501 | -- F : out Boolean) |
| 1502 | -- is |
| 1503 | -- I : Integer := |
| 1504 | -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S)); |
| 1505 | -- Bnn : System.Tasking.Protected_Objects.Operations. |
| 1506 | -- Communication_Block; |
| 1507 | -- begin |
| 1508 | -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call |
| 1509 | -- (T._object'Access, |
| 1510 | -- System.Tasking.Protected_Objects.Protected_Entry_Index (I), |
| 1511 | -- P, |
| 1512 | -- System.Tasking.Asynchronous_Call, |
| 1513 | -- Bnn); |
| 1514 | -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn); |
| 1515 | -- end _Disp_Asynchronous_Select; |
| 1516 | |
| 1517 | -- For task types, generate: |
| 1518 | |
| 1519 | -- procedure _Disp_Asynchronous_Select |
| 1520 | -- (T : in out <Typ>; |
| 1521 | -- S : Integer; |
| 1522 | -- P : System.Address; |
| 1523 | -- B : out System.Storage_Elements.Dummy_Communication_Block; |
| 1524 | -- F : out Boolean) |
| 1525 | -- is |
| 1526 | -- I : Integer := |
| 1527 | -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S)); |
| 1528 | -- begin |
| 1529 | -- System.Tasking.Rendezvous.Task_Entry_Call |
| 1530 | -- (T._task_id, |
| 1531 | -- System.Tasking.Task_Entry_Index (I), |
| 1532 | -- P, |
| 1533 | -- System.Tasking.Asynchronous_Call, |
| 1534 | -- F); |
| 1535 | -- end _Disp_Asynchronous_Select; |
| 1536 | |
| 76a1c25b |
1537 | function Make_Disp_Asynchronous_Select_Body |
| 1538 | (Typ : Entity_Id) return Node_Id |
| 1539 | is |
| 725a69d2 |
1540 | Com_Block : Entity_Id; |
| 1541 | Conc_Typ : Entity_Id := Empty; |
| 1542 | Decls : constant List_Id := New_List; |
| 1543 | DT_Ptr : Entity_Id; |
| 1544 | Loc : constant Source_Ptr := Sloc (Typ); |
| acf97c11 |
1545 | Obj_Ref : Node_Id; |
| 725a69d2 |
1546 | Stmts : constant List_Id := New_List; |
| ee6ba406 |
1547 | |
| 1548 | begin |
| 68f95949 |
1549 | pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| 1550 | |
| 952af0b9 |
1551 | -- Null body is generated for interface types |
| 1552 | |
| 76a1c25b |
1553 | if Is_Interface (Typ) then |
| 1554 | return |
| 1555 | Make_Subprogram_Body (Loc, |
| 1556 | Specification => |
| 1557 | Make_Disp_Asynchronous_Select_Spec (Typ), |
| 1558 | Declarations => |
| 1559 | New_List, |
| 1560 | Handled_Statement_Sequence => |
| 1561 | Make_Handled_Sequence_Of_Statements (Loc, |
| 1562 | New_List (Make_Null_Statement (Loc)))); |
| 9dfe12ae |
1563 | end if; |
| 1564 | |
| 76a1c25b |
1565 | DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); |
| aad6babd |
1566 | |
| 952af0b9 |
1567 | if Is_Concurrent_Record_Type (Typ) then |
| 1568 | Conc_Typ := Corresponding_Concurrent_Type (Typ); |
| aad6babd |
1569 | |
| 76a1c25b |
1570 | -- Generate: |
| cdb1c38f |
1571 | -- I : Integer := |
| 1572 | -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S); |
| aad6babd |
1573 | |
| 76a1c25b |
1574 | -- where I will be used to capture the entry index of the primitive |
| 1575 | -- wrapper at position S. |
| aad6babd |
1576 | |
| 76a1c25b |
1577 | Append_To (Decls, |
| 1578 | Make_Object_Declaration (Loc, |
| 1579 | Defining_Identifier => |
| 1580 | Make_Defining_Identifier (Loc, Name_uI), |
| 1581 | Object_Definition => |
| 1582 | New_Reference_To (Standard_Integer, Loc), |
| 1583 | Expression => |
| 725a69d2 |
1584 | Make_Function_Call (Loc, |
| cdb1c38f |
1585 | Name => |
| 1586 | New_Reference_To (RTE (RE_Get_Entry_Index), Loc), |
| 1587 | Parameter_Associations => |
| 1588 | New_List ( |
| 1589 | Unchecked_Convert_To (RTE (RE_Tag), |
| 1590 | New_Reference_To (DT_Ptr, Loc)), |
| 1591 | Make_Identifier (Loc, Name_uS))))); |
| aad6babd |
1592 | |
| 76a1c25b |
1593 | if Ekind (Conc_Typ) = E_Protected_Type then |
| aad6babd |
1594 | |
| 725a69d2 |
1595 | -- Generate: |
| cdb1c38f |
1596 | -- Bnn : Communication_Block; |
| 725a69d2 |
1597 | |
| 1598 | Com_Block := |
| 1599 | Make_Defining_Identifier (Loc, New_Internal_Name ('B')); |
| 1600 | |
| 1601 | Append_To (Decls, |
| 1602 | Make_Object_Declaration (Loc, |
| 1603 | Defining_Identifier => |
| 1604 | Com_Block, |
| 1605 | Object_Definition => |
| 1606 | New_Reference_To (RTE (RE_Communication_Block), Loc))); |
| 1607 | |
| acf97c11 |
1608 | -- Build T._object'Access for calls below |
| aad6babd |
1609 | |
| acf97c11 |
1610 | Obj_Ref := |
| 1611 | Make_Attribute_Reference (Loc, |
| 1612 | Attribute_Name => Name_Unchecked_Access, |
| 1613 | Prefix => |
| 1614 | Make_Selected_Component (Loc, |
| 1615 | Prefix => Make_Identifier (Loc, Name_uT), |
| 1616 | Selector_Name => Make_Identifier (Loc, Name_uObject))); |
| aad6babd |
1617 | |
| acf97c11 |
1618 | case Corresponding_Runtime_Package (Conc_Typ) is |
| 1619 | when System_Tasking_Protected_Objects_Entries => |
| aad6babd |
1620 | |
| acf97c11 |
1621 | -- Generate: |
| 1622 | -- Protected_Entry_Call |
| 1623 | -- (T._object'Access, -- Object |
| 1624 | -- Protected_Entry_Index! (I), -- E |
| 1625 | -- P, -- Uninterpreted_Data |
| 1626 | -- Asynchronous_Call, -- Mode |
| 1627 | -- Bnn); -- Communication_Block |
| 1628 | |
| 1629 | -- where T is the protected object, I is the entry index, P |
| 1630 | -- is the wrapped parameters and B is the name of the |
| 1631 | -- communication block. |
| 1632 | |
| 1633 | Append_To (Stmts, |
| 1634 | Make_Procedure_Call_Statement (Loc, |
| 1635 | Name => |
| 1636 | New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), |
| 1637 | Parameter_Associations => |
| 1638 | New_List ( |
| 1639 | Obj_Ref, |
| aad6babd |
1640 | |
| acf97c11 |
1641 | Make_Unchecked_Type_Conversion (Loc, -- entry index |
| 1642 | Subtype_Mark => |
| 1643 | New_Reference_To |
| 1644 | (RTE (RE_Protected_Entry_Index), Loc), |
| 1645 | Expression => Make_Identifier (Loc, Name_uI)), |
| d62940bf |
1646 | |
| acf97c11 |
1647 | Make_Identifier (Loc, Name_uP), -- parameter block |
| 1648 | New_Reference_To ( -- Asynchronous_Call |
| 1649 | RTE (RE_Asynchronous_Call), Loc), |
| 1650 | |
| 1651 | New_Reference_To (Com_Block, Loc)))); -- comm block |
| 1652 | |
| 1653 | when System_Tasking_Protected_Objects_Single_Entry => |
| 1654 | |
| 1655 | -- Generate: |
| 1656 | -- procedure Protected_Single_Entry_Call |
| 1657 | -- (Object : Protection_Entry_Access; |
| 1658 | -- Uninterpreted_Data : System.Address; |
| 1659 | -- Mode : Call_Modes); |
| 725a69d2 |
1660 | |
| acf97c11 |
1661 | Append_To (Stmts, |
| 1662 | Make_Procedure_Call_Statement (Loc, |
| 1663 | Name => |
| 1664 | New_Reference_To |
| 1665 | (RTE (RE_Protected_Single_Entry_Call), Loc), |
| 1666 | Parameter_Associations => |
| 1667 | New_List ( |
| 1668 | Obj_Ref, |
| 1669 | |
| 1670 | Make_Attribute_Reference (Loc, |
| 1671 | Prefix => Make_Identifier (Loc, Name_uP), |
| 1672 | Attribute_Name => Name_Address), |
| 1673 | |
| 1674 | New_Reference_To |
| 1675 | (RTE (RE_Asynchronous_Call), Loc)))); |
| 1676 | |
| 1677 | when others => |
| 1678 | raise Program_Error; |
| 1679 | end case; |
| 725a69d2 |
1680 | |
| 1681 | -- Generate: |
| cdb1c38f |
1682 | -- B := Dummy_Communication_Block (Bnn); |
| 725a69d2 |
1683 | |
| 1684 | Append_To (Stmts, |
| 1685 | Make_Assignment_Statement (Loc, |
| 1686 | Name => |
| 1687 | Make_Identifier (Loc, Name_uB), |
| 1688 | Expression => |
| 1689 | Make_Unchecked_Type_Conversion (Loc, |
| 1690 | Subtype_Mark => |
| 1691 | New_Reference_To ( |
| 1692 | RTE (RE_Dummy_Communication_Block), Loc), |
| 1693 | Expression => |
| 1694 | New_Reference_To (Com_Block, Loc)))); |
| 1695 | |
| 76a1c25b |
1696 | else |
| 1697 | pragma Assert (Ekind (Conc_Typ) = E_Task_Type); |
| d62940bf |
1698 | |
| 76a1c25b |
1699 | -- Generate: |
| cdb1c38f |
1700 | -- Task_Entry_Call |
| 1701 | -- (T._task_id, -- Acceptor |
| 1702 | -- Task_Entry_Index! (I), -- E |
| 1703 | -- P, -- Uninterpreted_Data |
| 1704 | -- Asynchronous_Call, -- Mode |
| 1705 | -- F); -- Rendezvous_Successful |
| ee6ba406 |
1706 | |
| acf97c11 |
1707 | -- where T is the task object, I is the entry index, P is the |
| 76a1c25b |
1708 | -- wrapped parameters and F is the status flag. |
| ee6ba406 |
1709 | |
| 76a1c25b |
1710 | Append_To (Stmts, |
| 1711 | Make_Procedure_Call_Statement (Loc, |
| 1712 | Name => |
| 1713 | New_Reference_To (RTE (RE_Task_Entry_Call), Loc), |
| 1714 | Parameter_Associations => |
| 1715 | New_List ( |
| 76a1c25b |
1716 | Make_Selected_Component (Loc, -- T._task_id |
| 1717 | Prefix => |
| 1718 | Make_Identifier (Loc, Name_uT), |
| 1719 | Selector_Name => |
| 1720 | Make_Identifier (Loc, Name_uTask_Id)), |
| ee6ba406 |
1721 | |
| 76a1c25b |
1722 | Make_Unchecked_Type_Conversion (Loc, -- entry index |
| 1723 | Subtype_Mark => |
| 1724 | New_Reference_To (RTE (RE_Task_Entry_Index), Loc), |
| 1725 | Expression => |
| 1726 | Make_Identifier (Loc, Name_uI)), |
| ee6ba406 |
1727 | |
| 76a1c25b |
1728 | Make_Identifier (Loc, Name_uP), -- parameter block |
| 1729 | New_Reference_To ( -- Asynchronous_Call |
| 1730 | RTE (RE_Asynchronous_Call), Loc), |
| 1731 | Make_Identifier (Loc, Name_uF)))); -- status flag |
| 1732 | end if; |
| 76a1c25b |
1733 | end if; |
| ee6ba406 |
1734 | |
| 76a1c25b |
1735 | return |
| 1736 | Make_Subprogram_Body (Loc, |
| 1737 | Specification => |
| 1738 | Make_Disp_Asynchronous_Select_Spec (Typ), |
| 1739 | Declarations => |
| 1740 | Decls, |
| 1741 | Handled_Statement_Sequence => |
| 1742 | Make_Handled_Sequence_Of_Statements (Loc, Stmts)); |
| 1743 | end Make_Disp_Asynchronous_Select_Body; |
| ee6ba406 |
1744 | |
| 76a1c25b |
1745 | ---------------------------------------- |
| 1746 | -- Make_Disp_Asynchronous_Select_Spec -- |
| 1747 | ---------------------------------------- |
| ee6ba406 |
1748 | |
| 76a1c25b |
1749 | function Make_Disp_Asynchronous_Select_Spec |
| 1750 | (Typ : Entity_Id) return Node_Id |
| 1751 | is |
| 1752 | Loc : constant Source_Ptr := Sloc (Typ); |
| 1753 | Def_Id : constant Node_Id := |
| 1754 | Make_Defining_Identifier (Loc, |
| 1755 | Name_uDisp_Asynchronous_Select); |
| 1756 | Params : constant List_Id := New_List; |
| ee6ba406 |
1757 | |
| 76a1c25b |
1758 | begin |
| 68f95949 |
1759 | pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| 1760 | |
| 725a69d2 |
1761 | -- T : in out Typ; -- Object parameter |
| 1762 | -- S : Integer; -- Primitive operation slot |
| 1763 | -- P : Address; -- Wrapped parameters |
| 1764 | -- B : out Dummy_Communication_Block; -- Communication block dummy |
| 1765 | -- F : out Boolean; -- Status flag |
| ee6ba406 |
1766 | |
| 725a69d2 |
1767 | Append_List_To (Params, New_List ( |
| 1768 | |
| 1769 | Make_Parameter_Specification (Loc, |
| 1770 | Defining_Identifier => |
| 1771 | Make_Defining_Identifier (Loc, Name_uT), |
| 1772 | Parameter_Type => |
| 1773 | New_Reference_To (Typ, Loc), |
| 1774 | In_Present => True, |
| 1775 | Out_Present => True), |
| 1776 | |
| 1777 | Make_Parameter_Specification (Loc, |
| 1778 | Defining_Identifier => |
| 1779 | Make_Defining_Identifier (Loc, Name_uS), |
| 1780 | Parameter_Type => |
| 1781 | New_Reference_To (Standard_Integer, Loc)), |
| 1782 | |
| 1783 | Make_Parameter_Specification (Loc, |
| 1784 | Defining_Identifier => |
| 1785 | Make_Defining_Identifier (Loc, Name_uP), |
| 1786 | Parameter_Type => |
| 1787 | New_Reference_To (RTE (RE_Address), Loc)), |
| 1788 | |
| 1789 | Make_Parameter_Specification (Loc, |
| 1790 | Defining_Identifier => |
| 1791 | Make_Defining_Identifier (Loc, Name_uB), |
| 1792 | Parameter_Type => |
| 1793 | New_Reference_To (RTE (RE_Dummy_Communication_Block), Loc), |
| 1794 | Out_Present => True), |
| ee6ba406 |
1795 | |
| 725a69d2 |
1796 | Make_Parameter_Specification (Loc, |
| 1797 | Defining_Identifier => |
| 1798 | Make_Defining_Identifier (Loc, Name_uF), |
| 1799 | Parameter_Type => |
| 1800 | New_Reference_To (Standard_Boolean, Loc), |
| 1801 | Out_Present => True))); |
| 7189d17f |
1802 | |
| 76a1c25b |
1803 | return |
| 725a69d2 |
1804 | Make_Procedure_Specification (Loc, |
| 1805 | Defining_Unit_Name => Def_Id, |
| 1806 | Parameter_Specifications => Params); |
| 76a1c25b |
1807 | end Make_Disp_Asynchronous_Select_Spec; |
| ee6ba406 |
1808 | |
| 76a1c25b |
1809 | --------------------------------------- |
| 1810 | -- Make_Disp_Conditional_Select_Body -- |
| 1811 | --------------------------------------- |
| ee6ba406 |
1812 | |
| cdb1c38f |
1813 | -- For interface types, generate: |
| 1814 | |
| 1815 | -- procedure _Disp_Conditional_Select |
| 1816 | -- (T : in out <Typ>; |
| 1817 | -- S : Integer; |
| 1818 | -- P : System.Address; |
| 1819 | -- C : out Ada.Tags.Prim_Op_Kind; |
| 1820 | -- F : out Boolean) |
| 1821 | -- is |
| 1822 | -- begin |
| 1823 | -- null; |
| 1824 | -- end _Disp_Conditional_Select; |
| 1825 | |
| 1826 | -- For protected types, generate: |
| 1827 | |
| 1828 | -- procedure _Disp_Conditional_Select |
| 1829 | -- (T : in out <Typ>; |
| 1830 | -- S : Integer; |
| 1831 | -- P : System.Address; |
| 1832 | -- C : out Ada.Tags.Prim_Op_Kind; |
| 1833 | -- F : out Boolean) |
| 1834 | -- is |
| 1835 | -- I : Integer; |
| 1836 | -- Bnn : System.Tasking.Protected_Objects.Operations. |
| 1837 | -- Communication_Block; |
| 1838 | |
| 1839 | -- begin |
| 1840 | -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S)); |
| 1841 | |
| 1842 | -- if C = Ada.Tags.POK_Procedure |
| 1843 | -- or else C = Ada.Tags.POK_Protected_Procedure |
| 1844 | -- or else C = Ada.Tags.POK_Task_Procedure |
| 1845 | -- then |
| 1846 | -- F := True; |
| 1847 | -- return; |
| 1848 | -- end if; |
| 1849 | |
| 1850 | -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S)); |
| 1851 | -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call |
| 1852 | -- (T.object'Access, |
| 1853 | -- System.Tasking.Protected_Objects.Protected_Entry_Index (I), |
| 1854 | -- P, |
| 1855 | -- System.Tasking.Conditional_Call, |
| 1856 | -- Bnn); |
| 1857 | -- F := not Cancelled (Bnn); |
| 1858 | -- end _Disp_Conditional_Select; |
| 1859 | |
| 1860 | -- For task types, generate: |
| 1861 | |
| 1862 | -- procedure _Disp_Conditional_Select |
| 1863 | -- (T : in out <Typ>; |
| 1864 | -- S : Integer; |
| 1865 | -- P : System.Address; |
| 1866 | -- C : out Ada.Tags.Prim_Op_Kind; |
| 1867 | -- F : out Boolean) |
| 1868 | -- is |
| 1869 | -- I : Integer; |
| 1870 | |
| 1871 | -- begin |
| 1872 | -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S)); |
| 1873 | -- System.Tasking.Rendezvous.Task_Entry_Call |
| 1874 | -- (T._task_id, |
| 1875 | -- System.Tasking.Task_Entry_Index (I), |
| 1876 | -- P, |
| 1877 | -- System.Tasking.Conditional_Call, |
| 1878 | -- F); |
| 1879 | -- end _Disp_Conditional_Select; |
| 1880 | |
| 76a1c25b |
1881 | function Make_Disp_Conditional_Select_Body |
| 1882 | (Typ : Entity_Id) return Node_Id |
| 1883 | is |
| 1884 | Loc : constant Source_Ptr := Sloc (Typ); |
| 1885 | Blk_Nam : Entity_Id; |
| 1886 | Conc_Typ : Entity_Id := Empty; |
| 1887 | Decls : constant List_Id := New_List; |
| 1888 | DT_Ptr : Entity_Id; |
| acf97c11 |
1889 | Obj_Ref : Node_Id; |
| 76a1c25b |
1890 | Stmts : constant List_Id := New_List; |
| ee6ba406 |
1891 | |
| 76a1c25b |
1892 | begin |
| 68f95949 |
1893 | pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| 1894 | |
| 952af0b9 |
1895 | -- Null body is generated for interface types |
| 1896 | |
| 76a1c25b |
1897 | if Is_Interface (Typ) then |
| 1898 | return |
| 1899 | Make_Subprogram_Body (Loc, |
| 1900 | Specification => |
| 1901 | Make_Disp_Conditional_Select_Spec (Typ), |
| 1902 | Declarations => |
| 1903 | No_List, |
| 1904 | Handled_Statement_Sequence => |
| 1905 | Make_Handled_Sequence_Of_Statements (Loc, |
| 1906 | New_List (Make_Null_Statement (Loc)))); |
| 1907 | end if; |
| ee6ba406 |
1908 | |
| 76a1c25b |
1909 | DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); |
| ee6ba406 |
1910 | |
| 952af0b9 |
1911 | if Is_Concurrent_Record_Type (Typ) then |
| 1912 | Conc_Typ := Corresponding_Concurrent_Type (Typ); |
| ee6ba406 |
1913 | |
| 76a1c25b |
1914 | -- Generate: |
| 1915 | -- I : Integer; |
| ee6ba406 |
1916 | |
| 76a1c25b |
1917 | -- where I will be used to capture the entry index of the primitive |
| 1918 | -- wrapper at position S. |
| ee6ba406 |
1919 | |
| 76a1c25b |
1920 | Append_To (Decls, |
| 1921 | Make_Object_Declaration (Loc, |
| 1922 | Defining_Identifier => |
| 1923 | Make_Defining_Identifier (Loc, Name_uI), |
| 1924 | Object_Definition => |
| 1925 | New_Reference_To (Standard_Integer, Loc))); |
| ee6ba406 |
1926 | |
| 952af0b9 |
1927 | -- Generate: |
| cdb1c38f |
1928 | -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S); |
| ee6ba406 |
1929 | |
| 952af0b9 |
1930 | -- if C = POK_Procedure |
| 1931 | -- or else C = POK_Protected_Procedure |
| 1932 | -- or else C = POK_Task_Procedure; |
| 1933 | -- then |
| 1934 | -- F := True; |
| 1935 | -- return; |
| 1936 | -- end if; |
| aad6babd |
1937 | |
| 725a69d2 |
1938 | Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts); |
| aad6babd |
1939 | |
| 76a1c25b |
1940 | -- Generate: |
| 1941 | -- Bnn : Communication_Block; |
| aad6babd |
1942 | |
| cdb1c38f |
1943 | -- where Bnn is the name of the communication block used in the |
| 1944 | -- call to Protected_Entry_Call. |
| aad6babd |
1945 | |
| 76a1c25b |
1946 | Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); |
| aad6babd |
1947 | |
| 76a1c25b |
1948 | Append_To (Decls, |
| 1949 | Make_Object_Declaration (Loc, |
| 1950 | Defining_Identifier => |
| 1951 | Blk_Nam, |
| 1952 | Object_Definition => |
| 1953 | New_Reference_To (RTE (RE_Communication_Block), Loc))); |
| aad6babd |
1954 | |
| 76a1c25b |
1955 | -- Generate: |
| cdb1c38f |
1956 | -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S); |
| aad6babd |
1957 | |
| 76a1c25b |
1958 | -- I is the entry index and S is the dispatch table slot |
| aad6babd |
1959 | |
| 76a1c25b |
1960 | Append_To (Stmts, |
| 1961 | Make_Assignment_Statement (Loc, |
| 1962 | Name => |
| 1963 | Make_Identifier (Loc, Name_uI), |
| 1964 | Expression => |
| 725a69d2 |
1965 | Make_Function_Call (Loc, |
| cdb1c38f |
1966 | Name => |
| 1967 | New_Reference_To (RTE (RE_Get_Entry_Index), Loc), |
| 1968 | Parameter_Associations => |
| 1969 | New_List ( |
| 1970 | Unchecked_Convert_To (RTE (RE_Tag), |
| 1971 | New_Reference_To (DT_Ptr, Loc)), |
| 1972 | Make_Identifier (Loc, Name_uS))))); |
| ee6ba406 |
1973 | |
| 76a1c25b |
1974 | if Ekind (Conc_Typ) = E_Protected_Type then |
| ee6ba406 |
1975 | |
| acf97c11 |
1976 | Obj_Ref := -- T._object'Access |
| 1977 | Make_Attribute_Reference (Loc, |
| 1978 | Attribute_Name => Name_Unchecked_Access, |
| 1979 | Prefix => |
| 1980 | Make_Selected_Component (Loc, |
| 1981 | Prefix => Make_Identifier (Loc, Name_uT), |
| 1982 | Selector_Name => Make_Identifier (Loc, Name_uObject))); |
| ee6ba406 |
1983 | |
| acf97c11 |
1984 | case Corresponding_Runtime_Package (Conc_Typ) is |
| 1985 | when System_Tasking_Protected_Objects_Entries => |
| 1986 | -- Generate: |
| e1c20931 |
1987 | |
| acf97c11 |
1988 | -- Protected_Entry_Call |
| 1989 | -- (T._object'Access, -- Object |
| 1990 | -- Protected_Entry_Index! (I), -- E |
| 1991 | -- P, -- Uninterpreted_Data |
| 1992 | -- Conditional_Call, -- Mode |
| 1993 | -- Bnn); -- Block |
| e1c20931 |
1994 | |
| acf97c11 |
1995 | -- where T is the protected object, I is the entry index, P |
| 1996 | -- are the wrapped parameters and Bnn is the name of the |
| 1997 | -- communication block. |
| d62940bf |
1998 | |
| acf97c11 |
1999 | Append_To (Stmts, |
| 2000 | Make_Procedure_Call_Statement (Loc, |
| 2001 | Name => |
| 2002 | New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), |
| 2003 | Parameter_Associations => |
| 2004 | New_List ( |
| 2005 | Obj_Ref, |
| d62940bf |
2006 | |
| acf97c11 |
2007 | Make_Unchecked_Type_Conversion (Loc, -- entry index |
| 2008 | Subtype_Mark => |
| 2009 | New_Reference_To |
| 2010 | (RTE (RE_Protected_Entry_Index), Loc), |
| 2011 | Expression => Make_Identifier (Loc, Name_uI)), |
| 2012 | |
| 2013 | Make_Identifier (Loc, Name_uP), -- parameter block |
| 2014 | |
| 2015 | New_Reference_To ( -- Conditional_Call |
| 2016 | RTE (RE_Conditional_Call), Loc), |
| 2017 | New_Reference_To ( -- Bnn |
| 2018 | Blk_Nam, Loc)))); |
| 2019 | |
| 2020 | when System_Tasking_Protected_Objects_Single_Entry => |
| 2021 | |
| 2022 | -- If we are compiling for a restricted run-time, the call |
| 2023 | -- uses the simpler form. |
| 2024 | |
| 2025 | Append_To (Stmts, |
| 2026 | Make_Procedure_Call_Statement (Loc, |
| 2027 | Name => |
| 2028 | New_Reference_To |
| 2029 | (RTE (RE_Protected_Single_Entry_Call), Loc), |
| 2030 | Parameter_Associations => |
| 2031 | New_List ( |
| 2032 | Obj_Ref, |
| 2033 | |
| 2034 | Make_Attribute_Reference (Loc, |
| 2035 | Prefix => Make_Identifier (Loc, Name_uP), |
| 2036 | Attribute_Name => Name_Address), |
| 2037 | |
| 2038 | New_Reference_To |
| 2039 | (RTE (RE_Conditional_Call), Loc)))); |
| 2040 | when others => |
| 2041 | raise Program_Error; |
| 2042 | end case; |
| d62940bf |
2043 | |
| 76a1c25b |
2044 | -- Generate: |
| 2045 | -- F := not Cancelled (Bnn); |
| e1c20931 |
2046 | |
| 76a1c25b |
2047 | -- where F is the success flag. The status of Cancelled is negated |
| 2048 | -- in order to match the behaviour of the version for task types. |
| e1c20931 |
2049 | |
| 76a1c25b |
2050 | Append_To (Stmts, |
| 2051 | Make_Assignment_Statement (Loc, |
| 2052 | Name => |
| 2053 | Make_Identifier (Loc, Name_uF), |
| 2054 | Expression => |
| 2055 | Make_Op_Not (Loc, |
| 2056 | Right_Opnd => |
| 2057 | Make_Function_Call (Loc, |
| 2058 | Name => |
| 2059 | New_Reference_To (RTE (RE_Cancelled), Loc), |
| 2060 | Parameter_Associations => |
| 2061 | New_List ( |
| 2062 | New_Reference_To (Blk_Nam, Loc)))))); |
| 2063 | else |
| 2064 | pragma Assert (Ekind (Conc_Typ) = E_Task_Type); |
| d62940bf |
2065 | |
| 76a1c25b |
2066 | -- Generate: |
| cdb1c38f |
2067 | -- Task_Entry_Call |
| 2068 | -- (T._task_id, -- Acceptor |
| 2069 | -- Task_Entry_Index! (I), -- E |
| 2070 | -- P, -- Uninterpreted_Data |
| 2071 | -- Conditional_Call, -- Mode |
| 2072 | -- F); -- Rendezvous_Successful |
| d62940bf |
2073 | |
| 76a1c25b |
2074 | -- where T is the task object, I is the entry index, P are the |
| 2075 | -- wrapped parameters and F is the status flag. |
| e1c20931 |
2076 | |
| 76a1c25b |
2077 | Append_To (Stmts, |
| 2078 | Make_Procedure_Call_Statement (Loc, |
| 2079 | Name => |
| 2080 | New_Reference_To (RTE (RE_Task_Entry_Call), Loc), |
| 2081 | Parameter_Associations => |
| 2082 | New_List ( |
| 2083 | |
| 2084 | Make_Selected_Component (Loc, -- T._task_id |
| 2085 | Prefix => |
| 2086 | Make_Identifier (Loc, Name_uT), |
| 2087 | Selector_Name => |
| 2088 | Make_Identifier (Loc, Name_uTask_Id)), |
| 2089 | |
| 2090 | Make_Unchecked_Type_Conversion (Loc, -- entry index |
| 2091 | Subtype_Mark => |
| 2092 | New_Reference_To (RTE (RE_Task_Entry_Index), Loc), |
| 2093 | Expression => |
| 2094 | Make_Identifier (Loc, Name_uI)), |
| 2095 | |
| 2096 | Make_Identifier (Loc, Name_uP), -- parameter block |
| 2097 | New_Reference_To ( -- Conditional_Call |
| 2098 | RTE (RE_Conditional_Call), Loc), |
| 2099 | Make_Identifier (Loc, Name_uF)))); -- status flag |
| d62940bf |
2100 | end if; |
| 76a1c25b |
2101 | end if; |
| 2102 | |
| 2103 | return |
| 2104 | Make_Subprogram_Body (Loc, |
| 2105 | Specification => |
| 2106 | Make_Disp_Conditional_Select_Spec (Typ), |
| 2107 | Declarations => |
| 2108 | Decls, |
| 2109 | Handled_Statement_Sequence => |
| 2110 | Make_Handled_Sequence_Of_Statements (Loc, Stmts)); |
| 2111 | end Make_Disp_Conditional_Select_Body; |
| 2112 | |
| 2113 | --------------------------------------- |
| 2114 | -- Make_Disp_Conditional_Select_Spec -- |
| 2115 | --------------------------------------- |
| 2116 | |
| 2117 | function Make_Disp_Conditional_Select_Spec |
| 2118 | (Typ : Entity_Id) return Node_Id |
| 2119 | is |
| 2120 | Loc : constant Source_Ptr := Sloc (Typ); |
| 2121 | Def_Id : constant Node_Id := |
| 2122 | Make_Defining_Identifier (Loc, |
| 2123 | Name_uDisp_Conditional_Select); |
| 2124 | Params : constant List_Id := New_List; |
| 2125 | |
| 2126 | begin |
| 68f95949 |
2127 | pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| 2128 | |
| 725a69d2 |
2129 | -- T : in out Typ; -- Object parameter |
| 2130 | -- S : Integer; -- Primitive operation slot |
| 2131 | -- P : Address; -- Wrapped parameters |
| 2132 | -- C : out Prim_Op_Kind; -- Call kind |
| 2133 | -- F : out Boolean; -- Status flag |
| 2134 | |
| 2135 | Append_List_To (Params, New_List ( |
| 2136 | |
| 2137 | Make_Parameter_Specification (Loc, |
| 2138 | Defining_Identifier => |
| 2139 | Make_Defining_Identifier (Loc, Name_uT), |
| 2140 | Parameter_Type => |
| 2141 | New_Reference_To (Typ, Loc), |
| 2142 | In_Present => True, |
| 2143 | Out_Present => True), |
| 2144 | |
| 2145 | Make_Parameter_Specification (Loc, |
| 2146 | Defining_Identifier => |
| 2147 | Make_Defining_Identifier (Loc, Name_uS), |
| 2148 | Parameter_Type => |
| 2149 | New_Reference_To (Standard_Integer, Loc)), |
| 2150 | |
| 2151 | Make_Parameter_Specification (Loc, |
| 2152 | Defining_Identifier => |
| 2153 | Make_Defining_Identifier (Loc, Name_uP), |
| 2154 | Parameter_Type => |
| 2155 | New_Reference_To (RTE (RE_Address), Loc)), |
| 76a1c25b |
2156 | |
| 725a69d2 |
2157 | Make_Parameter_Specification (Loc, |
| 2158 | Defining_Identifier => |
| 2159 | Make_Defining_Identifier (Loc, Name_uC), |
| 2160 | Parameter_Type => |
| 2161 | New_Reference_To (RTE (RE_Prim_Op_Kind), Loc), |
| 2162 | Out_Present => True), |
| 76a1c25b |
2163 | |
| 725a69d2 |
2164 | Make_Parameter_Specification (Loc, |
| 2165 | Defining_Identifier => |
| 2166 | Make_Defining_Identifier (Loc, Name_uF), |
| 2167 | Parameter_Type => |
| 2168 | New_Reference_To (Standard_Boolean, Loc), |
| 2169 | Out_Present => True))); |
| 76a1c25b |
2170 | |
| 2171 | return |
| 2172 | Make_Procedure_Specification (Loc, |
| 2173 | Defining_Unit_Name => Def_Id, |
| 2174 | Parameter_Specifications => Params); |
| 2175 | end Make_Disp_Conditional_Select_Spec; |
| 2176 | |
| 2177 | ------------------------------------- |
| 2178 | -- Make_Disp_Get_Prim_Op_Kind_Body -- |
| 2179 | ------------------------------------- |
| 2180 | |
| 2181 | function Make_Disp_Get_Prim_Op_Kind_Body |
| 2182 | (Typ : Entity_Id) return Node_Id |
| 2183 | is |
| 2184 | Loc : constant Source_Ptr := Sloc (Typ); |
| 2185 | DT_Ptr : Entity_Id; |
| 2186 | |
| 2187 | begin |
| 68f95949 |
2188 | pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| 2189 | |
| 76a1c25b |
2190 | if Is_Interface (Typ) then |
| 2191 | return |
| 2192 | Make_Subprogram_Body (Loc, |
| 2193 | Specification => |
| 2194 | Make_Disp_Get_Prim_Op_Kind_Spec (Typ), |
| 2195 | Declarations => |
| 2196 | New_List, |
| 2197 | Handled_Statement_Sequence => |
| 2198 | Make_Handled_Sequence_Of_Statements (Loc, |
| 2199 | New_List (Make_Null_Statement (Loc)))); |
| e1c20931 |
2200 | end if; |
| 2201 | |
| 76a1c25b |
2202 | DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); |
| 2203 | |
| d62940bf |
2204 | -- Generate: |
| 76a1c25b |
2205 | -- C := get_prim_op_kind (tag! (<type>VP), S); |
| ee6ba406 |
2206 | |
| 76a1c25b |
2207 | -- where C is the out parameter capturing the call kind and S is the |
| 2208 | -- dispatch table slot number. |
| ee6ba406 |
2209 | |
| 76a1c25b |
2210 | return |
| 2211 | Make_Subprogram_Body (Loc, |
| 2212 | Specification => |
| 2213 | Make_Disp_Get_Prim_Op_Kind_Spec (Typ), |
| 2214 | Declarations => |
| 2215 | New_List, |
| 2216 | Handled_Statement_Sequence => |
| 2217 | Make_Handled_Sequence_Of_Statements (Loc, |
| 2218 | New_List ( |
| 2219 | Make_Assignment_Statement (Loc, |
| 2220 | Name => |
| 2221 | Make_Identifier (Loc, Name_uC), |
| 2222 | Expression => |
| 725a69d2 |
2223 | Make_Function_Call (Loc, |
| 2224 | Name => |
| 2225 | New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc), |
| 2226 | Parameter_Associations => New_List ( |
| 2227 | Unchecked_Convert_To (RTE (RE_Tag), |
| 2228 | New_Reference_To (DT_Ptr, Loc)), |
| 2229 | Make_Identifier (Loc, Name_uS))))))); |
| 76a1c25b |
2230 | end Make_Disp_Get_Prim_Op_Kind_Body; |
| e1c20931 |
2231 | |
| 76a1c25b |
2232 | ------------------------------------- |
| 2233 | -- Make_Disp_Get_Prim_Op_Kind_Spec -- |
| 2234 | ------------------------------------- |
| e1c20931 |
2235 | |
| 76a1c25b |
2236 | function Make_Disp_Get_Prim_Op_Kind_Spec |
| 2237 | (Typ : Entity_Id) return Node_Id |
| 2238 | is |
| 2239 | Loc : constant Source_Ptr := Sloc (Typ); |
| 2240 | Def_Id : constant Node_Id := |
| 2241 | Make_Defining_Identifier (Loc, |
| 2242 | Name_uDisp_Get_Prim_Op_Kind); |
| 2243 | Params : constant List_Id := New_List; |
| e1c20931 |
2244 | |
| 76a1c25b |
2245 | begin |
| 68f95949 |
2246 | pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| 2247 | |
| 725a69d2 |
2248 | -- T : in out Typ; -- Object parameter |
| 2249 | -- S : Integer; -- Primitive operation slot |
| 2250 | -- C : out Prim_Op_Kind; -- Call kind |
| 2251 | |
| 2252 | Append_List_To (Params, New_List ( |
| 2253 | |
| 2254 | Make_Parameter_Specification (Loc, |
| 2255 | Defining_Identifier => |
| 2256 | Make_Defining_Identifier (Loc, Name_uT), |
| 2257 | Parameter_Type => |
| 2258 | New_Reference_To (Typ, Loc), |
| 2259 | In_Present => True, |
| 2260 | Out_Present => True), |
| ee6ba406 |
2261 | |
| 725a69d2 |
2262 | Make_Parameter_Specification (Loc, |
| 2263 | Defining_Identifier => |
| 2264 | Make_Defining_Identifier (Loc, Name_uS), |
| 2265 | Parameter_Type => |
| 2266 | New_Reference_To (Standard_Integer, Loc)), |
| ee6ba406 |
2267 | |
| 725a69d2 |
2268 | Make_Parameter_Specification (Loc, |
| 2269 | Defining_Identifier => |
| 2270 | Make_Defining_Identifier (Loc, Name_uC), |
| 2271 | Parameter_Type => |
| 2272 | New_Reference_To (RTE (RE_Prim_Op_Kind), Loc), |
| 2273 | Out_Present => True))); |
| 76a1c25b |
2274 | |
| 2275 | return |
| 2276 | Make_Procedure_Specification (Loc, |
| 2277 | Defining_Unit_Name => Def_Id, |
| 2278 | Parameter_Specifications => Params); |
| 2279 | end Make_Disp_Get_Prim_Op_Kind_Spec; |
| 2280 | |
| 2281 | -------------------------------- |
| 2282 | -- Make_Disp_Get_Task_Id_Body -- |
| 2283 | -------------------------------- |
| 2284 | |
| 2285 | function Make_Disp_Get_Task_Id_Body |
| 2286 | (Typ : Entity_Id) return Node_Id |
| 2287 | is |
| 2288 | Loc : constant Source_Ptr := Sloc (Typ); |
| 2289 | Ret : Node_Id; |
| 2290 | |
| 2291 | begin |
| 68f95949 |
2292 | pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| 2293 | |
| 76a1c25b |
2294 | if Is_Concurrent_Record_Type (Typ) |
| 2295 | and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type |
| 2296 | then |
| 725a69d2 |
2297 | -- Generate: |
| 2298 | -- return To_Address (_T._task_id); |
| 2299 | |
| 76a1c25b |
2300 | Ret := |
| 17e14451 |
2301 | Make_Simple_Return_Statement (Loc, |
| 76a1c25b |
2302 | Expression => |
| 725a69d2 |
2303 | Make_Unchecked_Type_Conversion (Loc, |
| 2304 | Subtype_Mark => |
| 2305 | New_Reference_To (RTE (RE_Address), Loc), |
| 2306 | Expression => |
| 2307 | Make_Selected_Component (Loc, |
| 2308 | Prefix => |
| 2309 | Make_Identifier (Loc, Name_uT), |
| 2310 | Selector_Name => |
| 2311 | Make_Identifier (Loc, Name_uTask_Id)))); |
| 76a1c25b |
2312 | |
| 2313 | -- A null body is constructed for non-task types |
| 2314 | |
| 2315 | else |
| 725a69d2 |
2316 | -- Generate: |
| 2317 | -- return Null_Address; |
| 2318 | |
| 76a1c25b |
2319 | Ret := |
| 17e14451 |
2320 | Make_Simple_Return_Statement (Loc, |
| 76a1c25b |
2321 | Expression => |
| 725a69d2 |
2322 | New_Reference_To (RTE (RE_Null_Address), Loc)); |
| 76a1c25b |
2323 | end if; |
| 2324 | |
| 2325 | return |
| 2326 | Make_Subprogram_Body (Loc, |
| 2327 | Specification => |
| 2328 | Make_Disp_Get_Task_Id_Spec (Typ), |
| 2329 | Declarations => |
| 2330 | New_List, |
| 2331 | Handled_Statement_Sequence => |
| 2332 | Make_Handled_Sequence_Of_Statements (Loc, |
| 2333 | New_List (Ret))); |
| 2334 | end Make_Disp_Get_Task_Id_Body; |
| 2335 | |
| 2336 | -------------------------------- |
| 2337 | -- Make_Disp_Get_Task_Id_Spec -- |
| 2338 | -------------------------------- |
| 2339 | |
| 2340 | function Make_Disp_Get_Task_Id_Spec |
| 2341 | (Typ : Entity_Id) return Node_Id |
| 2342 | is |
| 725a69d2 |
2343 | Loc : constant Source_Ptr := Sloc (Typ); |
| 76a1c25b |
2344 | |
| 2345 | begin |
| 68f95949 |
2346 | pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| 2347 | |
| 76a1c25b |
2348 | return |
| 2349 | Make_Function_Specification (Loc, |
| 725a69d2 |
2350 | Defining_Unit_Name => |
| 2351 | Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id), |
| 76a1c25b |
2352 | Parameter_Specifications => New_List ( |
| 2353 | Make_Parameter_Specification (Loc, |
| 2354 | Defining_Identifier => |
| 2355 | Make_Defining_Identifier (Loc, Name_uT), |
| 2356 | Parameter_Type => |
| 2357 | New_Reference_To (Typ, Loc))), |
| 2358 | Result_Definition => |
| 725a69d2 |
2359 | New_Reference_To (RTE (RE_Address), Loc)); |
| 76a1c25b |
2360 | end Make_Disp_Get_Task_Id_Spec; |
| 2361 | |
| cdb1c38f |
2362 | ---------------------------- |
| 2363 | -- Make_Disp_Requeue_Body -- |
| 2364 | ---------------------------- |
| 2365 | |
| 2366 | function Make_Disp_Requeue_Body |
| 2367 | (Typ : Entity_Id) return Node_Id |
| 2368 | is |
| 2369 | Loc : constant Source_Ptr := Sloc (Typ); |
| 2370 | Conc_Typ : Entity_Id := Empty; |
| 2371 | Stmts : constant List_Id := New_List; |
| 2372 | |
| 2373 | begin |
| 2374 | pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| 2375 | |
| 2376 | -- Null body is generated for interface types and non-concurrent |
| 2377 | -- tagged types. |
| 2378 | |
| 2379 | if Is_Interface (Typ) |
| 2380 | or else not Is_Concurrent_Record_Type (Typ) |
| 2381 | then |
| 2382 | return |
| 2383 | Make_Subprogram_Body (Loc, |
| 2384 | Specification => |
| 2385 | Make_Disp_Requeue_Spec (Typ), |
| 2386 | Declarations => |
| 2387 | No_List, |
| 2388 | Handled_Statement_Sequence => |
| 2389 | Make_Handled_Sequence_Of_Statements (Loc, |
| 2390 | New_List (Make_Null_Statement (Loc)))); |
| 2391 | end if; |
| 2392 | |
| 2393 | Conc_Typ := Corresponding_Concurrent_Type (Typ); |
| 2394 | |
| 2395 | if Ekind (Conc_Typ) = E_Protected_Type then |
| 2396 | |
| 2397 | -- Generate statements: |
| 2398 | -- if F then |
| 2399 | -- System.Tasking.Protected_Objects.Operations. |
| 2400 | -- Requeue_Protected_Entry |
| 2401 | -- (Protection_Entries_Access (P), |
| 2402 | -- O._object'Unchecked_Access, |
| 2403 | -- Protected_Entry_Index (I), |
| 2404 | -- A); |
| 2405 | -- else |
| 2406 | -- System.Tasking.Protected_Objects.Operations. |
| 2407 | -- Requeue_Task_To_Protected_Entry |
| 2408 | -- (O._object'Unchecked_Access, |
| 2409 | -- Protected_Entry_Index (I), |
| 2410 | -- A); |
| 2411 | -- end if; |
| 2412 | |
| acf97c11 |
2413 | if Restriction_Active (No_Entry_Queue) then |
| 2414 | Append_To (Stmts, Make_Null_Statement (Loc)); |
| 2415 | else |
| 2416 | Append_To (Stmts, |
| 2417 | Make_If_Statement (Loc, |
| 2418 | Condition => |
| 2419 | Make_Identifier (Loc, Name_uF), |
| cdb1c38f |
2420 | |
| acf97c11 |
2421 | Then_Statements => |
| 2422 | New_List ( |
| cdb1c38f |
2423 | |
| acf97c11 |
2424 | -- Call to Requeue_Protected_Entry |
| cdb1c38f |
2425 | |
| acf97c11 |
2426 | Make_Procedure_Call_Statement (Loc, |
| 2427 | Name => |
| 2428 | New_Reference_To ( |
| 2429 | RTE (RE_Requeue_Protected_Entry), Loc), |
| 2430 | Parameter_Associations => |
| 2431 | New_List ( |
| 2432 | |
| 2433 | Make_Unchecked_Type_Conversion (Loc, -- PEA (P) |
| 2434 | Subtype_Mark => |
| 2435 | New_Reference_To ( |
| 2436 | RTE (RE_Protection_Entries_Access), Loc), |
| 2437 | Expression => |
| 2438 | Make_Identifier (Loc, Name_uP)), |
| 2439 | |
| 2440 | Make_Attribute_Reference (Loc, -- O._object'Acc |
| 2441 | Attribute_Name => |
| 2442 | Name_Unchecked_Access, |
| 2443 | Prefix => |
| 2444 | Make_Selected_Component (Loc, |
| 2445 | Prefix => |
| 2446 | Make_Identifier (Loc, Name_uO), |
| 2447 | Selector_Name => |
| 2448 | Make_Identifier (Loc, Name_uObject))), |
| 2449 | |
| 2450 | Make_Unchecked_Type_Conversion (Loc, -- entry index |
| 2451 | Subtype_Mark => |
| 2452 | New_Reference_To ( |
| 2453 | RTE (RE_Protected_Entry_Index), Loc), |
| 2454 | Expression => |
| 2455 | Make_Identifier (Loc, Name_uI)), |
| cdb1c38f |
2456 | |
| acf97c11 |
2457 | Make_Identifier (Loc, Name_uA)))), -- abort status |
| cdb1c38f |
2458 | |
| acf97c11 |
2459 | Else_Statements => |
| 2460 | New_List ( |
| cdb1c38f |
2461 | |
| acf97c11 |
2462 | -- Call to Requeue_Task_To_Protected_Entry |
| cdb1c38f |
2463 | |
| acf97c11 |
2464 | Make_Procedure_Call_Statement (Loc, |
| 2465 | Name => |
| 2466 | New_Reference_To ( |
| 2467 | RTE (RE_Requeue_Task_To_Protected_Entry), Loc), |
| 2468 | Parameter_Associations => |
| 2469 | New_List ( |
| 2470 | |
| 2471 | Make_Attribute_Reference (Loc, -- O._object'Acc |
| 2472 | Attribute_Name => |
| 2473 | Name_Unchecked_Access, |
| 2474 | Prefix => |
| 2475 | Make_Selected_Component (Loc, |
| 2476 | Prefix => |
| 2477 | Make_Identifier (Loc, Name_uO), |
| 2478 | Selector_Name => |
| 2479 | Make_Identifier (Loc, Name_uObject))), |
| 2480 | |
| 2481 | Make_Unchecked_Type_Conversion (Loc, -- entry index |
| 2482 | Subtype_Mark => |
| 2483 | New_Reference_To ( |
| 2484 | RTE (RE_Protected_Entry_Index), Loc), |
| 2485 | Expression => |
| 2486 | Make_Identifier (Loc, Name_uI)), |
| cdb1c38f |
2487 | |
| acf97c11 |
2488 | Make_Identifier (Loc, Name_uA)))))); -- abort status |
| 2489 | end if; |
| cdb1c38f |
2490 | else |
| 2491 | pragma Assert (Is_Task_Type (Conc_Typ)); |
| 2492 | |
| 2493 | -- Generate: |
| 2494 | -- if F then |
| 2495 | -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry |
| 2496 | -- (Protection_Entries_Access (P), |
| 2497 | -- O._task_id, |
| 2498 | -- Task_Entry_Index (I), |
| 2499 | -- A); |
| 2500 | -- else |
| 2501 | -- System.Tasking.Rendezvous.Requeue_Task_Entry |
| 2502 | -- (O._task_id, |
| 2503 | -- Task_Entry_Index (I), |
| 2504 | -- A); |
| 2505 | -- end if; |
| 2506 | |
| 2507 | Append_To (Stmts, |
| 2508 | Make_If_Statement (Loc, |
| 2509 | Condition => |
| 2510 | Make_Identifier (Loc, Name_uF), |
| 2511 | |
| 2512 | Then_Statements => |
| 2513 | New_List ( |
| 2514 | |
| 2515 | -- Call to Requeue_Protected_To_Task_Entry |
| 2516 | |
| 2517 | Make_Procedure_Call_Statement (Loc, |
| 2518 | Name => |
| 2519 | New_Reference_To ( |
| 2520 | RTE (RE_Requeue_Protected_To_Task_Entry), Loc), |
| 2521 | |
| 2522 | Parameter_Associations => |
| 2523 | New_List ( |
| 2524 | |
| 2525 | Make_Unchecked_Type_Conversion (Loc, -- PEA (P) |
| 2526 | Subtype_Mark => |
| 2527 | New_Reference_To ( |
| 2528 | RTE (RE_Protection_Entries_Access), Loc), |
| 2529 | Expression => |
| 2530 | Make_Identifier (Loc, Name_uP)), |
| 2531 | |
| 2532 | Make_Selected_Component (Loc, -- O._task_id |
| 2533 | Prefix => |
| 2534 | Make_Identifier (Loc, Name_uO), |
| 2535 | Selector_Name => |
| 2536 | Make_Identifier (Loc, Name_uTask_Id)), |
| 2537 | |
| 2538 | Make_Unchecked_Type_Conversion (Loc, -- entry index |
| 2539 | Subtype_Mark => |
| 2540 | New_Reference_To ( |
| 2541 | RTE (RE_Task_Entry_Index), Loc), |
| 2542 | Expression => |
| 2543 | Make_Identifier (Loc, Name_uI)), |
| 2544 | |
| 2545 | Make_Identifier (Loc, Name_uA)))), -- abort status |
| 2546 | |
| 2547 | Else_Statements => |
| 2548 | New_List ( |
| 2549 | |
| 2550 | -- Call to Requeue_Task_Entry |
| 2551 | |
| 2552 | Make_Procedure_Call_Statement (Loc, |
| 2553 | Name => |
| 2554 | New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc), |
| 2555 | |
| 2556 | Parameter_Associations => |
| 2557 | New_List ( |
| 2558 | |
| 2559 | Make_Selected_Component (Loc, -- O._task_id |
| 2560 | Prefix => |
| 2561 | Make_Identifier (Loc, Name_uO), |
| 2562 | Selector_Name => |
| 2563 | Make_Identifier (Loc, Name_uTask_Id)), |
| 2564 | |
| 2565 | Make_Unchecked_Type_Conversion (Loc, -- entry index |
| 2566 | Subtype_Mark => |
| 2567 | New_Reference_To ( |
| 2568 | RTE (RE_Task_Entry_Index), Loc), |
| 2569 | Expression => |
| 2570 | Make_Identifier (Loc, Name_uI)), |
| 2571 | |
| 2572 | Make_Identifier (Loc, Name_uA)))))); -- abort status |
| 2573 | end if; |
| 2574 | |
| 2575 | -- Even though no declarations are needed in both cases, we allocate |
| 2576 | -- a list for entities added by Freeze. |
| 2577 | |
| 2578 | return |
| 2579 | Make_Subprogram_Body (Loc, |
| 2580 | Specification => |
| 2581 | Make_Disp_Requeue_Spec (Typ), |
| 2582 | Declarations => |
| 2583 | New_List, |
| 2584 | Handled_Statement_Sequence => |
| 2585 | Make_Handled_Sequence_Of_Statements (Loc, Stmts)); |
| 2586 | end Make_Disp_Requeue_Body; |
| 2587 | |
| 2588 | ---------------------------- |
| 2589 | -- Make_Disp_Requeue_Spec -- |
| 2590 | ---------------------------- |
| 2591 | |
| 2592 | function Make_Disp_Requeue_Spec |
| 2593 | (Typ : Entity_Id) return Node_Id |
| 2594 | is |
| 2595 | Loc : constant Source_Ptr := Sloc (Typ); |
| 2596 | |
| 2597 | begin |
| 2598 | pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| 2599 | |
| 2600 | -- O : in out Typ; - Object parameter |
| 2601 | -- F : Boolean; - Protected (True) / task (False) flag |
| 2602 | -- P : Address; - Protection_Entries_Access value |
| 2603 | -- I : Entry_Index - Index of entry call |
| 2604 | -- A : Boolean - Abort flag |
| 2605 | |
| 2606 | -- Note that the Protection_Entries_Access value is represented as a |
| 2607 | -- System.Address in order to avoid dragging in the tasking runtime |
| 2608 | -- when compiling sources without tasking constructs. |
| 2609 | |
| 2610 | return |
| 2611 | Make_Procedure_Specification (Loc, |
| 2612 | Defining_Unit_Name => |
| 2613 | Make_Defining_Identifier (Loc, Name_uDisp_Requeue), |
| 2614 | |
| 2615 | Parameter_Specifications => |
| 2616 | New_List ( |
| 2617 | |
| 2618 | Make_Parameter_Specification (Loc, -- O |
| 2619 | Defining_Identifier => |
| 2620 | Make_Defining_Identifier (Loc, Name_uO), |
| 2621 | Parameter_Type => |
| 2622 | New_Reference_To (Typ, Loc), |
| 2623 | In_Present => True, |
| 2624 | Out_Present => True), |
| 2625 | |
| 2626 | Make_Parameter_Specification (Loc, -- F |
| 2627 | Defining_Identifier => |
| 2628 | Make_Defining_Identifier (Loc, Name_uF), |
| 2629 | Parameter_Type => |
| 2630 | New_Reference_To (Standard_Boolean, Loc)), |
| 2631 | |
| 2632 | Make_Parameter_Specification (Loc, -- P |
| 2633 | Defining_Identifier => |
| 2634 | Make_Defining_Identifier (Loc, Name_uP), |
| 2635 | Parameter_Type => |
| 2636 | New_Reference_To (RTE (RE_Address), Loc)), |
| 2637 | |
| 2638 | Make_Parameter_Specification (Loc, -- I |
| 2639 | Defining_Identifier => |
| 2640 | Make_Defining_Identifier (Loc, Name_uI), |
| 2641 | Parameter_Type => |
| 2642 | New_Reference_To (Standard_Integer, Loc)), |
| 2643 | |
| 2644 | Make_Parameter_Specification (Loc, -- A |
| 2645 | Defining_Identifier => |
| 2646 | Make_Defining_Identifier (Loc, Name_uA), |
| 2647 | Parameter_Type => |
| 2648 | New_Reference_To (Standard_Boolean, Loc)))); |
| 2649 | end Make_Disp_Requeue_Spec; |
| 2650 | |
| 76a1c25b |
2651 | --------------------------------- |
| 2652 | -- Make_Disp_Timed_Select_Body -- |
| 2653 | --------------------------------- |
| 2654 | |
| cdb1c38f |
2655 | -- For interface types, generate: |
| 2656 | |
| 2657 | -- procedure _Disp_Timed_Select |
| 2658 | -- (T : in out <Typ>; |
| 2659 | -- S : Integer; |
| 2660 | -- P : System.Address; |
| 2661 | -- D : Duration; |
| 2662 | -- M : Integer; |
| 2663 | -- C : out Ada.Tags.Prim_Op_Kind; |
| 2664 | -- F : out Boolean) |
| 2665 | -- is |
| 2666 | -- begin |
| 2667 | -- null; |
| 2668 | -- end _Disp_Timed_Select; |
| 2669 | |
| 2670 | -- For protected types, generate: |
| 2671 | |
| 2672 | -- procedure _Disp_Timed_Select |
| 2673 | -- (T : in out <Typ>; |
| 2674 | -- S : Integer; |
| 2675 | -- P : System.Address; |
| 2676 | -- D : Duration; |
| 2677 | -- M : Integer; |
| 2678 | -- C : out Ada.Tags.Prim_Op_Kind; |
| 2679 | -- F : out Boolean) |
| 2680 | -- is |
| 2681 | -- I : Integer; |
| 2682 | |
| 2683 | -- begin |
| 2684 | -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S); |
| 2685 | |
| 2686 | -- if C = Ada.Tags.POK_Procedure |
| 2687 | -- or else C = Ada.Tags.POK_Protected_Procedure |
| 2688 | -- or else C = Ada.Tags.POK_Task_Procedure |
| 2689 | -- then |
| 2690 | -- F := True; |
| 2691 | -- return; |
| 2692 | -- end if; |
| 2693 | |
| 2694 | -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S); |
| 2695 | -- System.Tasking.Protected_Objects.Operations. |
| 2696 | -- Timed_Protected_Entry_Call |
| 2697 | -- (T._object'Access, |
| 2698 | -- System.Tasking.Protected_Objects.Protected_Entry_Index (I), |
| 2699 | -- P, |
| 2700 | -- D, |
| 2701 | -- M, |
| 2702 | -- F); |
| 2703 | -- end _Disp_Timed_Select; |
| 2704 | |
| 2705 | -- For task types, generate: |
| 2706 | |
| 2707 | -- procedure _Disp_Timed_Select |
| 2708 | -- (T : in out <Typ>; |
| 2709 | -- S : Integer; |
| 2710 | -- P : System.Address; |
| 2711 | -- D : Duration; |
| 2712 | -- M : Integer; |
| 2713 | -- C : out Ada.Tags.Prim_Op_Kind; |
| 2714 | -- F : out Boolean) |
| 2715 | -- is |
| 2716 | -- I : Integer; |
| 2717 | |
| 2718 | -- begin |
| 2719 | -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S); |
| 2720 | -- System.Tasking.Rendezvous.Timed_Task_Entry_Call |
| 2721 | -- (T._task_id, |
| 2722 | -- System.Tasking.Task_Entry_Index (I), |
| 2723 | -- P, |
| 2724 | -- D, |
| 2725 | -- M, |
| 2726 | -- D); |
| 2727 | -- end _Disp_Time_Select; |
| 2728 | |
| 76a1c25b |
2729 | function Make_Disp_Timed_Select_Body |
| 2730 | (Typ : Entity_Id) return Node_Id |
| 2731 | is |
| 2732 | Loc : constant Source_Ptr := Sloc (Typ); |
| 2733 | Conc_Typ : Entity_Id := Empty; |
| 2734 | Decls : constant List_Id := New_List; |
| 2735 | DT_Ptr : Entity_Id; |
| acf97c11 |
2736 | Obj_Ref : Node_Id; |
| 76a1c25b |
2737 | Stmts : constant List_Id := New_List; |
| 2738 | |
| 2739 | begin |
| 68f95949 |
2740 | pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| 2741 | |
| 952af0b9 |
2742 | -- Null body is generated for interface types |
| 2743 | |
| 76a1c25b |
2744 | if Is_Interface (Typ) then |
| 2745 | return |
| 2746 | Make_Subprogram_Body (Loc, |
| 2747 | Specification => |
| 2748 | Make_Disp_Timed_Select_Spec (Typ), |
| 2749 | Declarations => |
| 2750 | New_List, |
| 2751 | Handled_Statement_Sequence => |
| 2752 | Make_Handled_Sequence_Of_Statements (Loc, |
| 2753 | New_List (Make_Null_Statement (Loc)))); |
| 2754 | end if; |
| 2755 | |
| 76a1c25b |
2756 | DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); |
| 2757 | |
| 952af0b9 |
2758 | if Is_Concurrent_Record_Type (Typ) then |
| 2759 | Conc_Typ := Corresponding_Concurrent_Type (Typ); |
| 76a1c25b |
2760 | |
| 2761 | -- Generate: |
| 2762 | -- I : Integer; |
| 2763 | |
| 2764 | -- where I will be used to capture the entry index of the primitive |
| 2765 | -- wrapper at position S. |
| 2766 | |
| 2767 | Append_To (Decls, |
| 2768 | Make_Object_Declaration (Loc, |
| 2769 | Defining_Identifier => |
| 2770 | Make_Defining_Identifier (Loc, Name_uI), |
| 2771 | Object_Definition => |
| 2772 | New_Reference_To (Standard_Integer, Loc))); |
| 76a1c25b |
2773 | |
| 952af0b9 |
2774 | -- Generate: |
| 2775 | -- C := Get_Prim_Op_Kind (tag! (<type>VP), S); |
| 76a1c25b |
2776 | |
| 952af0b9 |
2777 | -- if C = POK_Procedure |
| 2778 | -- or else C = POK_Protected_Procedure |
| 2779 | -- or else C = POK_Task_Procedure; |
| 2780 | -- then |
| 2781 | -- F := True; |
| 2782 | -- return; |
| 2783 | -- end if; |
| 76a1c25b |
2784 | |
| 725a69d2 |
2785 | Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts); |
| 76a1c25b |
2786 | |
| 2787 | -- Generate: |
| 952af0b9 |
2788 | -- I := Get_Entry_Index (tag! (<type>VP), S); |
| 76a1c25b |
2789 | |
| 2790 | -- I is the entry index and S is the dispatch table slot |
| 2791 | |
| 2792 | Append_To (Stmts, |
| 2793 | Make_Assignment_Statement (Loc, |
| 2794 | Name => |
| 2795 | Make_Identifier (Loc, Name_uI), |
| 2796 | Expression => |
| 725a69d2 |
2797 | Make_Function_Call (Loc, |
| cdb1c38f |
2798 | Name => |
| 2799 | New_Reference_To (RTE (RE_Get_Entry_Index), Loc), |
| 2800 | Parameter_Associations => |
| 2801 | New_List ( |
| 2802 | Unchecked_Convert_To (RTE (RE_Tag), |
| 2803 | New_Reference_To (DT_Ptr, Loc)), |
| 2804 | Make_Identifier (Loc, Name_uS))))); |
| 76a1c25b |
2805 | |
| acf97c11 |
2806 | -- Protected case |
| 2807 | |
| 76a1c25b |
2808 | if Ekind (Conc_Typ) = E_Protected_Type then |
| 2809 | |
| acf97c11 |
2810 | -- Build T._object'Access |
| 2811 | |
| 2812 | Obj_Ref := |
| 2813 | Make_Attribute_Reference (Loc, |
| 2814 | Attribute_Name => Name_Unchecked_Access, |
| 2815 | Prefix => |
| 2816 | Make_Selected_Component (Loc, |
| 2817 | Prefix => Make_Identifier (Loc, Name_uT), |
| 2818 | Selector_Name => Make_Identifier (Loc, Name_uObject))); |
| 2819 | |
| 2820 | -- Normal case, No_Entry_Queue restriction not active. In this |
| 2821 | -- case we generate: |
| 2822 | |
| 2823 | -- Timed_Protected_Entry_Call |
| 2824 | -- (T._object'access, |
| cdb1c38f |
2825 | -- Protected_Entry_Index! (I), |
| acf97c11 |
2826 | -- P, D, M, F); |
| 76a1c25b |
2827 | |
| 2828 | -- where T is the protected object, I is the entry index, P are |
| 2829 | -- the wrapped parameters, D is the delay amount, M is the delay |
| 2830 | -- mode and F is the status flag. |
| 2831 | |
| acf97c11 |
2832 | case Corresponding_Runtime_Package (Conc_Typ) is |
| 2833 | when System_Tasking_Protected_Objects_Entries => |
| 2834 | Append_To (Stmts, |
| 2835 | Make_Procedure_Call_Statement (Loc, |
| 2836 | Name => |
| 2837 | New_Reference_To |
| 2838 | (RTE (RE_Timed_Protected_Entry_Call), Loc), |
| 2839 | Parameter_Associations => |
| 2840 | New_List ( |
| 2841 | Obj_Ref, |
| 2842 | |
| 2843 | Make_Unchecked_Type_Conversion (Loc, -- entry index |
| 2844 | Subtype_Mark => |
| 2845 | New_Reference_To |
| 2846 | (RTE (RE_Protected_Entry_Index), Loc), |
| 2847 | Expression => |
| 2848 | Make_Identifier (Loc, Name_uI)), |
| 76a1c25b |
2849 | |
| acf97c11 |
2850 | Make_Identifier (Loc, Name_uP), -- parameter block |
| 2851 | Make_Identifier (Loc, Name_uD), -- delay |
| 2852 | Make_Identifier (Loc, Name_uM), -- delay mode |
| 2853 | Make_Identifier (Loc, Name_uF)))); -- status flag |
| 76a1c25b |
2854 | |
| acf97c11 |
2855 | when System_Tasking_Protected_Objects_Single_Entry => |
| 2856 | -- Generate: |
| 76a1c25b |
2857 | |
| acf97c11 |
2858 | -- Timed_Protected_Single_Entry_Call |
| 2859 | -- (T._object'access, P, D, M, F); |
| 2860 | |
| 2861 | -- where T is the protected object, P is the wrapped |
| 2862 | -- parameters, D is the delay amount, M is the delay mode, F |
| 2863 | -- is the status flag. |
| 2864 | |
| 2865 | Append_To (Stmts, |
| 2866 | Make_Procedure_Call_Statement (Loc, |
| 2867 | Name => |
| 2868 | New_Reference_To |
| 2869 | (RTE (RE_Timed_Protected_Single_Entry_Call), Loc), |
| 2870 | Parameter_Associations => |
| 2871 | New_List ( |
| 2872 | Obj_Ref, |
| 2873 | Make_Identifier (Loc, Name_uP), -- parameter block |
| 2874 | Make_Identifier (Loc, Name_uD), -- delay |
| 2875 | Make_Identifier (Loc, Name_uM), -- delay mode |
| 2876 | Make_Identifier (Loc, Name_uF)))); -- status flag |
| 2877 | |
| 2878 | when others => |
| 2879 | raise Program_Error; |
| 2880 | end case; |
| 2881 | |
| 2882 | -- Task case |
| ee6ba406 |
2883 | |
| ee6ba406 |
2884 | else |
| 76a1c25b |
2885 | pragma Assert (Ekind (Conc_Typ) = E_Task_Type); |
| 2886 | |
| 2887 | -- Generate: |
| 2888 | -- Timed_Task_Entry_Call ( |
| 2889 | -- T._task_id, |
| cdb1c38f |
2890 | -- Task_Entry_Index! (I), |
| 76a1c25b |
2891 | -- P, |
| 2892 | -- D, |
| 2893 | -- M, |
| 2894 | -- F); |
| 2895 | |
| 2896 | -- where T is the task object, I is the entry index, P are the |
| 2897 | -- wrapped parameters, D is the delay amount, M is the delay |
| 2898 | -- mode and F is the status flag. |
| 2899 | |
| 2900 | Append_To (Stmts, |
| 2901 | Make_Procedure_Call_Statement (Loc, |
| 2902 | Name => |
| 2903 | New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc), |
| 2904 | Parameter_Associations => |
| 2905 | New_List ( |
| 2906 | |
| 2907 | Make_Selected_Component (Loc, -- T._task_id |
| 2908 | Prefix => |
| 2909 | Make_Identifier (Loc, Name_uT), |
| 2910 | Selector_Name => |
| 2911 | Make_Identifier (Loc, Name_uTask_Id)), |
| 2912 | |
| 2913 | Make_Unchecked_Type_Conversion (Loc, -- entry index |
| 2914 | Subtype_Mark => |
| 2915 | New_Reference_To (RTE (RE_Task_Entry_Index), Loc), |
| 2916 | Expression => |
| 2917 | Make_Identifier (Loc, Name_uI)), |
| 2918 | |
| 2919 | Make_Identifier (Loc, Name_uP), -- parameter block |
| 2920 | Make_Identifier (Loc, Name_uD), -- delay |
| 2921 | Make_Identifier (Loc, Name_uM), -- delay mode |
| 2922 | Make_Identifier (Loc, Name_uF)))); -- status flag |
| ee6ba406 |
2923 | end if; |
| 76a1c25b |
2924 | end if; |
| 2925 | |
| 2926 | return |
| 2927 | Make_Subprogram_Body (Loc, |
| 2928 | Specification => |
| 2929 | Make_Disp_Timed_Select_Spec (Typ), |
| 2930 | Declarations => |
| 2931 | Decls, |
| 2932 | Handled_Statement_Sequence => |
| 2933 | Make_Handled_Sequence_Of_Statements (Loc, Stmts)); |
| 2934 | end Make_Disp_Timed_Select_Body; |
| 2935 | |
| 2936 | --------------------------------- |
| 2937 | -- Make_Disp_Timed_Select_Spec -- |
| 2938 | --------------------------------- |
| 2939 | |
| 2940 | function Make_Disp_Timed_Select_Spec |
| 2941 | (Typ : Entity_Id) return Node_Id |
| 2942 | is |
| 2943 | Loc : constant Source_Ptr := Sloc (Typ); |
| 2944 | Def_Id : constant Node_Id := |
| 2945 | Make_Defining_Identifier (Loc, |
| 2946 | Name_uDisp_Timed_Select); |
| 2947 | Params : constant List_Id := New_List; |
| ee6ba406 |
2948 | |
| 76a1c25b |
2949 | begin |
| 68f95949 |
2950 | pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| 2951 | |
| 725a69d2 |
2952 | -- T : in out Typ; -- Object parameter |
| 2953 | -- S : Integer; -- Primitive operation slot |
| 2954 | -- P : Address; -- Wrapped parameters |
| 2955 | -- D : Duration; -- Delay |
| 2956 | -- M : Integer; -- Delay Mode |
| 2957 | -- C : out Prim_Op_Kind; -- Call kind |
| 2958 | -- F : out Boolean; -- Status flag |
| 76a1c25b |
2959 | |
| 725a69d2 |
2960 | Append_List_To (Params, New_List ( |
| 2961 | |
| 2962 | Make_Parameter_Specification (Loc, |
| 2963 | Defining_Identifier => |
| 2964 | Make_Defining_Identifier (Loc, Name_uT), |
| 2965 | Parameter_Type => |
| 2966 | New_Reference_To (Typ, Loc), |
| 2967 | In_Present => True, |
| 2968 | Out_Present => True), |
| 2969 | |
| 2970 | Make_Parameter_Specification (Loc, |
| 2971 | Defining_Identifier => |
| 2972 | Make_Defining_Identifier (Loc, Name_uS), |
| 2973 | Parameter_Type => |
| 2974 | New_Reference_To (Standard_Integer, Loc)), |
| 2975 | |
| 2976 | Make_Parameter_Specification (Loc, |
| 2977 | Defining_Identifier => |
| 2978 | Make_Defining_Identifier (Loc, Name_uP), |
| 2979 | Parameter_Type => |
| 2980 | New_Reference_To (RTE (RE_Address), Loc)), |
| 76a1c25b |
2981 | |
| 76a1c25b |
2982 | Make_Parameter_Specification (Loc, |
| 2983 | Defining_Identifier => |
| 2984 | Make_Defining_Identifier (Loc, Name_uD), |
| 2985 | Parameter_Type => |
| 725a69d2 |
2986 | New_Reference_To (Standard_Duration, Loc)), |
| 76a1c25b |
2987 | |
| 76a1c25b |
2988 | Make_Parameter_Specification (Loc, |
| 2989 | Defining_Identifier => |
| 2990 | Make_Defining_Identifier (Loc, Name_uM), |
| 2991 | Parameter_Type => |
| 725a69d2 |
2992 | New_Reference_To (Standard_Integer, Loc)), |
| ee6ba406 |
2993 | |
| 725a69d2 |
2994 | Make_Parameter_Specification (Loc, |
| 2995 | Defining_Identifier => |
| 2996 | Make_Defining_Identifier (Loc, Name_uC), |
| 2997 | Parameter_Type => |
| 2998 | New_Reference_To (RTE (RE_Prim_Op_Kind), Loc), |
| 2999 | Out_Present => True))); |
| ee6ba406 |
3000 | |
| 725a69d2 |
3001 | Append_To (Params, |
| 3002 | Make_Parameter_Specification (Loc, |
| 3003 | Defining_Identifier => |
| 3004 | Make_Defining_Identifier (Loc, Name_uF), |
| 3005 | Parameter_Type => |
| 3006 | New_Reference_To (Standard_Boolean, Loc), |
| 3007 | Out_Present => True)); |
| ee6ba406 |
3008 | |
| 76a1c25b |
3009 | return |
| 3010 | Make_Procedure_Specification (Loc, |
| 3011 | Defining_Unit_Name => Def_Id, |
| 3012 | Parameter_Specifications => Params); |
| 3013 | end Make_Disp_Timed_Select_Spec; |
| ee6ba406 |
3014 | |
| 76a1c25b |
3015 | ------------- |
| 3016 | -- Make_DT -- |
| 3017 | ------------- |
| ee6ba406 |
3018 | |
| 725a69d2 |
3019 | -- The frontend supports two models for expanding dispatch tables |
| 3020 | -- associated with library-level defined tagged types: statically |
| 3021 | -- and non-statically allocated dispatch tables. In the former case |
| 3022 | -- the object containing the dispatch table is constant and it is |
| 3023 | -- initialized by means of a positional aggregate. In the latter case, |
| 3024 | -- the object containing the dispatch table is a variable which is |
| 3025 | -- initialized by means of assignments. |
| 3026 | |
| 3027 | -- In case of locally defined tagged types, the object containing the |
| 3028 | -- object containing the dispatch table is always a variable (instead |
| 3029 | -- of a constant). This is currently required to give support to late |
| 3030 | -- overriding of primitives. For example: |
| 3031 | |
| 3032 | -- procedure Example is |
| 3033 | -- package Pkg is |
| 3034 | -- type T1 is tagged null record; |
| 3035 | -- procedure Prim (O : T1); |
| 3036 | -- end Pkg; |
| 3037 | |
| 3038 | -- type T2 is new Pkg.T1 with null record; |
| 3039 | -- procedure Prim (X : T2) is -- late overriding |
| 3040 | -- begin |
| 3041 | -- ... |
| 3042 | -- ... |
| 3043 | -- end; |
| 952af0b9 |
3044 | |
| 17e14451 |
3045 | function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is |
| 3046 | Loc : constant Source_Ptr := Sloc (Typ); |
| 3047 | |
| 725a69d2 |
3048 | Max_Predef_Prims : constant Int := |
| 3049 | UI_To_Int |
| 3050 | (Intval |
| 3051 | (Expression |
| 17e14451 |
3052 | (Parent (RTE (RE_Max_Predef_Prims))))); |
| 3053 | |
| cc60bd16 |
3054 | DT_Decl : constant Elist_Id := New_Elmt_List; |
| 3055 | DT_Aggr : constant Elist_Id := New_Elmt_List; |
| 3056 | -- Entities marked with attribute Is_Dispatch_Table_Entity |
| 3057 | |
| 17e14451 |
3058 | procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id); |
| 3059 | -- Verify that all non-tagged types in the profile of a subprogram |
| 3060 | -- are frozen at the point the subprogram is frozen. This enforces |
| 3061 | -- the rule on RM 13.14 (14) as modified by AI05-019. At the point a |
| 3062 | -- subprogram is frozen, enough must be known about it to build the |
| 3063 | -- activation record for it, which requires at least that the size of |
| 3064 | -- all parameters be known. Controlling arguments are by-reference, |
| 3065 | -- and therefore the rule only applies to non-tagged types. |
| 3066 | -- Typical violation of the rule involves an object declaration that |
| 3067 | -- freezes a tagged type, when one of its primitive operations has a |
| 3068 | -- type in its profile whose full view has not been analyzed yet. |
| 725a69d2 |
3069 | |
| 24971415 |
3070 | procedure Export_DT (Typ : Entity_Id; DT : Entity_Id); |
| 3071 | -- Export the dispatch table entity DT of tagged type Typ. Required to |
| 3072 | -- generate forward references and statically allocate the table. |
| 3073 | |
| 725a69d2 |
3074 | procedure Make_Secondary_DT |
| acf97c11 |
3075 | (Typ : Entity_Id; |
| 3076 | Iface : Entity_Id; |
| 3077 | Num_Iface_Prims : Nat; |
| 3078 | Iface_DT_Ptr : Entity_Id; |
| 3079 | Predef_Prims_Ptr : Entity_Id; |
| 3080 | Build_Thunks : Boolean; |
| 3081 | Result : List_Id); |
| cdb1c38f |
3082 | -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch |
| 3083 | -- Table of Typ associated with Iface. Each abstract interface of Typ |
| 3084 | -- has two secondary dispatch tables: one containing pointers to thunks |
| 3085 | -- and another containing pointers to the primitives covering the |
| 3086 | -- interface primitives. The former secondary table is generated when |
| 3087 | -- Build_Thunks is True, and provides common support for dispatching |
| 3088 | -- calls through interface types; the latter secondary table is |
| 3089 | -- generated when Build_Thunks is False, and provides support for |
| 3090 | -- Generic Dispatching Constructors that dispatch calls through |
| 3091 | -- interface types. |
| 9dfe12ae |
3092 | |
| 17e14451 |
3093 | ------------------------------ |
| 3094 | -- Check_Premature_Freezing -- |
| 3095 | ------------------------------ |
| 3096 | |
| 3097 | procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id) is |
| 3098 | begin |
| 3099 | if Present (N) |
| 3100 | and then Is_Private_Type (Typ) |
| 3101 | and then No (Full_View (Typ)) |
| 3102 | and then not Is_Generic_Type (Typ) |
| 3103 | and then not Is_Tagged_Type (Typ) |
| 3104 | and then not Is_Frozen (Typ) |
| 3105 | then |
| 3106 | Error_Msg_Sloc := Sloc (Subp); |
| 3107 | Error_Msg_NE |
| 3108 | ("declaration must appear after completion of type &", N, Typ); |
| 3109 | Error_Msg_NE |
| 3110 | ("\which is an untagged type in the profile of" |
| 3111 | & " primitive operation & declared#", |
| 3112 | N, Subp); |
| 3113 | end if; |
| 3114 | end Check_Premature_Freezing; |
| 3115 | |
| 24971415 |
3116 | --------------- |
| 3117 | -- Export_DT -- |
| 3118 | --------------- |
| 3119 | |
| 3120 | procedure Export_DT (Typ : Entity_Id; DT : Entity_Id) is |
| 3121 | begin |
| 3122 | Set_Is_Statically_Allocated (DT); |
| 3123 | Set_Is_True_Constant (DT); |
| 3124 | Set_Is_Exported (DT); |
| 3125 | |
| 3126 | pragma Assert (Present (Dispatch_Table_Wrapper (Typ))); |
| 3127 | Get_External_Name (Dispatch_Table_Wrapper (Typ), True); |
| 3128 | Set_Interface_Name (DT, |
| 3129 | Make_String_Literal (Loc, |
| 3130 | Strval => String_From_Name_Buffer)); |
| 3131 | |
| 3132 | -- Ensure proper Sprint output of this implicit importation |
| 3133 | |
| 3134 | Set_Is_Internal (DT); |
| 3135 | Set_Is_Public (DT); |
| 3136 | end Export_DT; |
| 3137 | |
| 725a69d2 |
3138 | ----------------------- |
| 3139 | -- Make_Secondary_DT -- |
| 3140 | ----------------------- |
| ee6ba406 |
3141 | |
| 725a69d2 |
3142 | procedure Make_Secondary_DT |
| acf97c11 |
3143 | (Typ : Entity_Id; |
| 3144 | Iface : Entity_Id; |
| 3145 | Num_Iface_Prims : Nat; |
| 3146 | Iface_DT_Ptr : Entity_Id; |
| 3147 | Predef_Prims_Ptr : Entity_Id; |
| 3148 | Build_Thunks : Boolean; |
| 3149 | Result : List_Id) |
| 725a69d2 |
3150 | is |
| 3151 | Loc : constant Source_Ptr := Sloc (Typ); |
| 725a69d2 |
3152 | Name_DT : constant Name_Id := New_Internal_Name ('T'); |
| 3153 | Iface_DT : constant Entity_Id := |
| 3154 | Make_Defining_Identifier (Loc, Name_DT); |
| 3155 | Name_Predef_Prims : constant Name_Id := New_Internal_Name ('R'); |
| 3156 | Predef_Prims : constant Entity_Id := |
| 3157 | Make_Defining_Identifier (Loc, |
| 3158 | Name_Predef_Prims); |
| 3159 | DT_Constr_List : List_Id; |
| 3160 | DT_Aggr_List : List_Id; |
| 3161 | Empty_DT : Boolean := False; |
| 3162 | Nb_Predef_Prims : Nat := 0; |
| 3163 | Nb_Prim : Nat; |
| 3164 | New_Node : Node_Id; |
| 3165 | OSD : Entity_Id; |
| 3166 | OSD_Aggr_List : List_Id; |
| 3167 | Pos : Nat; |
| 3168 | Prim : Entity_Id; |
| 3169 | Prim_Elmt : Elmt_Id; |
| 3170 | Prim_Ops_Aggr_List : List_Id; |
| 343d35dc |
3171 | |
| 725a69d2 |
3172 | begin |
| 17e14451 |
3173 | -- Handle cases in which we do not generate statically allocated |
| 3174 | -- dispatch tables. |
| 343d35dc |
3175 | |
| 24971415 |
3176 | if not Building_Static_DT (Typ) then |
| 725a69d2 |
3177 | Set_Ekind (Predef_Prims, E_Variable); |
| 3178 | Set_Is_Statically_Allocated (Predef_Prims); |
| 343d35dc |
3179 | |
| 725a69d2 |
3180 | Set_Ekind (Iface_DT, E_Variable); |
| 3181 | Set_Is_Statically_Allocated (Iface_DT); |
| 343d35dc |
3182 | |
| 725a69d2 |
3183 | -- Statically allocated dispatch tables and related entities are |
| 3184 | -- constants. |
| 343d35dc |
3185 | |
| 725a69d2 |
3186 | else |
| 3187 | Set_Ekind (Predef_Prims, E_Constant); |
| 3188 | Set_Is_Statically_Allocated (Predef_Prims); |
| 3189 | Set_Is_True_Constant (Predef_Prims); |
| 343d35dc |
3190 | |
| 725a69d2 |
3191 | Set_Ekind (Iface_DT, E_Constant); |
| 3192 | Set_Is_Statically_Allocated (Iface_DT); |
| 3193 | Set_Is_True_Constant (Iface_DT); |
| 343d35dc |
3194 | end if; |
| 3195 | |
| 725a69d2 |
3196 | -- Generate code to create the storage for the Dispatch_Table object. |
| 3197 | -- If the number of primitives of Typ is 0 we reserve a dummy single |
| 3198 | -- entry for its DT because at run-time the pointer to this dummy |
| 3199 | -- entry will be used as the tag. |
| 68f95949 |
3200 | |
| cdb1c38f |
3201 | if Num_Iface_Prims = 0 then |
| 725a69d2 |
3202 | Empty_DT := True; |
| 3203 | Nb_Prim := 1; |
| cdb1c38f |
3204 | else |
| 3205 | Nb_Prim := Num_Iface_Prims; |
| 725a69d2 |
3206 | end if; |
| 76a1c25b |
3207 | |
| 725a69d2 |
3208 | -- Generate: |
| 952af0b9 |
3209 | |
| 725a69d2 |
3210 | -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) := |
| 3211 | -- (predef-prim-op-thunk-1'address, |
| 3212 | -- predef-prim-op-thunk-2'address, |
| 3213 | -- ... |
| 3214 | -- predef-prim-op-thunk-n'address); |
| 3215 | -- for Predef_Prims'Alignment use Address'Alignment |
| 952af0b9 |
3216 | |
| 725a69d2 |
3217 | -- Stage 1: Calculate the number of predefined primitives |
| 76a1c25b |
3218 | |
| 24971415 |
3219 | if not Building_Static_DT (Typ) then |
| 725a69d2 |
3220 | Nb_Predef_Prims := Max_Predef_Prims; |
| 3221 | else |
| 3222 | Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| 3223 | while Present (Prim_Elmt) loop |
| 3224 | Prim := Node (Prim_Elmt); |
| aad6babd |
3225 | |
| 725a69d2 |
3226 | if Is_Predefined_Dispatching_Operation (Prim) |
| 3227 | and then not Is_Abstract_Subprogram (Prim) |
| 3228 | then |
| 3229 | Pos := UI_To_Int (DT_Position (Prim)); |
| aad6babd |
3230 | |
| 725a69d2 |
3231 | if Pos > Nb_Predef_Prims then |
| 3232 | Nb_Predef_Prims := Pos; |
| 3233 | end if; |
| 3234 | end if; |
| aad6babd |
3235 | |
| 725a69d2 |
3236 | Next_Elmt (Prim_Elmt); |
| 3237 | end loop; |
| 3238 | end if; |
| aad6babd |
3239 | |
| 725a69d2 |
3240 | -- Stage 2: Create the thunks associated with the predefined |
| 3241 | -- primitives and save their entity to fill the aggregate. |
| ee6ba406 |
3242 | |
| 725a69d2 |
3243 | declare |
| 3244 | Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; |
| cc60bd16 |
3245 | Decl : Node_Id; |
| 725a69d2 |
3246 | Thunk_Id : Entity_Id; |
| 3247 | Thunk_Code : Node_Id; |
| aad6babd |
3248 | |
| 725a69d2 |
3249 | begin |
| 3250 | Prim_Ops_Aggr_List := New_List; |
| 3251 | Prim_Table := (others => Empty); |
| aad6babd |
3252 | |
| cdb1c38f |
3253 | if Building_Static_DT (Typ) then |
| 3254 | Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| 3255 | while Present (Prim_Elmt) loop |
| 3256 | Prim := Node (Prim_Elmt); |
| aad6babd |
3257 | |
| cdb1c38f |
3258 | if Is_Predefined_Dispatching_Operation (Prim) |
| 3259 | and then not Is_Abstract_Subprogram (Prim) |
| 3260 | and then not Present (Prim_Table |
| 3261 | (UI_To_Int (DT_Position (Prim)))) |
| 3262 | then |
| 3263 | if not Build_Thunks then |
| 3264 | Prim_Table (UI_To_Int (DT_Position (Prim))) := |
| 3265 | Alias (Prim); |
| aad6babd |
3266 | |
| cdb1c38f |
3267 | else |
| 3268 | while Present (Alias (Prim)) loop |
| 3269 | Prim := Alias (Prim); |
| 3270 | end loop; |
| 3271 | |
| 3272 | Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); |
| aad6babd |
3273 | |
| cdb1c38f |
3274 | if Present (Thunk_Id) then |
| 3275 | Append_To (Result, Thunk_Code); |
| 3276 | Prim_Table (UI_To_Int (DT_Position (Prim))) |
| 3277 | := Thunk_Id; |
| 3278 | end if; |
| 3279 | end if; |
| 725a69d2 |
3280 | end if; |
| aad6babd |
3281 | |
| cdb1c38f |
3282 | Next_Elmt (Prim_Elmt); |
| 3283 | end loop; |
| 3284 | end if; |
| aad6babd |
3285 | |
| 725a69d2 |
3286 | for J in Prim_Table'Range loop |
| 3287 | if Present (Prim_Table (J)) then |
| 3288 | New_Node := |
| cc60bd16 |
3289 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
| acf97c11 |
3290 | Make_Attribute_Reference (Loc, |
| 3291 | Prefix => New_Reference_To (Prim_Table (J), Loc), |
| 3292 | Attribute_Name => Name_Unrestricted_Access)); |
| 725a69d2 |
3293 | else |
| cc60bd16 |
3294 | New_Node := Make_Null (Loc); |
| 725a69d2 |
3295 | end if; |
| 952af0b9 |
3296 | |
| 725a69d2 |
3297 | Append_To (Prim_Ops_Aggr_List, New_Node); |
| 3298 | end loop; |
| 952af0b9 |
3299 | |
| cc60bd16 |
3300 | New_Node := |
| 3301 | Make_Aggregate (Loc, |
| 3302 | Expressions => Prim_Ops_Aggr_List); |
| 3303 | |
| 3304 | -- Remember aggregates initializing dispatch tables |
| 3305 | |
| 3306 | Append_Elmt (New_Node, DT_Aggr); |
| 3307 | |
| 3308 | Decl := |
| 3309 | Make_Subtype_Declaration (Loc, |
| 3310 | Defining_Identifier => |
| 3311 | Make_Defining_Identifier (Loc, |
| 3312 | New_Internal_Name ('S')), |
| 3313 | Subtype_Indication => |
| 3314 | New_Reference_To (RTE (RE_Address_Array), Loc)); |
| 3315 | |
| 3316 | Append_To (Result, Decl); |
| 3317 | |
| 725a69d2 |
3318 | Append_To (Result, |
| 3319 | Make_Object_Declaration (Loc, |
| 3320 | Defining_Identifier => Predef_Prims, |
| 24971415 |
3321 | Constant_Present => Building_Static_DT (Typ), |
| 725a69d2 |
3322 | Aliased_Present => True, |
| cc60bd16 |
3323 | Object_Definition => New_Reference_To |
| 3324 | (Defining_Identifier (Decl), Loc), |
| 3325 | Expression => New_Node)); |
| aad6babd |
3326 | |
| 725a69d2 |
3327 | Append_To (Result, |
| 3328 | Make_Attribute_Definition_Clause (Loc, |
| 3329 | Name => New_Reference_To (Predef_Prims, Loc), |
| 3330 | Chars => Name_Alignment, |
| 3331 | Expression => |
| 3332 | Make_Attribute_Reference (Loc, |
| 3333 | Prefix => |
| 3334 | New_Reference_To (RTE (RE_Integer_Address), Loc), |
| 3335 | Attribute_Name => Name_Alignment))); |
| 3336 | end; |
| aad6babd |
3337 | |
| 725a69d2 |
3338 | -- Generate |
| 76a1c25b |
3339 | |
| 725a69d2 |
3340 | -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) := |
| 3341 | -- (OSD_Table => (1 => <value>, |
| 3342 | -- ... |
| 3343 | -- N => <value>)); |
| 76a1c25b |
3344 | |
| 725a69d2 |
3345 | -- Iface_DT : Dispatch_Table (Nb_Prims) := |
| 3346 | -- ([ Signature => <sig-value> ], |
| 3347 | -- Tag_Kind => <tag_kind-value>, |
| 3348 | -- Predef_Prims => Predef_Prims'Address, |
| 3349 | -- Offset_To_Top => 0, |
| 3350 | -- OSD => OSD'Address, |
| 3351 | -- Prims_Ptr => (prim-op-1'address, |
| 3352 | -- prim-op-2'address, |
| 3353 | -- ... |
| 3354 | -- prim-op-n'address)); |
| 76a1c25b |
3355 | |
| 725a69d2 |
3356 | -- Stage 3: Initialize the discriminant and the record components |
| aad6babd |
3357 | |
| 725a69d2 |
3358 | DT_Constr_List := New_List; |
| 3359 | DT_Aggr_List := New_List; |
| 343d35dc |
3360 | |
| 725a69d2 |
3361 | -- Nb_Prim. If the tagged type has no primitives we add a dummy |
| 3362 | -- slot whose address will be the tag of this type. |
| 343d35dc |
3363 | |
| 725a69d2 |
3364 | if Nb_Prim = 0 then |
| 3365 | New_Node := Make_Integer_Literal (Loc, 1); |
| 3366 | else |
| 3367 | New_Node := Make_Integer_Literal (Loc, Nb_Prim); |
| 3368 | end if; |
| 343d35dc |
3369 | |
| 725a69d2 |
3370 | Append_To (DT_Constr_List, New_Node); |
| 3371 | Append_To (DT_Aggr_List, New_Copy (New_Node)); |
| 343d35dc |
3372 | |
| 725a69d2 |
3373 | -- Signature |
| 343d35dc |
3374 | |
| 725a69d2 |
3375 | if RTE_Record_Component_Available (RE_Signature) then |
| 3376 | Append_To (DT_Aggr_List, |
| 3377 | New_Reference_To (RTE (RE_Secondary_DT), Loc)); |
| 3378 | end if; |
| 343d35dc |
3379 | |
| 725a69d2 |
3380 | -- Tag_Kind |
| 343d35dc |
3381 | |
| 725a69d2 |
3382 | if RTE_Record_Component_Available (RE_Tag_Kind) then |
| 3383 | Append_To (DT_Aggr_List, Tagged_Kind (Typ)); |
| 3384 | end if; |
| aad6babd |
3385 | |
| 725a69d2 |
3386 | -- Predef_Prims |
| aad6babd |
3387 | |
| 725a69d2 |
3388 | Append_To (DT_Aggr_List, |
| 3389 | Make_Attribute_Reference (Loc, |
| 3390 | Prefix => New_Reference_To (Predef_Prims, Loc), |
| 3391 | Attribute_Name => Name_Address)); |
| aad6babd |
3392 | |
| 725a69d2 |
3393 | -- Note: The correct value of Offset_To_Top will be set by the init |
| 3394 | -- subprogram |
| aad6babd |
3395 | |
| 725a69d2 |
3396 | Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); |
| aad6babd |
3397 | |
| 725a69d2 |
3398 | -- Generate the Object Specific Data table required to dispatch calls |
| 3399 | -- through synchronized interfaces. |
| aad6babd |
3400 | |
| 725a69d2 |
3401 | if Empty_DT |
| 3402 | or else Is_Abstract_Type (Typ) |
| 3403 | or else Is_Controlled (Typ) |
| 3404 | or else Restriction_Active (No_Dispatching_Calls) |
| 3405 | or else not Is_Limited_Type (Typ) |
| 3406 | or else not Has_Abstract_Interfaces (Typ) |
| cdb1c38f |
3407 | or else not Build_Thunks |
| 725a69d2 |
3408 | then |
| 3409 | -- No OSD table required |
| ee6ba406 |
3410 | |
| 725a69d2 |
3411 | Append_To (DT_Aggr_List, |
| 3412 | New_Reference_To (RTE (RE_Null_Address), Loc)); |
| d62940bf |
3413 | |
| 725a69d2 |
3414 | else |
| 3415 | OSD_Aggr_List := New_List; |
| d62940bf |
3416 | |
| 725a69d2 |
3417 | declare |
| 3418 | Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; |
| 3419 | Prim : Entity_Id; |
| 3420 | Prim_Alias : Entity_Id; |
| 3421 | Prim_Elmt : Elmt_Id; |
| 3422 | E : Entity_Id; |
| 3423 | Count : Nat := 0; |
| 3424 | Pos : Nat; |
| d62940bf |
3425 | |
| 725a69d2 |
3426 | begin |
| 3427 | Prim_Table := (others => Empty); |
| 3428 | Prim_Alias := Empty; |
| d62940bf |
3429 | |
| 725a69d2 |
3430 | Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| 3431 | while Present (Prim_Elmt) loop |
| 3432 | Prim := Node (Prim_Elmt); |
| d62940bf |
3433 | |
| 725a69d2 |
3434 | if Present (Abstract_Interface_Alias (Prim)) |
| 3435 | and then Find_Dispatching_Type |
| 3436 | (Abstract_Interface_Alias (Prim)) = Iface |
| 3437 | then |
| 3438 | Prim_Alias := Abstract_Interface_Alias (Prim); |
| d62940bf |
3439 | |
| 725a69d2 |
3440 | E := Prim; |
| 3441 | while Present (Alias (E)) loop |
| 3442 | E := Alias (E); |
| 3443 | end loop; |
| 68f95949 |
3444 | |
| 725a69d2 |
3445 | Pos := UI_To_Int (DT_Position (Prim_Alias)); |
| 68f95949 |
3446 | |
| 725a69d2 |
3447 | if Present (Prim_Table (Pos)) then |
| 3448 | pragma Assert (Prim_Table (Pos) = E); |
| 3449 | null; |
| 68f95949 |
3450 | |
| 725a69d2 |
3451 | else |
| 3452 | Prim_Table (Pos) := E; |
| 3453 | |
| 3454 | Append_To (OSD_Aggr_List, |
| 3455 | Make_Component_Association (Loc, |
| 3456 | Choices => New_List ( |
| 3457 | Make_Integer_Literal (Loc, |
| 3458 | DT_Position (Prim_Alias))), |
| 3459 | Expression => |
| 3460 | Make_Integer_Literal (Loc, |
| 3461 | DT_Position (Alias (Prim))))); |
| 3462 | |
| 3463 | Count := Count + 1; |
| 3464 | end if; |
| 3465 | end if; |
| 3466 | |
| 3467 | Next_Elmt (Prim_Elmt); |
| 3468 | end loop; |
| 3469 | pragma Assert (Count = Nb_Prim); |
| 3470 | end; |
| 3471 | |
| 3472 | OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); |
| 3473 | |
| 3474 | Append_To (Result, |
| 3475 | Make_Object_Declaration (Loc, |
| 3476 | Defining_Identifier => OSD, |
| 3477 | Object_Definition => |
| 3478 | Make_Subtype_Indication (Loc, |
| 3479 | Subtype_Mark => |
| 3480 | New_Reference_To (RTE (RE_Object_Specific_Data), Loc), |
| 3481 | Constraint => |
| 3482 | Make_Index_Or_Discriminant_Constraint (Loc, |
| 3483 | Constraints => New_List ( |
| 3484 | Make_Integer_Literal (Loc, Nb_Prim)))), |
| 3485 | Expression => Make_Aggregate (Loc, |
| 3486 | Component_Associations => New_List ( |
| 3487 | Make_Component_Association (Loc, |
| 3488 | Choices => New_List ( |
| 3489 | New_Occurrence_Of |
| 3490 | (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), |
| 3491 | Expression => |
| 3492 | Make_Integer_Literal (Loc, Nb_Prim)), |
| 3493 | |
| 3494 | Make_Component_Association (Loc, |
| 3495 | Choices => New_List ( |
| 3496 | New_Occurrence_Of |
| 3497 | (RTE_Record_Component (RE_OSD_Table), Loc)), |
| 3498 | Expression => Make_Aggregate (Loc, |
| 3499 | Component_Associations => OSD_Aggr_List)))))); |
| 3500 | |
| 17e14451 |
3501 | Append_To (Result, |
| 3502 | Make_Attribute_Definition_Clause (Loc, |
| 3503 | Name => New_Reference_To (OSD, Loc), |
| 3504 | Chars => Name_Alignment, |
| 3505 | Expression => |
| 3506 | Make_Attribute_Reference (Loc, |
| 3507 | Prefix => |
| 3508 | New_Reference_To (RTE (RE_Integer_Address), Loc), |
| 3509 | Attribute_Name => Name_Alignment))); |
| 3510 | |
| 725a69d2 |
3511 | -- In secondary dispatch tables the Typeinfo component contains |
| 3512 | -- the address of the Object Specific Data (see a-tags.ads) |
| 3513 | |
| 3514 | Append_To (DT_Aggr_List, |
| 3515 | Make_Attribute_Reference (Loc, |
| 3516 | Prefix => New_Reference_To (OSD, Loc), |
| 3517 | Attribute_Name => Name_Address)); |
| 3518 | end if; |
| 3519 | |
| 3520 | -- Initialize the table of primitive operations |
| 3521 | |
| 3522 | Prim_Ops_Aggr_List := New_List; |
| 3523 | |
| 3524 | if Empty_DT then |
| cc60bd16 |
3525 | Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); |
| 725a69d2 |
3526 | |
| 3527 | elsif Is_Abstract_Type (Typ) |
| 24971415 |
3528 | or else not Building_Static_DT (Typ) |
| 725a69d2 |
3529 | then |
| 3530 | for J in 1 .. Nb_Prim loop |
| cc60bd16 |
3531 | Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); |
| 725a69d2 |
3532 | end loop; |
| 3533 | |
| 3534 | else |
| 3535 | declare |
| 3536 | Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; |
| 3537 | Pos : Nat; |
| 3538 | Thunk_Code : Node_Id; |
| 3539 | Thunk_Id : Entity_Id; |
| 3540 | |
| 3541 | begin |
| 3542 | Prim_Table := (others => Empty); |
| 3543 | |
| 3544 | Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| 3545 | while Present (Prim_Elmt) loop |
| 3546 | Prim := Node (Prim_Elmt); |
| 3547 | |
| 3548 | if not Is_Predefined_Dispatching_Operation (Prim) |
| 3549 | and then Present (Abstract_Interface_Alias (Prim)) |
| 3550 | and then not Is_Abstract_Subprogram (Alias (Prim)) |
| 3551 | and then not Is_Imported (Alias (Prim)) |
| 3552 | and then Find_Dispatching_Type |
| 3553 | (Abstract_Interface_Alias (Prim)) = Iface |
| 3554 | |
| 3555 | -- Generate the code of the thunk only if the abstract |
| 3556 | -- interface type is not an immediate ancestor of |
| 3557 | -- Tagged_Type; otherwise the DT associated with the |
| 3558 | -- interface is the primary DT. |
| 3559 | |
| 3560 | and then not Is_Parent (Iface, Typ) |
| 3561 | then |
| cdb1c38f |
3562 | if not Build_Thunks then |
| 725a69d2 |
3563 | Pos := |
| 3564 | UI_To_Int |
| 3565 | (DT_Position (Abstract_Interface_Alias (Prim))); |
| cdb1c38f |
3566 | Prim_Table (Pos) := Alias (Prim); |
| 3567 | else |
| 3568 | Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); |
| 725a69d2 |
3569 | |
| cdb1c38f |
3570 | if Present (Thunk_Id) then |
| 3571 | Pos := |
| 3572 | UI_To_Int |
| 3573 | (DT_Position (Abstract_Interface_Alias (Prim))); |
| 3574 | |
| 3575 | Prim_Table (Pos) := Thunk_Id; |
| 3576 | Append_To (Result, Thunk_Code); |
| 3577 | end if; |
| 725a69d2 |
3578 | end if; |
| 3579 | end if; |
| 3580 | |
| 3581 | Next_Elmt (Prim_Elmt); |
| 3582 | end loop; |
| 3583 | |
| 3584 | for J in Prim_Table'Range loop |
| 3585 | if Present (Prim_Table (J)) then |
| 3586 | New_Node := |
| cc60bd16 |
3587 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
| acf97c11 |
3588 | Make_Attribute_Reference (Loc, |
| 3589 | Prefix => New_Reference_To (Prim_Table (J), Loc), |
| 3590 | Attribute_Name => Name_Unrestricted_Access)); |
| 725a69d2 |
3591 | else |
| cc60bd16 |
3592 | New_Node := Make_Null (Loc); |
| 725a69d2 |
3593 | end if; |
| 3594 | |
| 3595 | Append_To (Prim_Ops_Aggr_List, New_Node); |
| 3596 | end loop; |
| 3597 | end; |
| 3598 | end if; |
| 3599 | |
| cc60bd16 |
3600 | New_Node := |
| 725a69d2 |
3601 | Make_Aggregate (Loc, |
| cc60bd16 |
3602 | Expressions => Prim_Ops_Aggr_List); |
| 3603 | |
| 3604 | Append_To (DT_Aggr_List, New_Node); |
| 3605 | |
| 3606 | -- Remember aggregates initializing dispatch tables |
| 3607 | |
| 3608 | Append_Elmt (New_Node, DT_Aggr); |
| 725a69d2 |
3609 | |
| 3610 | Append_To (Result, |
| 3611 | Make_Object_Declaration (Loc, |
| 3612 | Defining_Identifier => Iface_DT, |
| 3613 | Aliased_Present => True, |
| 3614 | Object_Definition => |
| 3615 | Make_Subtype_Indication (Loc, |
| 3616 | Subtype_Mark => New_Reference_To |
| 3617 | (RTE (RE_Dispatch_Table_Wrapper), Loc), |
| 3618 | Constraint => Make_Index_Or_Discriminant_Constraint (Loc, |
| 3619 | Constraints => DT_Constr_List)), |
| 3620 | |
| 3621 | Expression => Make_Aggregate (Loc, |
| 3622 | Expressions => DT_Aggr_List))); |
| 3623 | |
| 17e14451 |
3624 | Append_To (Result, |
| 3625 | Make_Attribute_Definition_Clause (Loc, |
| 3626 | Name => New_Reference_To (Iface_DT, Loc), |
| 3627 | Chars => Name_Alignment, |
| 3628 | Expression => |
| 3629 | Make_Attribute_Reference (Loc, |
| 3630 | Prefix => |
| 3631 | New_Reference_To (RTE (RE_Integer_Address), Loc), |
| 3632 | Attribute_Name => Name_Alignment))); |
| 3633 | |
| 725a69d2 |
3634 | -- Generate code to create the pointer to the dispatch table |
| 3635 | |
| 3636 | -- Iface_DT_Ptr : Tag := Tag!(DT'Address); |
| 3637 | |
| 3638 | Append_To (Result, |
| 3639 | Make_Object_Declaration (Loc, |
| 3640 | Defining_Identifier => Iface_DT_Ptr, |
| 3641 | Constant_Present => True, |
| 3642 | Object_Definition => |
| 3643 | New_Reference_To (RTE (RE_Interface_Tag), Loc), |
| 3644 | Expression => |
| 24971415 |
3645 | Unchecked_Convert_To (RTE (RE_Interface_Tag), |
| 725a69d2 |
3646 | Make_Attribute_Reference (Loc, |
| 3647 | Prefix => |
| 3648 | Make_Selected_Component (Loc, |
| 3649 | Prefix => New_Reference_To (Iface_DT, Loc), |
| 3650 | Selector_Name => |
| 3651 | New_Occurrence_Of |
| 3652 | (RTE_Record_Component (RE_Prims_Ptr), Loc)), |
| 3653 | Attribute_Name => Name_Address)))); |
| 3654 | |
| acf97c11 |
3655 | Append_To (Result, |
| 3656 | Make_Object_Declaration (Loc, |
| 3657 | Defining_Identifier => Predef_Prims_Ptr, |
| 3658 | Constant_Present => True, |
| 3659 | Object_Definition => |
| 3660 | New_Reference_To (RTE (RE_Address), Loc), |
| 3661 | Expression => |
| 3662 | Make_Attribute_Reference (Loc, |
| 3663 | Prefix => |
| 3664 | Make_Selected_Component (Loc, |
| 3665 | Prefix => New_Reference_To (Iface_DT, Loc), |
| 3666 | Selector_Name => |
| 3667 | New_Occurrence_Of |
| 3668 | (RTE_Record_Component (RE_Predef_Prims), Loc)), |
| 3669 | Attribute_Name => Name_Address))); |
| 3670 | |
| cc60bd16 |
3671 | -- Remember entities containing dispatch tables |
| acf97c11 |
3672 | |
| cc60bd16 |
3673 | Append_Elmt (Predef_Prims, DT_Decl); |
| 3674 | Append_Elmt (Iface_DT, DT_Decl); |
| 725a69d2 |
3675 | end Make_Secondary_DT; |
| 3676 | |
| 3677 | -- Local variables |
| 3678 | |
| 725a69d2 |
3679 | Elab_Code : constant List_Id := New_List; |
| 17e14451 |
3680 | Result : constant List_Id := New_List; |
| 3681 | Tname : constant Name_Id := Chars (Typ); |
| 725a69d2 |
3682 | AI : Elmt_Id; |
| cdb1c38f |
3683 | AI_Tag_Elmt : Elmt_Id; |
| 24971415 |
3684 | AI_Tag_Comp : Elmt_Id; |
| f9162257 |
3685 | DT_Aggr_List : List_Id; |
| 24971415 |
3686 | DT_Constr_List : List_Id; |
| 725a69d2 |
3687 | DT_Ptr : Entity_Id; |
| 725a69d2 |
3688 | ITable : Node_Id; |
| 3689 | I_Depth : Nat := 0; |
| 3690 | Iface_Table_Node : Node_Id; |
| 3691 | Name_ITable : Name_Id; |
| 3692 | Name_No_Reg : Name_Id; |
| 3693 | Nb_Predef_Prims : Nat := 0; |
| 3694 | Nb_Prim : Nat := 0; |
| 3695 | New_Node : Node_Id; |
| 3696 | No_Reg : Node_Id; |
| 725a69d2 |
3697 | Num_Ifaces : Nat := 0; |
| cc60bd16 |
3698 | Parent_Typ : Entity_Id; |
| 725a69d2 |
3699 | Prim : Entity_Id; |
| 3700 | Prim_Elmt : Elmt_Id; |
| 3701 | Prim_Ops_Aggr_List : List_Id; |
| 725a69d2 |
3702 | Suffix_Index : Int; |
| 3703 | Typ_Comps : Elist_Id; |
| 3704 | Typ_Ifaces : Elist_Id; |
| 3705 | TSD_Aggr_List : List_Id; |
| 3706 | TSD_Tags_List : List_Id; |
| 17e14451 |
3707 | |
| 3708 | -- The following name entries are used by Make_DT to generate a number |
| 3709 | -- of entities related to a tagged type. These entities may be generated |
| 3710 | -- in a scope other than that of the tagged type declaration, and if |
| 3711 | -- the entities for two tagged types with the same name happen to be |
| 3712 | -- generated in the same scope, we have to take care to use different |
| 3713 | -- names. This is achieved by means of a unique serial number appended |
| 3714 | -- to each generated entity name. |
| 3715 | |
| 3716 | Name_DT : constant Name_Id := |
| 3717 | New_External_Name (Tname, 'T', Suffix_Index => -1); |
| 3718 | Name_Exname : constant Name_Id := |
| 3719 | New_External_Name (Tname, 'E', Suffix_Index => -1); |
| e7e688dd |
3720 | Name_HT_Link : constant Name_Id := |
| 3721 | New_External_Name (Tname, 'H', Suffix_Index => -1); |
| 17e14451 |
3722 | Name_Predef_Prims : constant Name_Id := |
| 3723 | New_External_Name (Tname, 'R', Suffix_Index => -1); |
| 3724 | Name_SSD : constant Name_Id := |
| 3725 | New_External_Name (Tname, 'S', Suffix_Index => -1); |
| 3726 | Name_TSD : constant Name_Id := |
| 3727 | New_External_Name (Tname, 'B', Suffix_Index => -1); |
| 3728 | |
| 3729 | -- Entities built with above names |
| 3730 | |
| 3731 | DT : constant Entity_Id := |
| 3732 | Make_Defining_Identifier (Loc, Name_DT); |
| 3733 | Exname : constant Entity_Id := |
| 3734 | Make_Defining_Identifier (Loc, Name_Exname); |
| e7e688dd |
3735 | HT_Link : constant Entity_Id := |
| 3736 | Make_Defining_Identifier (Loc, Name_HT_Link); |
| 17e14451 |
3737 | Predef_Prims : constant Entity_Id := |
| 3738 | Make_Defining_Identifier (Loc, Name_Predef_Prims); |
| 3739 | SSD : constant Entity_Id := |
| 3740 | Make_Defining_Identifier (Loc, Name_SSD); |
| 3741 | TSD : constant Entity_Id := |
| 3742 | Make_Defining_Identifier (Loc, Name_TSD); |
| 725a69d2 |
3743 | |
| 3744 | -- Start of processing for Make_DT |
| 3745 | |
| 3746 | begin |
| 17e14451 |
3747 | pragma Assert (Is_Frozen (Typ)); |
| 725a69d2 |
3748 | |
| 17e14451 |
3749 | -- Handle cases in which there is no need to build the dispatch table |
| 725a69d2 |
3750 | |
| 17e14451 |
3751 | if Has_Dispatch_Table (Typ) |
| 3752 | or else No (Access_Disp_Table (Typ)) |
| 3753 | or else Is_CPP_Class (Typ) |
| 3754 | then |
| 725a69d2 |
3755 | return Result; |
| 725a69d2 |
3756 | |
| 17e14451 |
3757 | elsif No_Run_Time_Mode then |
| 3758 | Error_Msg_CRT ("tagged types", Typ); |
| 3759 | return Result; |
| 725a69d2 |
3760 | |
| 17e14451 |
3761 | elsif not RTE_Available (RE_Tag) then |
| 725a69d2 |
3762 | Append_To (Result, |
| 3763 | Make_Object_Declaration (Loc, |
| 17e14451 |
3764 | Defining_Identifier => Node (First_Elmt |
| 3765 | (Access_Disp_Table (Typ))), |
| 725a69d2 |
3766 | Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), |
| 3767 | Constant_Present => True, |
| 3768 | Expression => |
| 24971415 |
3769 | Unchecked_Convert_To (RTE (RE_Tag), |
| 725a69d2 |
3770 | New_Reference_To (RTE (RE_Null_Address), Loc)))); |
| 3771 | |
| 3772 | Analyze_List (Result, Suppress => All_Checks); |
| 3773 | Error_Msg_CRT ("tagged types", Typ); |
| 3774 | return Result; |
| 3775 | end if; |
| 3776 | |
| 17e14451 |
3777 | -- Ensure that the value of Max_Predef_Prims defined in a-tags is |
| cdb1c38f |
3778 | -- correct. Valid values are 10 under configurable runtime or 16 |
| 17e14451 |
3779 | -- with full runtime. |
| 3780 | |
| 3781 | if RTE_Available (RE_Interface_Data) then |
| cdb1c38f |
3782 | if Max_Predef_Prims /= 16 then |
| 17e14451 |
3783 | Error_Msg_N ("run-time library configuration error", Typ); |
| 3784 | return Result; |
| 3785 | end if; |
| 725a69d2 |
3786 | else |
| 17e14451 |
3787 | if Max_Predef_Prims /= 10 then |
| 3788 | Error_Msg_N ("run-time library configuration error", Typ); |
| 3789 | Error_Msg_CRT ("tagged types", Typ); |
| 3790 | return Result; |
| 3791 | end if; |
| 725a69d2 |
3792 | end if; |
| 3793 | |
| cc60bd16 |
3794 | -- Initialize Parent_Typ handling private types |
| 3795 | |
| 3796 | Parent_Typ := Etype (Typ); |
| 3797 | |
| 3798 | if Present (Full_View (Parent_Typ)) then |
| 3799 | Parent_Typ := Full_View (Parent_Typ); |
| 3800 | end if; |
| 3801 | |
| 17e14451 |
3802 | -- Ensure that all the primitives are frozen. This is only required when |
| 3803 | -- building static dispatch tables --- the primitives must be frozen to |
| 3804 | -- be referenced (otherwise we have problems with the backend). It is |
| 3805 | -- not a requirement with nonstatic dispatch tables because in this case |
| 3806 | -- we generate now an empty dispatch table; the extra code required to |
| 24971415 |
3807 | -- register the primitives in the slots will be generated later --- when |
| 17e14451 |
3808 | -- each primitive is frozen (see Freeze_Subprogram). |
| 725a69d2 |
3809 | |
| 24971415 |
3810 | if Building_Static_DT (Typ) |
| 17e14451 |
3811 | and then not Is_CPP_Class (Typ) |
| 3812 | then |
| 3813 | declare |
| 3814 | Save : constant Boolean := Freezing_Library_Level_Tagged_Type; |
| 3815 | Prim_Elmt : Elmt_Id; |
| 3816 | Frnodes : List_Id; |
| 725a69d2 |
3817 | |
| 17e14451 |
3818 | begin |
| 3819 | Freezing_Library_Level_Tagged_Type := True; |
| 3820 | Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| 3821 | while Present (Prim_Elmt) loop |
| 3822 | Frnodes := Freeze_Entity (Node (Prim_Elmt), Loc); |
| 725a69d2 |
3823 | |
| 17e14451 |
3824 | declare |
| 3825 | Subp : constant Entity_Id := Node (Prim_Elmt); |
| 3826 | F : Entity_Id; |
| 725a69d2 |
3827 | |
| 17e14451 |
3828 | begin |
| 3829 | F := First_Formal (Subp); |
| 3830 | while Present (F) loop |
| 3831 | Check_Premature_Freezing (Subp, Etype (F)); |
| 3832 | Next_Formal (F); |
| 3833 | end loop; |
| 3834 | |
| 3835 | Check_Premature_Freezing (Subp, Etype (Subp)); |
| 3836 | end; |
| 3837 | |
| 3838 | if Present (Frnodes) then |
| 3839 | Append_List_To (Result, Frnodes); |
| 3840 | end if; |
| 3841 | |
| 3842 | Next_Elmt (Prim_Elmt); |
| 3843 | end loop; |
| 3844 | Freezing_Library_Level_Tagged_Type := Save; |
| 3845 | end; |
| 3846 | end if; |
| 725a69d2 |
3847 | |
| 17e14451 |
3848 | -- Ada 2005 (AI-251): Build the secondary dispatch tables |
| 3849 | |
| 3850 | if Has_Abstract_Interfaces (Typ) then |
| 3851 | Collect_Interface_Components (Typ, Typ_Comps); |
| 3852 | |
| 3853 | Suffix_Index := 0; |
| acf97c11 |
3854 | AI_Tag_Elmt := |
| 3855 | Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); |
| 17e14451 |
3856 | |
| 3857 | AI_Tag_Comp := First_Elmt (Typ_Comps); |
| 3858 | while Present (AI_Tag_Comp) loop |
| cdb1c38f |
3859 | |
| 3860 | -- Build the secondary table containing pointers to thunks |
| 3861 | |
| 17e14451 |
3862 | Make_Secondary_DT |
| cdb1c38f |
3863 | (Typ => Typ, |
| 3864 | Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))), |
| 3865 | Num_Iface_Prims => UI_To_Int |
| 3866 | (DT_Entry_Count (Node (AI_Tag_Comp))), |
| 3867 | Iface_DT_Ptr => Node (AI_Tag_Elmt), |
| acf97c11 |
3868 | Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), |
| cdb1c38f |
3869 | Build_Thunks => True, |
| 3870 | Result => Result); |
| 3871 | Next_Elmt (AI_Tag_Elmt); |
| 3872 | |
| acf97c11 |
3873 | -- Skip the secondary dispatch table of predefined primitives |
| 3874 | |
| 3875 | Next_Elmt (AI_Tag_Elmt); |
| 3876 | |
| 36b938a3 |
3877 | -- Build the secondary table containing pointers to primitives |
| cdb1c38f |
3878 | -- (used to give support to Generic Dispatching Constructors). |
| 3879 | |
| 3880 | Make_Secondary_DT |
| 3881 | (Typ => Typ, |
| 3882 | Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))), |
| 3883 | Num_Iface_Prims => UI_To_Int |
| 3884 | (DT_Entry_Count (Node (AI_Tag_Comp))), |
| 3885 | Iface_DT_Ptr => Node (AI_Tag_Elmt), |
| acf97c11 |
3886 | Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), |
| cdb1c38f |
3887 | Build_Thunks => False, |
| 3888 | Result => Result); |
| 3889 | Next_Elmt (AI_Tag_Elmt); |
| 725a69d2 |
3890 | |
| acf97c11 |
3891 | -- Skip the secondary dispatch table of predefined primitives |
| 3892 | |
| 3893 | Next_Elmt (AI_Tag_Elmt); |
| 3894 | |
| 17e14451 |
3895 | Suffix_Index := Suffix_Index + 1; |
| 17e14451 |
3896 | Next_Elmt (AI_Tag_Comp); |
| 3897 | end loop; |
| 3898 | end if; |
| 725a69d2 |
3899 | |
| 24971415 |
3900 | -- Get the _tag entity and the number of primitives of its dispatch |
| 3901 | -- table. |
| 725a69d2 |
3902 | |
| 24971415 |
3903 | DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); |
| 3904 | Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); |
| 725a69d2 |
3905 | |
| 24971415 |
3906 | Set_Is_Statically_Allocated (DT); |
| 725a69d2 |
3907 | Set_Is_Statically_Allocated (SSD); |
| 725a69d2 |
3908 | Set_Is_Statically_Allocated (TSD); |
| e7e688dd |
3909 | Set_Is_Statically_Allocated (Predef_Prims); |
| 725a69d2 |
3910 | |
| 3911 | -- Generate code to define the boolean that controls registration, in |
| 3912 | -- order to avoid multiple registrations for tagged types defined in |
| 3913 | -- multiple-called scopes. |
| 3914 | |
| cdb1c38f |
3915 | Name_No_Reg := New_External_Name (Tname, 'F', Suffix_Index => -1); |
| 3916 | No_Reg := Make_Defining_Identifier (Loc, Name_No_Reg); |
| 725a69d2 |
3917 | |
| cdb1c38f |
3918 | Set_Ekind (No_Reg, E_Variable); |
| 3919 | Set_Is_Statically_Allocated (No_Reg); |
| 725a69d2 |
3920 | |
| cdb1c38f |
3921 | Append_To (Result, |
| 3922 | Make_Object_Declaration (Loc, |
| 3923 | Defining_Identifier => No_Reg, |
| 3924 | Object_Definition => New_Reference_To (Standard_Boolean, Loc), |
| 3925 | Expression => New_Reference_To (Standard_True, Loc))); |
| 725a69d2 |
3926 | |
| 3927 | -- In case of locally defined tagged type we declare the object |
| 36b938a3 |
3928 | -- containing the dispatch table by means of a variable. Its |
| 725a69d2 |
3929 | -- initialization is done later by means of an assignment. This is |
| 3930 | -- required to generate its External_Tag. |
| 3931 | |
| 24971415 |
3932 | if not Building_Static_DT (Typ) then |
| 725a69d2 |
3933 | |
| 3934 | -- Generate: |
| 3935 | -- DT : No_Dispatch_Table_Wrapper; |
| 17e14451 |
3936 | -- for DT'Alignment use Address'Alignment; |
| 725a69d2 |
3937 | -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address); |
| 3938 | |
| 24971415 |
3939 | if not Has_DT (Typ) then |
| 725a69d2 |
3940 | Append_To (Result, |
| 3941 | Make_Object_Declaration (Loc, |
| 3942 | Defining_Identifier => DT, |
| 3943 | Aliased_Present => True, |
| 3944 | Constant_Present => False, |
| 3945 | Object_Definition => |
| 3946 | New_Reference_To |
| 3947 | (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); |
| 3948 | |
| 17e14451 |
3949 | Append_To (Result, |
| 3950 | Make_Attribute_Definition_Clause (Loc, |
| 3951 | Name => New_Reference_To (DT, Loc), |
| 3952 | Chars => Name_Alignment, |
| 3953 | Expression => |
| 3954 | Make_Attribute_Reference (Loc, |
| 3955 | Prefix => |
| 3956 | New_Reference_To (RTE (RE_Integer_Address), Loc), |
| 3957 | Attribute_Name => Name_Alignment))); |
| 3958 | |
| 725a69d2 |
3959 | Append_To (Result, |
| 3960 | Make_Object_Declaration (Loc, |
| 3961 | Defining_Identifier => DT_Ptr, |
| 3962 | Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), |
| 3963 | Constant_Present => True, |
| 3964 | Expression => |
| 24971415 |
3965 | Unchecked_Convert_To (RTE (RE_Tag), |
| 725a69d2 |
3966 | Make_Attribute_Reference (Loc, |
| 3967 | Prefix => |
| 3968 | Make_Selected_Component (Loc, |
| 3969 | Prefix => New_Reference_To (DT, Loc), |
| 3970 | Selector_Name => |
| 3971 | New_Occurrence_Of |
| 3972 | (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), |
| 3973 | Attribute_Name => Name_Address)))); |
| 3974 | |
| 3975 | -- Generate: |
| 3976 | -- DT : Dispatch_Table_Wrapper (Nb_Prim); |
| 3977 | -- for DT'Alignment use Address'Alignment; |
| 3978 | -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address); |
| 3979 | |
| 3980 | else |
| 3981 | -- If the tagged type has no primitives we add a dummy slot |
| 3982 | -- whose address will be the tag of this type. |
| 3983 | |
| 3984 | if Nb_Prim = 0 then |
| 3985 | DT_Constr_List := |
| 3986 | New_List (Make_Integer_Literal (Loc, 1)); |
| 3987 | else |
| 3988 | DT_Constr_List := |
| 3989 | New_List (Make_Integer_Literal (Loc, Nb_Prim)); |
| 3990 | end if; |
| 3991 | |
| 3992 | Append_To (Result, |
| 3993 | Make_Object_Declaration (Loc, |
| 3994 | Defining_Identifier => DT, |
| 3995 | Aliased_Present => True, |
| 3996 | Constant_Present => False, |
| 3997 | Object_Definition => |
| 3998 | Make_Subtype_Indication (Loc, |
| 3999 | Subtype_Mark => |
| 4000 | New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc), |
| 4001 | Constraint => Make_Index_Or_Discriminant_Constraint (Loc, |
| 4002 | Constraints => DT_Constr_List)))); |
| 4003 | |
| 4004 | Append_To (Result, |
| 4005 | Make_Attribute_Definition_Clause (Loc, |
| 4006 | Name => New_Reference_To (DT, Loc), |
| 4007 | Chars => Name_Alignment, |
| 4008 | Expression => |
| 4009 | Make_Attribute_Reference (Loc, |
| 4010 | Prefix => |
| 4011 | New_Reference_To (RTE (RE_Integer_Address), Loc), |
| 4012 | Attribute_Name => Name_Alignment))); |
| 4013 | |
| 4014 | Append_To (Result, |
| 4015 | Make_Object_Declaration (Loc, |
| 4016 | Defining_Identifier => DT_Ptr, |
| 4017 | Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), |
| 4018 | Constant_Present => True, |
| 4019 | Expression => |
| 24971415 |
4020 | Unchecked_Convert_To (RTE (RE_Tag), |
| 725a69d2 |
4021 | Make_Attribute_Reference (Loc, |
| 4022 | Prefix => |
| 4023 | Make_Selected_Component (Loc, |
| 4024 | Prefix => New_Reference_To (DT, Loc), |
| 4025 | Selector_Name => |
| 4026 | New_Occurrence_Of |
| 4027 | (RTE_Record_Component (RE_Prims_Ptr), Loc)), |
| 4028 | Attribute_Name => Name_Address)))); |
| acf97c11 |
4029 | |
| 4030 | Append_To (Result, |
| 4031 | Make_Object_Declaration (Loc, |
| 4032 | Defining_Identifier => |
| 4033 | Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))), |
| 4034 | Constant_Present => True, |
| 4035 | Object_Definition => New_Reference_To |
| 4036 | (RTE (RE_Address), Loc), |
| 4037 | Expression => |
| 4038 | Make_Attribute_Reference (Loc, |
| 4039 | Prefix => |
| 4040 | Make_Selected_Component (Loc, |
| 4041 | Prefix => New_Reference_To (DT, Loc), |
| 4042 | Selector_Name => |
| 4043 | New_Occurrence_Of |
| 4044 | (RTE_Record_Component (RE_Predef_Prims), Loc)), |
| 4045 | Attribute_Name => Name_Address))); |
| 725a69d2 |
4046 | end if; |
| 4047 | end if; |
| 4048 | |
| 4049 | -- Generate: Exname : constant String := full_qualified_name (typ); |
| 343d35dc |
4050 | -- The type itself may be an anonymous parent type, so use the first |
| 4051 | -- subtype to have a user-recognizable name. |
| d62940bf |
4052 | |
| 343d35dc |
4053 | Append_To (Result, |
| 4054 | Make_Object_Declaration (Loc, |
| 4055 | Defining_Identifier => Exname, |
| 4056 | Constant_Present => True, |
| 4057 | Object_Definition => New_Reference_To (Standard_String, Loc), |
| 4058 | Expression => |
| 4059 | Make_String_Literal (Loc, |
| 4060 | Full_Qualified_Name (First_Subtype (Typ))))); |
| d62940bf |
4061 | |
| 24971415 |
4062 | Set_Is_Statically_Allocated (Exname); |
| 4063 | Set_Is_True_Constant (Exname); |
| 4064 | |
| e7e688dd |
4065 | -- Declare the object used by Ada.Tags.Register_Tag |
| 4066 | |
| 4067 | if RTE_Available (RE_Register_Tag) then |
| 4068 | Append_To (Result, |
| 4069 | Make_Object_Declaration (Loc, |
| 4070 | Defining_Identifier => HT_Link, |
| 4071 | Object_Definition => New_Reference_To (RTE (RE_Tag), Loc))); |
| 4072 | end if; |
| 4073 | |
| 725a69d2 |
4074 | -- Generate code to create the storage for the type specific data object |
| 4075 | -- with enough space to store the tags of the ancestors plus the tags |
| 4076 | -- of all the implemented interfaces (as described in a-tags.adb). |
| 4077 | |
| 4078 | -- TSD : Type_Specific_Data (I_Depth) := |
| 4079 | -- (Idepth => I_Depth, |
| 4080 | -- Access_Level => Type_Access_Level (Typ), |
| 4081 | -- Expanded_Name => Cstring_Ptr!(Exname'Address)) |
| 4082 | -- External_Tag => Cstring_Ptr!(Exname'Address)) |
| e7e688dd |
4083 | -- HT_Link => HT_Link'Address, |
| 725a69d2 |
4084 | -- Transportable => <<boolean-value>>, |
| 4085 | -- RC_Offset => <<integer-value>>, |
| cc60bd16 |
4086 | -- [ Size_Func => Size_Prim'Access ] |
| 725a69d2 |
4087 | -- [ Interfaces_Table => <<access-value>> ] |
| 24971415 |
4088 | -- [ SSD => SSD_Table'Address ] |
| 725a69d2 |
4089 | -- Tags_Table => (0 => null, |
| 4090 | -- 1 => Parent'Tag |
| 4091 | -- ...); |
| 4092 | -- for TSD'Alignment use Address'Alignment |
| 4093 | |
| 4094 | TSD_Aggr_List := New_List; |
| 4095 | |
| 4096 | -- Idepth: Count ancestors to compute the inheritance depth. For private |
| 4097 | -- extensions, always go to the full view in order to compute the real |
| 4098 | -- inheritance depth. |
| 4099 | |
| 4100 | declare |
| 4101 | Current_Typ : Entity_Id; |
| 4102 | Parent_Typ : Entity_Id; |
| 4103 | |
| 4104 | begin |
| 4105 | I_Depth := 0; |
| 4106 | Current_Typ := Typ; |
| 4107 | loop |
| 4108 | Parent_Typ := Etype (Current_Typ); |
| 4109 | |
| 4110 | if Is_Private_Type (Parent_Typ) then |
| 4111 | Parent_Typ := Full_View (Base_Type (Parent_Typ)); |
| 4112 | end if; |
| 4113 | |
| 4114 | exit when Parent_Typ = Current_Typ; |
| 4115 | |
| 4116 | I_Depth := I_Depth + 1; |
| 4117 | Current_Typ := Parent_Typ; |
| 4118 | end loop; |
| 4119 | end; |
| 4120 | |
| 4121 | Append_To (TSD_Aggr_List, |
| 17e14451 |
4122 | Make_Integer_Literal (Loc, I_Depth)); |
| 725a69d2 |
4123 | |
| 4124 | -- Access_Level |
| 4125 | |
| 4126 | Append_To (TSD_Aggr_List, |
| 17e14451 |
4127 | Make_Integer_Literal (Loc, Type_Access_Level (Typ))); |
| 725a69d2 |
4128 | |
| 4129 | -- Expanded_Name |
| 4130 | |
| 4131 | Append_To (TSD_Aggr_List, |
| 17e14451 |
4132 | Unchecked_Convert_To (RTE (RE_Cstring_Ptr), |
| 4133 | Make_Attribute_Reference (Loc, |
| 4134 | Prefix => New_Reference_To (Exname, Loc), |
| 4135 | Attribute_Name => Name_Address))); |
| 725a69d2 |
4136 | |
| 4137 | -- External_Tag of a local tagged type |
| 4138 | |
| 17e14451 |
4139 | -- <typ>A : constant String := |
| 725a69d2 |
4140 | -- "Internal tag at 16#tag-addr#: <full-name-of-typ>"; |
| 4141 | |
| 4142 | -- The reason we generate this strange name is that we do not want to |
| 4143 | -- enter local tagged types in the global hash table used to compute |
| 4144 | -- the Internal_Tag attribute for two reasons: |
| 4145 | |
| 4146 | -- 1. It is hard to avoid a tasking race condition for entering the |
| 4147 | -- entry into the hash table. |
| 4148 | |
| 4149 | -- 2. It would cause a storage leak, unless we rig up considerable |
| 4150 | -- mechanism to remove the entry from the hash table on exit. |
| 4151 | |
| 4152 | -- So what we do is to generate the above external tag name, where the |
| 4153 | -- hex address is the address of the local dispatch table (i.e. exactly |
| 4154 | -- the value we want if Internal_Tag is computed from this string). |
| 4155 | |
| 4156 | -- Of course this value will only be valid if the tagged type is still |
| 4157 | -- in scope, but it clearly must be erroneous to compute the internal |
| 4158 | -- tag of a tagged type that is out of scope! |
| 4159 | |
| 17e14451 |
4160 | -- We don't do this processing if an explicit external tag has been |
| 4161 | -- specified. That's an odd case for which we have already issued a |
| 4162 | -- warning, where we will not be able to compute the internal tag. |
| 4163 | |
| 4164 | if not Is_Library_Level_Entity (Typ) |
| 4165 | and then not Has_External_Tag_Rep_Clause (Typ) |
| 4166 | then |
| 725a69d2 |
4167 | declare |
| 725a69d2 |
4168 | Exname : constant Entity_Id := |
| 17e14451 |
4169 | Make_Defining_Identifier (Loc, |
| 4170 | New_External_Name (Tname, 'A')); |
| 4171 | |
| 725a69d2 |
4172 | Full_Name : constant String_Id := |
| 4173 | Full_Qualified_Name (First_Subtype (Typ)); |
| 4174 | Str1_Id : String_Id; |
| 4175 | Str2_Id : String_Id; |
| 725a69d2 |
4176 | |
| 4177 | begin |
| 4178 | -- Generate: |
| 17e14451 |
4179 | -- Str1 = "Internal tag at 16#"; |
| 725a69d2 |
4180 | |
| 4181 | Start_String; |
| 4182 | Store_String_Chars ("Internal tag at 16#"); |
| 4183 | Str1_Id := End_String; |
| 4184 | |
| 4185 | -- Generate: |
| 17e14451 |
4186 | -- Str2 = "#: <type-full-name>"; |
| 725a69d2 |
4187 | |
| 4188 | Start_String; |
| 4189 | Store_String_Chars ("#: "); |
| 725a69d2 |
4190 | Store_String_Chars (Full_Name); |
| 17e14451 |
4191 | Str2_Id := End_String; |
| 725a69d2 |
4192 | |
| 4193 | -- Generate: |
| 4194 | -- Exname : constant String := |
| 17e14451 |
4195 | -- Str1 & Address_Image (Tag) & Str2; |
| 725a69d2 |
4196 | |
| 4197 | if RTE_Available (RE_Address_Image) then |
| 4198 | Append_To (Result, |
| 4199 | Make_Object_Declaration (Loc, |
| 4200 | Defining_Identifier => Exname, |
| 4201 | Constant_Present => True, |
| 4202 | Object_Definition => New_Reference_To |
| 4203 | (Standard_String, Loc), |
| 4204 | Expression => |
| 4205 | Make_Op_Concat (Loc, |
| 4206 | Left_Opnd => |
| 4207 | Make_String_Literal (Loc, Str1_Id), |
| 4208 | Right_Opnd => |
| 4209 | Make_Op_Concat (Loc, |
| 4210 | Left_Opnd => |
| 4211 | Make_Function_Call (Loc, |
| 4212 | Name => |
| 4213 | New_Reference_To |
| 4214 | (RTE (RE_Address_Image), Loc), |
| 4215 | Parameter_Associations => New_List ( |
| 4216 | Unchecked_Convert_To (RTE (RE_Address), |
| 4217 | New_Reference_To (DT_Ptr, Loc)))), |
| 4218 | Right_Opnd => |
| 17e14451 |
4219 | Make_String_Literal (Loc, Str2_Id))))); |
| 4220 | |
| 725a69d2 |
4221 | else |
| 4222 | Append_To (Result, |
| 4223 | Make_Object_Declaration (Loc, |
| 4224 | Defining_Identifier => Exname, |
| 4225 | Constant_Present => True, |
| 4226 | Object_Definition => New_Reference_To |
| 4227 | (Standard_String, Loc), |
| 4228 | Expression => |
| 4229 | Make_Op_Concat (Loc, |
| 4230 | Left_Opnd => |
| 4231 | Make_String_Literal (Loc, Str1_Id), |
| 4232 | Right_Opnd => |
| 17e14451 |
4233 | Make_String_Literal (Loc, Str2_Id)))); |
| 725a69d2 |
4234 | end if; |
| 4235 | |
| 4236 | New_Node := |
| 4237 | Unchecked_Convert_To (RTE (RE_Cstring_Ptr), |
| 4238 | Make_Attribute_Reference (Loc, |
| 4239 | Prefix => New_Reference_To (Exname, Loc), |
| 4240 | Attribute_Name => Name_Address)); |
| 4241 | end; |
| 4242 | |
| 4243 | -- External tag of a library-level tagged type: Check for a definition |
| 4244 | -- of External_Tag. The clause is considered only if it applies to this |
| 4245 | -- specific tagged type, as opposed to one of its ancestors. |
| cc60bd16 |
4246 | -- If the type is an unconstrained type extension, we are building the |
| 4247 | -- dispatch table of its anonymous base type, so the external tag, if |
| 4248 | -- any was specified, must be retrieved from the first subtype. |
| 725a69d2 |
4249 | |
| 4250 | else |
| 4251 | declare |
| cc60bd16 |
4252 | Def : constant Node_Id := Get_Attribute_Definition_Clause |
| 4253 | (First_Subtype (Typ), |
| 4254 | Attribute_External_Tag); |
| 4255 | |
| 725a69d2 |
4256 | Old_Val : String_Id; |
| 4257 | New_Val : String_Id; |
| 4258 | E : Entity_Id; |
| 4259 | |
| 4260 | begin |
| 4261 | if not Present (Def) |
| cc60bd16 |
4262 | or else Entity (Name (Def)) /= First_Subtype (Typ) |
| 725a69d2 |
4263 | then |
| 4264 | New_Node := |
| 4265 | Unchecked_Convert_To (RTE (RE_Cstring_Ptr), |
| 4266 | Make_Attribute_Reference (Loc, |
| cc60bd16 |
4267 | Prefix => New_Reference_To (Exname, Loc), |
| 725a69d2 |
4268 | Attribute_Name => Name_Address)); |
| 4269 | else |
| 4270 | Old_Val := Strval (Expr_Value_S (Expression (Def))); |
| 4271 | |
| 17e14451 |
4272 | -- For the rep clause "for <typ>'external_tag use y" generate: |
| 725a69d2 |
4273 | |
| 17e14451 |
4274 | -- <typ>A : constant string := y; |
| 4275 | -- |
| 4276 | -- <typ>A'Address is used to set the External_Tag component |
| 4277 | -- of the TSD |
| 725a69d2 |
4278 | |
| 4279 | -- Create a new nul terminated string if it is not already |
| 4280 | |
| 4281 | if String_Length (Old_Val) > 0 |
| 4282 | and then |
| 4283 | Get_String_Char (Old_Val, String_Length (Old_Val)) = 0 |
| 4284 | then |
| 4285 | New_Val := Old_Val; |
| 4286 | else |
| 4287 | Start_String (Old_Val); |
| 4288 | Store_String_Char (Get_Char_Code (ASCII.NUL)); |
| 4289 | New_Val := End_String; |
| 4290 | end if; |
| 4291 | |
| 4292 | E := Make_Defining_Identifier (Loc, |
| 4293 | New_External_Name (Chars (Typ), 'A')); |
| 4294 | |
| 4295 | Append_To (Result, |
| 4296 | Make_Object_Declaration (Loc, |
| 4297 | Defining_Identifier => E, |
| 4298 | Constant_Present => True, |
| 4299 | Object_Definition => |
| 4300 | New_Reference_To (Standard_String, Loc), |
| 4301 | Expression => |
| 4302 | Make_String_Literal (Loc, New_Val))); |
| 4303 | |
| 4304 | New_Node := |
| 4305 | Unchecked_Convert_To (RTE (RE_Cstring_Ptr), |
| 4306 | Make_Attribute_Reference (Loc, |
| 4307 | Prefix => New_Reference_To (E, Loc), |
| 4308 | Attribute_Name => Name_Address)); |
| 4309 | end if; |
| 4310 | end; |
| 4311 | end if; |
| 4312 | |
| 17e14451 |
4313 | Append_To (TSD_Aggr_List, New_Node); |
| 725a69d2 |
4314 | |
| 4315 | -- HT_Link |
| 4316 | |
| e7e688dd |
4317 | if RTE_Available (RE_Register_Tag) then |
| 4318 | Append_To (TSD_Aggr_List, |
| 4319 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), |
| 4320 | Make_Attribute_Reference (Loc, |
| 4321 | Prefix => New_Reference_To (HT_Link, Loc), |
| 4322 | Attribute_Name => Name_Address))); |
| 4323 | else |
| 4324 | Append_To (TSD_Aggr_List, |
| 4325 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), |
| 4326 | New_Reference_To (RTE (RE_Null_Address), Loc))); |
| 4327 | end if; |
| 725a69d2 |
4328 | |
| 4329 | -- Transportable: Set for types that can be used in remote calls |
| 4330 | -- with respect to E.4(18) legality rules. |
| 4331 | |
| 17e14451 |
4332 | declare |
| 4333 | Transportable : Entity_Id; |
| 725a69d2 |
4334 | |
| 17e14451 |
4335 | begin |
| 4336 | Transportable := |
| 4337 | Boolean_Literals |
| 4338 | (Is_Pure (Typ) |
| 4339 | or else Is_Shared_Passive (Typ) |
| 4340 | or else |
| 4341 | ((Is_Remote_Types (Typ) |
| 4342 | or else Is_Remote_Call_Interface (Typ)) |
| 4343 | and then Original_View_In_Visible_Part (Typ)) |
| 4344 | or else not Comes_From_Source (Typ)); |
| 4345 | |
| 4346 | Append_To (TSD_Aggr_List, |
| 4347 | New_Occurrence_Of (Transportable, Loc)); |
| 4348 | end; |
| 725a69d2 |
4349 | |
| 4350 | -- RC_Offset: These are the valid values and their meaning: |
| 4351 | |
| 343d35dc |
4352 | -- >0: For simple types with controlled components is |
| 4353 | -- type._record_controller'position |
| 725a69d2 |
4354 | |
| 343d35dc |
4355 | -- 0: For types with no controlled components |
| 725a69d2 |
4356 | |
| 343d35dc |
4357 | -- -1: For complex types with controlled components where the position |
| 4358 | -- of the record controller is not statically computable but there |
| 4359 | -- are controlled components at this level. The _Controller field |
| 4360 | -- is available right after the _parent. |
| 725a69d2 |
4361 | |
| 343d35dc |
4362 | -- -2: There are no controlled components at this level. We need to |
| 4363 | -- get the position from the parent. |
| 952af0b9 |
4364 | |
| 17e14451 |
4365 | declare |
| 4366 | RC_Offset_Node : Node_Id; |
| 343d35dc |
4367 | |
| 17e14451 |
4368 | begin |
| 4369 | if not Has_Controlled_Component (Typ) then |
| 4370 | RC_Offset_Node := Make_Integer_Literal (Loc, 0); |
| 4371 | |
| 4372 | elsif Etype (Typ) /= Typ |
| cdb1c38f |
4373 | and then Has_Discriminants (Parent_Typ) |
| 17e14451 |
4374 | then |
| 4375 | if Has_New_Controlled_Component (Typ) then |
| 4376 | RC_Offset_Node := Make_Integer_Literal (Loc, -1); |
| 4377 | else |
| 4378 | RC_Offset_Node := Make_Integer_Literal (Loc, -2); |
| 4379 | end if; |
| 343d35dc |
4380 | else |
| 17e14451 |
4381 | RC_Offset_Node := |
| 4382 | Make_Attribute_Reference (Loc, |
| 4383 | Prefix => |
| 4384 | Make_Selected_Component (Loc, |
| 4385 | Prefix => New_Reference_To (Typ, Loc), |
| 4386 | Selector_Name => |
| 4387 | New_Reference_To (Controller_Component (Typ), Loc)), |
| 4388 | Attribute_Name => Name_Position); |
| 4389 | |
| 4390 | -- This is not proper Ada code to use the attribute 'Position |
| 4391 | -- on something else than an object but this is supported by |
| 4392 | -- the back end (see comment on the Bit_Component attribute in |
| 4393 | -- sem_attr). So we avoid semantic checking here. |
| 4394 | |
| 4395 | -- Is this documented in sinfo.ads??? it should be! |
| 4396 | |
| 4397 | Set_Analyzed (RC_Offset_Node); |
| 4398 | Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller)); |
| 4399 | Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ); |
| 4400 | Set_Etype (Selector_Name (Prefix (RC_Offset_Node)), |
| 4401 | RTE (RE_Record_Controller)); |
| 4402 | Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset)); |
| 68f95949 |
4403 | end if; |
| 952af0b9 |
4404 | |
| 17e14451 |
4405 | Append_To (TSD_Aggr_List, RC_Offset_Node); |
| 4406 | end; |
| 725a69d2 |
4407 | |
| cc60bd16 |
4408 | -- Size_Func |
| 4409 | |
| 4410 | if RTE_Record_Component_Available (RE_Size_Func) then |
| 4411 | if not Building_Static_DT (Typ) |
| 4412 | or else Is_Interface (Typ) |
| 4413 | then |
| 4414 | Append_To (TSD_Aggr_List, |
| 4415 | Unchecked_Convert_To (RTE (RE_Size_Ptr), |
| 4416 | New_Reference_To (RTE (RE_Null_Address), Loc))); |
| 4417 | |
| 4418 | else |
| 4419 | declare |
| 4420 | Prim_Elmt : Elmt_Id; |
| 4421 | Prim : Entity_Id; |
| 4422 | |
| 4423 | begin |
| 4424 | Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| 4425 | while Present (Prim_Elmt) loop |
| 4426 | Prim := Node (Prim_Elmt); |
| 4427 | |
| 4428 | if Chars (Prim) = Name_uSize then |
| 4429 | while Present (Alias (Prim)) loop |
| 4430 | Prim := Alias (Prim); |
| 4431 | end loop; |
| 4432 | |
| 4433 | if Is_Abstract_Subprogram (Prim) then |
| 4434 | Append_To (TSD_Aggr_List, |
| 4435 | Unchecked_Convert_To (RTE (RE_Size_Ptr), |
| 4436 | New_Reference_To (RTE (RE_Null_Address), Loc))); |
| 4437 | else |
| 4438 | Append_To (TSD_Aggr_List, |
| 4439 | Unchecked_Convert_To (RTE (RE_Size_Ptr), |
| 4440 | Make_Attribute_Reference (Loc, |
| 4441 | Prefix => New_Reference_To (Prim, Loc), |
| 4442 | Attribute_Name => Name_Unrestricted_Access))); |
| 4443 | end if; |
| 4444 | |
| 4445 | exit; |
| 4446 | end if; |
| 4447 | |
| 4448 | Next_Elmt (Prim_Elmt); |
| 4449 | end loop; |
| 4450 | end; |
| 4451 | end if; |
| 4452 | end if; |
| 4453 | |
| 725a69d2 |
4454 | -- Interfaces_Table (required for AI-405) |
| 4455 | |
| 4456 | if RTE_Record_Component_Available (RE_Interfaces_Table) then |
| 4457 | |
| 4458 | -- Count the number of interface types implemented by Typ |
| 4459 | |
| 4460 | Collect_Abstract_Interfaces (Typ, Typ_Ifaces); |
| 4461 | |
| 4462 | AI := First_Elmt (Typ_Ifaces); |
| 4463 | while Present (AI) loop |
| 4464 | Num_Ifaces := Num_Ifaces + 1; |
| 4465 | Next_Elmt (AI); |
| 4466 | end loop; |
| 952af0b9 |
4467 | |
| 343d35dc |
4468 | if Num_Ifaces = 0 then |
| 725a69d2 |
4469 | Iface_Table_Node := Make_Null (Loc); |
| 952af0b9 |
4470 | |
| 725a69d2 |
4471 | -- Generate the Interface_Table object |
| 343d35dc |
4472 | |
| 4473 | else |
| 725a69d2 |
4474 | declare |
| 17e14451 |
4475 | TSD_Ifaces_List : constant List_Id := New_List; |
| cdb1c38f |
4476 | Elmt : Elmt_Id; |
| 4477 | Sec_DT_Tag : Node_Id; |
| 725a69d2 |
4478 | |
| 4479 | begin |
| 4480 | AI := First_Elmt (Typ_Ifaces); |
| 4481 | while Present (AI) loop |
| cdb1c38f |
4482 | if Is_Parent (Node (AI), Typ) then |
| 4483 | Sec_DT_Tag := |
| 4484 | New_Reference_To (DT_Ptr, Loc); |
| 4485 | else |
| acf97c11 |
4486 | Elmt := |
| 4487 | Next_Elmt |
| 4488 | (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); |
| cdb1c38f |
4489 | pragma Assert (Has_Thunks (Node (Elmt))); |
| 4490 | |
| 4491 | while Ekind (Node (Elmt)) = E_Constant |
| 4492 | and then not |
| 4493 | Is_Parent (Node (AI), Related_Type (Node (Elmt))) |
| 4494 | loop |
| 4495 | pragma Assert (Has_Thunks (Node (Elmt))); |
| 4496 | Next_Elmt (Elmt); |
| acf97c11 |
4497 | pragma Assert (Has_Thunks (Node (Elmt))); |
| 4498 | Next_Elmt (Elmt); |
| 4499 | pragma Assert (not Has_Thunks (Node (Elmt))); |
| 4500 | Next_Elmt (Elmt); |
| cdb1c38f |
4501 | pragma Assert (not Has_Thunks (Node (Elmt))); |
| 4502 | Next_Elmt (Elmt); |
| 4503 | end loop; |
| 4504 | |
| 4505 | pragma Assert (Ekind (Node (Elmt)) = E_Constant |
| acf97c11 |
4506 | and then not |
| 4507 | Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt))))); |
| cdb1c38f |
4508 | Sec_DT_Tag := |
| acf97c11 |
4509 | New_Reference_To (Node (Next_Elmt (Next_Elmt (Elmt))), |
| 4510 | Loc); |
| cdb1c38f |
4511 | end if; |
| 4512 | |
| 17e14451 |
4513 | Append_To (TSD_Ifaces_List, |
| 4514 | Make_Aggregate (Loc, |
| 4515 | Expressions => New_List ( |
| 4516 | |
| 4517 | -- Iface_Tag |
| 4518 | |
| 24971415 |
4519 | Unchecked_Convert_To (RTE (RE_Tag), |
| 725a69d2 |
4520 | New_Reference_To |
| 4521 | (Node (First_Elmt (Access_Disp_Table (Node (AI)))), |
| 17e14451 |
4522 | Loc)), |
| 725a69d2 |
4523 | |
| 17e14451 |
4524 | -- Static_Offset_To_Top |
| 725a69d2 |
4525 | |
| 17e14451 |
4526 | New_Reference_To (Standard_True, Loc), |
| 725a69d2 |
4527 | |
| 17e14451 |
4528 | -- Offset_To_Top_Value |
| 4529 | |
| 4530 | Make_Integer_Literal (Loc, 0), |
| 4531 | |
| 4532 | -- Offset_To_Top_Func |
| 4533 | |
| cdb1c38f |
4534 | Make_Null (Loc), |
| 4535 | |
| 4536 | -- Secondary_DT |
| 4537 | |
| 4538 | Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag) |
| 4539 | |
| 4540 | ))); |
| 725a69d2 |
4541 | |
| 725a69d2 |
4542 | Next_Elmt (AI); |
| 4543 | end loop; |
| 725a69d2 |
4544 | |
| 17e14451 |
4545 | Name_ITable := New_External_Name (Tname, 'I'); |
| 4546 | ITable := Make_Defining_Identifier (Loc, Name_ITable); |
| 4547 | Set_Is_Statically_Allocated (ITable); |
| 725a69d2 |
4548 | |
| 17e14451 |
4549 | -- The table of interfaces is not constant; its slots are |
| 4550 | -- filled at run-time by the IP routine using attribute |
| 4551 | -- 'Position to know the location of the tag components |
| 4552 | -- (and this attribute cannot be safely used before the |
| 4553 | -- object is initialized). |
| 725a69d2 |
4554 | |
| 17e14451 |
4555 | Append_To (Result, |
| 4556 | Make_Object_Declaration (Loc, |
| 4557 | Defining_Identifier => ITable, |
| 4558 | Aliased_Present => True, |
| 4559 | Constant_Present => False, |
| 4560 | Object_Definition => |
| 4561 | Make_Subtype_Indication (Loc, |
| 4562 | Subtype_Mark => |
| 4563 | New_Reference_To (RTE (RE_Interface_Data), Loc), |
| 4564 | Constraint => Make_Index_Or_Discriminant_Constraint |
| 4565 | (Loc, |
| 4566 | Constraints => New_List ( |
| 4567 | Make_Integer_Literal (Loc, Num_Ifaces)))), |
| 725a69d2 |
4568 | |
| 17e14451 |
4569 | Expression => Make_Aggregate (Loc, |
| 4570 | Expressions => New_List ( |
| 4571 | Make_Integer_Literal (Loc, Num_Ifaces), |
| 4572 | Make_Aggregate (Loc, |
| 4573 | Expressions => TSD_Ifaces_List))))); |
| 725a69d2 |
4574 | |
| 17e14451 |
4575 | Append_To (Result, |
| 4576 | Make_Attribute_Definition_Clause (Loc, |
| 4577 | Name => New_Reference_To (ITable, Loc), |
| 4578 | Chars => Name_Alignment, |
| 4579 | Expression => |
| 4580 | Make_Attribute_Reference (Loc, |
| 4581 | Prefix => |
| 4582 | New_Reference_To (RTE (RE_Integer_Address), Loc), |
| 4583 | Attribute_Name => Name_Alignment))); |
| 725a69d2 |
4584 | |
| 17e14451 |
4585 | Iface_Table_Node := |
| 4586 | Make_Attribute_Reference (Loc, |
| 4587 | Prefix => New_Reference_To (ITable, Loc), |
| 4588 | Attribute_Name => Name_Unchecked_Access); |
| 4589 | end; |
| 725a69d2 |
4590 | end if; |
| 4591 | |
| 17e14451 |
4592 | Append_To (TSD_Aggr_List, Iface_Table_Node); |
| 725a69d2 |
4593 | end if; |
| 4594 | |
| 4595 | -- Generate the Select Specific Data table for synchronized types that |
| 4596 | -- implement synchronized interfaces. The size of the table is |
| 4597 | -- constrained by the number of non-predefined primitive operations. |
| 4598 | |
| 4599 | if RTE_Record_Component_Available (RE_SSD) then |
| 4600 | if Ada_Version >= Ada_05 |
| 24971415 |
4601 | and then Has_DT (Typ) |
| 725a69d2 |
4602 | and then Is_Concurrent_Record_Type (Typ) |
| 4603 | and then Has_Abstract_Interfaces (Typ) |
| 4604 | and then Nb_Prim > 0 |
| 4605 | and then not Is_Abstract_Type (Typ) |
| 4606 | and then not Is_Controlled (Typ) |
| 4607 | and then not Restriction_Active (No_Dispatching_Calls) |
| 4608 | then |
| 343d35dc |
4609 | Append_To (Result, |
| 4610 | Make_Object_Declaration (Loc, |
| 725a69d2 |
4611 | Defining_Identifier => SSD, |
| 343d35dc |
4612 | Aliased_Present => True, |
| 4613 | Object_Definition => |
| 4614 | Make_Subtype_Indication (Loc, |
| 725a69d2 |
4615 | Subtype_Mark => New_Reference_To ( |
| 4616 | RTE (RE_Select_Specific_Data), Loc), |
| 4617 | Constraint => |
| 4618 | Make_Index_Or_Discriminant_Constraint (Loc, |
| 4619 | Constraints => New_List ( |
| 4620 | Make_Integer_Literal (Loc, Nb_Prim)))))); |
| 4621 | |
| 17e14451 |
4622 | Append_To (Result, |
| 4623 | Make_Attribute_Definition_Clause (Loc, |
| 4624 | Name => New_Reference_To (SSD, Loc), |
| 4625 | Chars => Name_Alignment, |
| 4626 | Expression => |
| 4627 | Make_Attribute_Reference (Loc, |
| 4628 | Prefix => |
| 4629 | New_Reference_To (RTE (RE_Integer_Address), Loc), |
| 4630 | Attribute_Name => Name_Alignment))); |
| 4631 | |
| 725a69d2 |
4632 | -- This table is initialized by Make_Select_Specific_Data_Table, |
| 4633 | -- which calls Set_Entry_Index and Set_Prim_Op_Kind. |
| 4634 | |
| 4635 | Append_To (TSD_Aggr_List, |
| 17e14451 |
4636 | Make_Attribute_Reference (Loc, |
| 4637 | Prefix => New_Reference_To (SSD, Loc), |
| 4638 | Attribute_Name => Name_Unchecked_Access)); |
| 725a69d2 |
4639 | else |
| 17e14451 |
4640 | Append_To (TSD_Aggr_List, Make_Null (Loc)); |
| 343d35dc |
4641 | end if; |
| 952af0b9 |
4642 | end if; |
| 4643 | |
| 725a69d2 |
4644 | -- Initialize the table of ancestor tags. In case of interface types |
| 4645 | -- this table is not needed. |
| d62940bf |
4646 | |
| cc60bd16 |
4647 | TSD_Tags_List := New_List; |
| 952af0b9 |
4648 | |
| cc60bd16 |
4649 | -- If we are not statically allocating the dispatch table then we must |
| 4650 | -- fill position 0 with null because we still have not generated the |
| 4651 | -- tag of Typ. |
| 343d35dc |
4652 | |
| cc60bd16 |
4653 | if not Building_Static_DT (Typ) |
| 4654 | or else Is_Interface (Typ) |
| 4655 | then |
| 4656 | Append_To (TSD_Tags_List, |
| 4657 | Unchecked_Convert_To (RTE (RE_Tag), |
| 4658 | New_Reference_To (RTE (RE_Null_Address), Loc))); |
| 343d35dc |
4659 | |
| cc60bd16 |
4660 | -- Otherwise we can safely reference the tag |
| 343d35dc |
4661 | |
| cc60bd16 |
4662 | else |
| 4663 | Append_To (TSD_Tags_List, |
| 4664 | New_Reference_To (DT_Ptr, Loc)); |
| 4665 | end if; |
| 343d35dc |
4666 | |
| cc60bd16 |
4667 | -- Fill the rest of the table with the tags of the ancestors |
| 343d35dc |
4668 | |
| cc60bd16 |
4669 | declare |
| 4670 | Current_Typ : Entity_Id; |
| 4671 | Parent_Typ : Entity_Id; |
| 4672 | Pos : Nat; |
| 725a69d2 |
4673 | |
| cc60bd16 |
4674 | begin |
| 17e14451 |
4675 | Pos := 1; |
| 4676 | Current_Typ := Typ; |
| 725a69d2 |
4677 | |
| 17e14451 |
4678 | loop |
| 4679 | Parent_Typ := Etype (Current_Typ); |
| 343d35dc |
4680 | |
| 17e14451 |
4681 | if Is_Private_Type (Parent_Typ) then |
| 4682 | Parent_Typ := Full_View (Base_Type (Parent_Typ)); |
| 4683 | end if; |
| 4684 | |
| 4685 | exit when Parent_Typ = Current_Typ; |
| 4686 | |
| 4687 | if Is_CPP_Class (Parent_Typ) |
| 4688 | or else Is_Interface (Typ) |
| 4689 | then |
| 4690 | -- The tags defined in the C++ side will be inherited when |
| 4691 | -- the object is constructed (Exp_Ch3.Build_Init_Procedure) |
| 4692 | |
| 4693 | Append_To (TSD_Tags_List, |
| 4694 | Unchecked_Convert_To (RTE (RE_Tag), |
| 4695 | New_Reference_To (RTE (RE_Null_Address), Loc))); |
| 4696 | else |
| 4697 | Append_To (TSD_Tags_List, |
| 4698 | New_Reference_To |
| 4699 | (Node (First_Elmt (Access_Disp_Table (Parent_Typ))), |
| 4700 | Loc)); |
| 4701 | end if; |
| 4702 | |
| 4703 | Pos := Pos + 1; |
| 4704 | Current_Typ := Parent_Typ; |
| 4705 | end loop; |
| 4706 | |
| 4707 | pragma Assert (Pos = I_Depth + 1); |
| 4708 | end; |
| 4709 | |
| 4710 | Append_To (TSD_Aggr_List, |
| 4711 | Make_Aggregate (Loc, |
| 4712 | Expressions => TSD_Tags_List)); |
| 343d35dc |
4713 | |
| 725a69d2 |
4714 | -- Build the TSD object |
| 343d35dc |
4715 | |
| 4716 | Append_To (Result, |
| 4717 | Make_Object_Declaration (Loc, |
| 4718 | Defining_Identifier => TSD, |
| 4719 | Aliased_Present => True, |
| 24971415 |
4720 | Constant_Present => Building_Static_DT (Typ), |
| 343d35dc |
4721 | Object_Definition => |
| 4722 | Make_Subtype_Indication (Loc, |
| 4723 | Subtype_Mark => New_Reference_To ( |
| 4724 | RTE (RE_Type_Specific_Data), Loc), |
| 4725 | Constraint => |
| 4726 | Make_Index_Or_Discriminant_Constraint (Loc, |
| 4727 | Constraints => New_List ( |
| 4728 | Make_Integer_Literal (Loc, I_Depth)))), |
| 725a69d2 |
4729 | |
| 343d35dc |
4730 | Expression => Make_Aggregate (Loc, |
| 17e14451 |
4731 | Expressions => TSD_Aggr_List))); |
| 343d35dc |
4732 | |
| 24971415 |
4733 | Set_Is_True_Constant (TSD, Building_Static_DT (Typ)); |
| 4734 | |
| 343d35dc |
4735 | Append_To (Result, |
| 4736 | Make_Attribute_Definition_Clause (Loc, |
| 4737 | Name => New_Reference_To (TSD, Loc), |
| 4738 | Chars => Name_Alignment, |
| 4739 | Expression => |
| 4740 | Make_Attribute_Reference (Loc, |
| 4741 | Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), |
| 4742 | Attribute_Name => Name_Alignment))); |
| 4743 | |
| 24971415 |
4744 | -- Initialize or declare the dispatch table object |
| 343d35dc |
4745 | |
| 24971415 |
4746 | if not Has_DT (Typ) then |
| 725a69d2 |
4747 | DT_Constr_List := New_List; |
| 4748 | DT_Aggr_List := New_List; |
| 343d35dc |
4749 | |
| 725a69d2 |
4750 | -- Typeinfo |
| 952af0b9 |
4751 | |
| 725a69d2 |
4752 | New_Node := |
| 4753 | Make_Attribute_Reference (Loc, |
| 4754 | Prefix => New_Reference_To (TSD, Loc), |
| 4755 | Attribute_Name => Name_Address); |
| 4756 | |
| 4757 | Append_To (DT_Constr_List, New_Node); |
| 4758 | Append_To (DT_Aggr_List, New_Copy (New_Node)); |
| 4759 | Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); |
| 4760 | |
| 4761 | -- In case of locally defined tagged types we have already declared |
| 4762 | -- and uninitialized object for the dispatch table, which is now |
| 24971415 |
4763 | -- initialized by means of the following assignment: |
| 4764 | |
| 4765 | -- DT := (TSD'Address, 0); |
| 725a69d2 |
4766 | |
| 24971415 |
4767 | if not Building_Static_DT (Typ) then |
| 725a69d2 |
4768 | Append_To (Result, |
| 4769 | Make_Assignment_Statement (Loc, |
| 4770 | Name => New_Reference_To (DT, Loc), |
| 4771 | Expression => Make_Aggregate (Loc, |
| 4772 | Expressions => DT_Aggr_List))); |
| 4773 | |
| 24971415 |
4774 | -- In case of library level tagged types we declare and export now |
| 4775 | -- the constant object containing the dummy dispatch table. There |
| 4776 | -- is no need to declare the tag here because it has been previously |
| 4777 | -- declared by Make_Tags |
| 4778 | |
| 4779 | -- DT : aliased constant No_Dispatch_Table := |
| 4780 | -- (NDT_TSD => TSD'Address; |
| 4781 | -- NDT_Prims_Ptr => 0); |
| 4782 | -- for DT'Alignment use Address'Alignment; |
| 725a69d2 |
4783 | |
| 4784 | else |
| 4785 | Append_To (Result, |
| 4786 | Make_Object_Declaration (Loc, |
| 4787 | Defining_Identifier => DT, |
| 4788 | Aliased_Present => True, |
| 17e14451 |
4789 | Constant_Present => True, |
| 725a69d2 |
4790 | Object_Definition => |
| 4791 | New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc), |
| 4792 | Expression => Make_Aggregate (Loc, |
| 4793 | Expressions => DT_Aggr_List))); |
| 4794 | |
| 17e14451 |
4795 | Append_To (Result, |
| 4796 | Make_Attribute_Definition_Clause (Loc, |
| 4797 | Name => New_Reference_To (DT, Loc), |
| 4798 | Chars => Name_Alignment, |
| 4799 | Expression => |
| 4800 | Make_Attribute_Reference (Loc, |
| 4801 | Prefix => |
| 4802 | New_Reference_To (RTE (RE_Integer_Address), Loc), |
| 4803 | Attribute_Name => Name_Alignment))); |
| 4804 | |
| 24971415 |
4805 | Export_DT (Typ, DT); |
| 725a69d2 |
4806 | end if; |
| 4807 | |
| 4808 | -- Common case: Typ has a dispatch table |
| 4809 | |
| 4810 | -- Generate: |
| 4811 | |
| 4812 | -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) := |
| 4813 | -- (predef-prim-op-1'address, |
| 4814 | -- predef-prim-op-2'address, |
| 4815 | -- ... |
| 4816 | -- predef-prim-op-n'address); |
| 4817 | -- for Predef_Prims'Alignment use Address'Alignment |
| 4818 | |
| 4819 | -- DT : Dispatch_Table (Nb_Prims) := |
| 4820 | -- (Signature => <sig-value>, |
| 4821 | -- Tag_Kind => <tag_kind-value>, |
| 4822 | -- Predef_Prims => Predef_Prims'First'Address, |
| 4823 | -- Offset_To_Top => 0, |
| 4824 | -- TSD => TSD'Address; |
| 4825 | -- Prims_Ptr => (prim-op-1'address, |
| 4826 | -- prim-op-2'address, |
| 4827 | -- ... |
| 4828 | -- prim-op-n'address)); |
| 17e14451 |
4829 | -- for DT'Alignment use Address'Alignment |
| 725a69d2 |
4830 | |
| 4831 | else |
| 4832 | declare |
| 4833 | Pos : Nat; |
| 4834 | |
| 4835 | begin |
| 24971415 |
4836 | if not Building_Static_DT (Typ) then |
| 725a69d2 |
4837 | Nb_Predef_Prims := Max_Predef_Prims; |
| 4838 | |
| 4839 | else |
| 4840 | Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| 4841 | while Present (Prim_Elmt) loop |
| 4842 | Prim := Node (Prim_Elmt); |
| 4843 | |
| 4844 | if Is_Predefined_Dispatching_Operation (Prim) |
| 4845 | and then not Is_Abstract_Subprogram (Prim) |
| 4846 | then |
| 4847 | Pos := UI_To_Int (DT_Position (Prim)); |
| 4848 | |
| 4849 | if Pos > Nb_Predef_Prims then |
| 4850 | Nb_Predef_Prims := Pos; |
| 4851 | end if; |
| 4852 | end if; |
| 4853 | |
| 4854 | Next_Elmt (Prim_Elmt); |
| 4855 | end loop; |
| 4856 | end if; |
| 4857 | |
| 4858 | declare |
| 4859 | Prim_Table : array |
| 4860 | (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; |
| cc60bd16 |
4861 | Decl : Node_Id; |
| 725a69d2 |
4862 | E : Entity_Id; |
| 4863 | |
| 4864 | begin |
| 4865 | Prim_Ops_Aggr_List := New_List; |
| 4866 | |
| 4867 | Prim_Table := (others => Empty); |
| 17e14451 |
4868 | |
| cdb1c38f |
4869 | if Building_Static_DT (Typ) then |
| 4870 | Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| 4871 | while Present (Prim_Elmt) loop |
| 4872 | Prim := Node (Prim_Elmt); |
| 725a69d2 |
4873 | |
| cdb1c38f |
4874 | if Is_Predefined_Dispatching_Operation (Prim) |
| 4875 | and then not Is_Abstract_Subprogram (Prim) |
| 4876 | and then not Present (Prim_Table |
| 4877 | (UI_To_Int (DT_Position (Prim)))) |
| 4878 | then |
| 4879 | E := Prim; |
| 4880 | while Present (Alias (E)) loop |
| 4881 | E := Alias (E); |
| 4882 | end loop; |
| 725a69d2 |
4883 | |
| cdb1c38f |
4884 | pragma Assert (not Is_Abstract_Subprogram (E)); |
| 4885 | Prim_Table (UI_To_Int (DT_Position (Prim))) := E; |
| 4886 | end if; |
| 725a69d2 |
4887 | |
| cdb1c38f |
4888 | Next_Elmt (Prim_Elmt); |
| 4889 | end loop; |
| 4890 | end if; |
| 725a69d2 |
4891 | |
| 4892 | for J in Prim_Table'Range loop |
| 4893 | if Present (Prim_Table (J)) then |
| 4894 | New_Node := |
| cc60bd16 |
4895 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
| acf97c11 |
4896 | Make_Attribute_Reference (Loc, |
| 4897 | Prefix => New_Reference_To (Prim_Table (J), Loc), |
| 4898 | Attribute_Name => Name_Unrestricted_Access)); |
| 725a69d2 |
4899 | else |
| cc60bd16 |
4900 | New_Node := Make_Null (Loc); |
| 725a69d2 |
4901 | end if; |
| 4902 | |
| 4903 | Append_To (Prim_Ops_Aggr_List, New_Node); |
| 4904 | end loop; |
| 343d35dc |
4905 | |
| cc60bd16 |
4906 | New_Node := |
| 4907 | Make_Aggregate (Loc, |
| 4908 | Expressions => Prim_Ops_Aggr_List); |
| 4909 | |
| 4910 | Decl := |
| 4911 | Make_Subtype_Declaration (Loc, |
| 4912 | Defining_Identifier => |
| 4913 | Make_Defining_Identifier (Loc, |
| 4914 | New_Internal_Name ('S')), |
| 4915 | Subtype_Indication => |
| 4916 | New_Reference_To (RTE (RE_Address_Array), Loc)); |
| 4917 | |
| 4918 | Append_To (Result, Decl); |
| 4919 | |
| 68f95949 |
4920 | Append_To (Result, |
| 4921 | Make_Object_Declaration (Loc, |
| 725a69d2 |
4922 | Defining_Identifier => Predef_Prims, |
| 68f95949 |
4923 | Aliased_Present => True, |
| 24971415 |
4924 | Constant_Present => Building_Static_DT (Typ), |
| cc60bd16 |
4925 | Object_Definition => New_Reference_To |
| 4926 | (Defining_Identifier (Decl), Loc), |
| 4927 | Expression => New_Node)); |
| 4928 | |
| 4929 | -- Remember aggregates initializing dispatch tables |
| 4930 | |
| 4931 | Append_Elmt (New_Node, DT_Aggr); |
| 725a69d2 |
4932 | |
| 4933 | Append_To (Result, |
| 4934 | Make_Attribute_Definition_Clause (Loc, |
| 4935 | Name => New_Reference_To (Predef_Prims, Loc), |
| 4936 | Chars => Name_Alignment, |
| 4937 | Expression => |
| 4938 | Make_Attribute_Reference (Loc, |
| 4939 | Prefix => |
| 4940 | New_Reference_To (RTE (RE_Integer_Address), Loc), |
| 4941 | Attribute_Name => Name_Alignment))); |
| 4942 | end; |
| 4943 | end; |
| 4944 | |
| 4945 | -- Stage 1: Initialize the discriminant and the record components |
| 4946 | |
| 4947 | DT_Constr_List := New_List; |
| 4948 | DT_Aggr_List := New_List; |
| 4949 | |
| 4950 | -- Num_Prims. If the tagged type has no primitives we add a dummy |
| 4951 | -- slot whose address will be the tag of this type. |
| 4952 | |
| 4953 | if Nb_Prim = 0 then |
| 4954 | New_Node := Make_Integer_Literal (Loc, 1); |
| 4955 | else |
| 4956 | New_Node := Make_Integer_Literal (Loc, Nb_Prim); |
| 4957 | end if; |
| 4958 | |
| 4959 | Append_To (DT_Constr_List, New_Node); |
| 4960 | Append_To (DT_Aggr_List, New_Copy (New_Node)); |
| 4961 | |
| 4962 | -- Signature |
| 4963 | |
| 4964 | if RTE_Record_Component_Available (RE_Signature) then |
| 4965 | Append_To (DT_Aggr_List, |
| 4966 | New_Reference_To (RTE (RE_Primary_DT), Loc)); |
| 4967 | end if; |
| 4968 | |
| 4969 | -- Tag_Kind |
| 4970 | |
| 4971 | if RTE_Record_Component_Available (RE_Tag_Kind) then |
| 4972 | Append_To (DT_Aggr_List, Tagged_Kind (Typ)); |
| 4973 | end if; |
| 4974 | |
| 4975 | -- Predef_Prims |
| 4976 | |
| 4977 | Append_To (DT_Aggr_List, |
| 4978 | Make_Attribute_Reference (Loc, |
| 4979 | Prefix => New_Reference_To (Predef_Prims, Loc), |
| 4980 | Attribute_Name => Name_Address)); |
| 4981 | |
| 4982 | -- Offset_To_Top |
| 4983 | |
| cc60bd16 |
4984 | Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); |
| 725a69d2 |
4985 | |
| 4986 | -- Typeinfo |
| 4987 | |
| 4988 | Append_To (DT_Aggr_List, |
| 4989 | Make_Attribute_Reference (Loc, |
| 4990 | Prefix => New_Reference_To (TSD, Loc), |
| 4991 | Attribute_Name => Name_Address)); |
| 4992 | |
| 4993 | -- Stage 2: Initialize the table of primitive operations |
| 4994 | |
| 4995 | Prim_Ops_Aggr_List := New_List; |
| 4996 | |
| 4997 | if Nb_Prim = 0 then |
| cc60bd16 |
4998 | Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); |
| 725a69d2 |
4999 | |
| 24971415 |
5000 | elsif not Building_Static_DT (Typ) then |
| 725a69d2 |
5001 | for J in 1 .. Nb_Prim loop |
| cc60bd16 |
5002 | Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); |
| 725a69d2 |
5003 | end loop; |
| 5004 | |
| 5005 | else |
| 5006 | declare |
| 5007 | Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; |
| 5008 | E : Entity_Id; |
| 5009 | Prim : Entity_Id; |
| 5010 | Prim_Elmt : Elmt_Id; |
| 5011 | |
| 5012 | begin |
| 5013 | Prim_Table := (others => Empty); |
| cdb1c38f |
5014 | |
| 5015 | Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| 725a69d2 |
5016 | while Present (Prim_Elmt) loop |
| 5017 | Prim := Node (Prim_Elmt); |
| 5018 | |
| 5019 | if Is_Imported (Prim) |
| 5020 | or else Present (Abstract_Interface_Alias (Prim)) |
| 5021 | or else Is_Predefined_Dispatching_Operation (Prim) |
| 5022 | then |
| 5023 | null; |
| 5024 | |
| 5025 | else |
| 5026 | -- Traverse the list of aliased entities to handle |
| 5027 | -- renamings of predefined primitives. |
| 5028 | |
| 5029 | E := Prim; |
| 5030 | while Present (Alias (E)) loop |
| 5031 | E := Alias (E); |
| 5032 | end loop; |
| 5033 | |
| 5034 | if not Is_Predefined_Dispatching_Operation (E) |
| 5035 | and then not Is_Abstract_Subprogram (E) |
| 5036 | and then not Present (Abstract_Interface_Alias (E)) |
| 5037 | then |
| 5038 | pragma Assert |
| 5039 | (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); |
| 5040 | |
| 5041 | Prim_Table (UI_To_Int (DT_Position (Prim))) := E; |
| 725a69d2 |
5042 | end if; |
| 5043 | end if; |
| 5044 | |
| 5045 | Next_Elmt (Prim_Elmt); |
| 5046 | end loop; |
| 5047 | |
| 5048 | for J in Prim_Table'Range loop |
| 5049 | if Present (Prim_Table (J)) then |
| 5050 | New_Node := |
| cc60bd16 |
5051 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
| acf97c11 |
5052 | Make_Attribute_Reference (Loc, |
| 5053 | Prefix => New_Reference_To (Prim_Table (J), Loc), |
| 5054 | Attribute_Name => Name_Unrestricted_Access)); |
| 725a69d2 |
5055 | else |
| cc60bd16 |
5056 | New_Node := Make_Null (Loc); |
| 725a69d2 |
5057 | end if; |
| 5058 | |
| 5059 | Append_To (Prim_Ops_Aggr_List, New_Node); |
| 5060 | end loop; |
| 5061 | end; |
| 5062 | end if; |
| 5063 | |
| cc60bd16 |
5064 | New_Node := |
| 725a69d2 |
5065 | Make_Aggregate (Loc, |
| cc60bd16 |
5066 | Expressions => Prim_Ops_Aggr_List); |
| 5067 | |
| 5068 | Append_To (DT_Aggr_List, New_Node); |
| 5069 | |
| 5070 | -- Remember aggregates initializing dispatch tables |
| 5071 | |
| 5072 | Append_Elmt (New_Node, DT_Aggr); |
| 725a69d2 |
5073 | |
| 5074 | -- In case of locally defined tagged types we have already declared |
| 5075 | -- and uninitialized object for the dispatch table, which is now |
| 5076 | -- initialized by means of an assignment. |
| 5077 | |
| 24971415 |
5078 | if not Building_Static_DT (Typ) then |
| 725a69d2 |
5079 | Append_To (Result, |
| 5080 | Make_Assignment_Statement (Loc, |
| 5081 | Name => New_Reference_To (DT, Loc), |
| 5082 | Expression => Make_Aggregate (Loc, |
| 5083 | Expressions => DT_Aggr_List))); |
| 5084 | |
| 24971415 |
5085 | -- In case of library level tagged types we declare now and export |
| 5086 | -- the constant object containing the dispatch table. |
| 725a69d2 |
5087 | |
| 5088 | else |
| 5089 | Append_To (Result, |
| 5090 | Make_Object_Declaration (Loc, |
| 5091 | Defining_Identifier => DT, |
| 5092 | Aliased_Present => True, |
| 17e14451 |
5093 | Constant_Present => True, |
| 725a69d2 |
5094 | Object_Definition => |
| 5095 | Make_Subtype_Indication (Loc, |
| 5096 | Subtype_Mark => New_Reference_To |
| 5097 | (RTE (RE_Dispatch_Table_Wrapper), Loc), |
| 5098 | Constraint => Make_Index_Or_Discriminant_Constraint (Loc, |
| 5099 | Constraints => DT_Constr_List)), |
| 5100 | Expression => Make_Aggregate (Loc, |
| 5101 | Expressions => DT_Aggr_List))); |
| 5102 | |
| 5103 | Append_To (Result, |
| 5104 | Make_Attribute_Definition_Clause (Loc, |
| 5105 | Name => New_Reference_To (DT, Loc), |
| 5106 | Chars => Name_Alignment, |
| 5107 | Expression => |
| 5108 | Make_Attribute_Reference (Loc, |
| 5109 | Prefix => |
| 5110 | New_Reference_To (RTE (RE_Integer_Address), Loc), |
| 5111 | Attribute_Name => Name_Alignment))); |
| 5112 | |
| 24971415 |
5113 | Export_DT (Typ, DT); |
| 952af0b9 |
5114 | end if; |
| 76a1c25b |
5115 | end if; |
| d62940bf |
5116 | |
| 725a69d2 |
5117 | -- Initialize the table of ancestor tags |
| 5118 | |
| 24971415 |
5119 | if not Building_Static_DT (Typ) |
| 17e14451 |
5120 | and then not Is_Interface (Typ) |
| 725a69d2 |
5121 | and then not Is_CPP_Class (Typ) |
| 5122 | then |
| 5123 | Append_To (Result, |
| 5124 | Make_Assignment_Statement (Loc, |
| 5125 | Name => |
| 5126 | Make_Indexed_Component (Loc, |
| 5127 | Prefix => |
| 5128 | Make_Selected_Component (Loc, |
| 5129 | Prefix => |
| 5130 | New_Reference_To (TSD, Loc), |
| 5131 | Selector_Name => |
| 5132 | New_Reference_To |
| 5133 | (RTE_Record_Component (RE_Tags_Table), Loc)), |
| 5134 | Expressions => |
| 5135 | New_List (Make_Integer_Literal (Loc, 0))), |
| 5136 | |
| 5137 | Expression => |
| 5138 | New_Reference_To |
| 5139 | (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); |
| 5140 | end if; |
| 5141 | |
| acf97c11 |
5142 | -- Inherit the dispatch tables of the parent |
| 5143 | |
| 5144 | -- There is no need to inherit anything from the parent when building |
| 5145 | -- static dispatch tables because the whole dispatch table (including |
| 5146 | -- inherited primitives) has been already built. |
| 5147 | |
| 24971415 |
5148 | if Building_Static_DT (Typ) then |
| 725a69d2 |
5149 | null; |
| 5150 | |
| af647dc7 |
5151 | -- If the ancestor is a CPP_Class type we inherit the dispatch tables |
| 5152 | -- in the init proc, and we don't need to fill them in here. |
| d62940bf |
5153 | |
| cc60bd16 |
5154 | elsif Is_CPP_Class (Parent_Typ) then |
| af647dc7 |
5155 | null; |
| d62940bf |
5156 | |
| acf97c11 |
5157 | -- Otherwise we fill in the dispatch tables here |
| d62940bf |
5158 | |
| af647dc7 |
5159 | else |
| cc60bd16 |
5160 | if Typ /= Parent_Typ |
| af647dc7 |
5161 | and then not Is_Interface (Typ) |
| 5162 | and then not Restriction_Active (No_Dispatching_Calls) |
| 68f95949 |
5163 | then |
| 343d35dc |
5164 | -- Inherit the dispatch table |
| d62940bf |
5165 | |
| acf97c11 |
5166 | if not Is_Interface (Typ) |
| cc60bd16 |
5167 | and then not Is_Interface (Parent_Typ) |
| 5168 | and then not Is_CPP_Class (Parent_Typ) |
| acf97c11 |
5169 | then |
| 5170 | declare |
| 5171 | Nb_Prims : constant Int := |
| 5172 | UI_To_Int (DT_Entry_Count |
| cc60bd16 |
5173 | (First_Tag_Component (Parent_Typ))); |
| 5174 | |
| acf97c11 |
5175 | begin |
| 5176 | Append_To (Elab_Code, |
| 5177 | Build_Inherit_Predefined_Prims (Loc, |
| 5178 | Old_Tag_Node => |
| 5179 | New_Reference_To |
| 5180 | (Node |
| 5181 | (Next_Elmt |
| 5182 | (First_Elmt |
| cc60bd16 |
5183 | (Access_Disp_Table (Parent_Typ)))), Loc), |
| acf97c11 |
5184 | New_Tag_Node => |
| 5185 | New_Reference_To |
| 5186 | (Node |
| 5187 | (Next_Elmt |
| 5188 | (First_Elmt |
| 5189 | (Access_Disp_Table (Typ)))), Loc))); |
| 5190 | |
| 5191 | if Nb_Prims /= 0 then |
| 725a69d2 |
5192 | Append_To (Elab_Code, |
| acf97c11 |
5193 | Build_Inherit_Prims (Loc, |
| 5194 | Typ => Typ, |
| 5195 | Old_Tag_Node => |
| 5196 | New_Reference_To |
| 5197 | (Node |
| 5198 | (First_Elmt |
| cc60bd16 |
5199 | (Access_Disp_Table (Parent_Typ))), Loc), |
| acf97c11 |
5200 | New_Tag_Node => New_Reference_To (DT_Ptr, Loc), |
| 5201 | Num_Prims => Nb_Prims)); |
| 5202 | end if; |
| 5203 | end; |
| af647dc7 |
5204 | end if; |
| d62940bf |
5205 | |
| af647dc7 |
5206 | -- Inherit the secondary dispatch tables of the ancestor |
| d62940bf |
5207 | |
| cc60bd16 |
5208 | if not Is_CPP_Class (Parent_Typ) then |
| af647dc7 |
5209 | declare |
| 5210 | Sec_DT_Ancestor : Elmt_Id := |
| 5211 | Next_Elmt |
| acf97c11 |
5212 | (Next_Elmt |
| af647dc7 |
5213 | (First_Elmt |
| cc60bd16 |
5214 | (Access_Disp_Table (Parent_Typ)))); |
| af647dc7 |
5215 | Sec_DT_Typ : Elmt_Id := |
| 5216 | Next_Elmt |
| acf97c11 |
5217 | (Next_Elmt |
| 5218 | (First_Elmt |
| 5219 | (Access_Disp_Table (Typ)))); |
| af647dc7 |
5220 | |
| 5221 | procedure Copy_Secondary_DTs (Typ : Entity_Id); |
| 5222 | -- Local procedure required to climb through the ancestors |
| 5223 | -- and copy the contents of all their secondary dispatch |
| 5224 | -- tables. |
| 5225 | |
| 5226 | ------------------------ |
| 5227 | -- Copy_Secondary_DTs -- |
| 5228 | ------------------------ |
| 5229 | |
| 5230 | procedure Copy_Secondary_DTs (Typ : Entity_Id) is |
| 5231 | E : Entity_Id; |
| 5232 | Iface : Elmt_Id; |
| 5233 | |
| 5234 | begin |
| 5235 | -- Climb to the ancestor (if any) handling private types |
| 5236 | |
| 5237 | if Present (Full_View (Etype (Typ))) then |
| 5238 | if Full_View (Etype (Typ)) /= Typ then |
| 5239 | Copy_Secondary_DTs (Full_View (Etype (Typ))); |
| 5240 | end if; |
| d62940bf |
5241 | |
| af647dc7 |
5242 | elsif Etype (Typ) /= Typ then |
| 5243 | Copy_Secondary_DTs (Etype (Typ)); |
| 5244 | end if; |
| d62940bf |
5245 | |
| af647dc7 |
5246 | if Present (Abstract_Interfaces (Typ)) |
| 5247 | and then not Is_Empty_Elmt_List |
| 5248 | (Abstract_Interfaces (Typ)) |
| 5249 | then |
| 5250 | Iface := First_Elmt (Abstract_Interfaces (Typ)); |
| 5251 | E := First_Entity (Typ); |
| 5252 | while Present (E) |
| 5253 | and then Present (Node (Sec_DT_Ancestor)) |
| 725a69d2 |
5254 | and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant |
| af647dc7 |
5255 | loop |
| 5256 | if Is_Tag (E) and then Chars (E) /= Name_uTag then |
| cdb1c38f |
5257 | declare |
| 5258 | Num_Prims : constant Int := |
| 5259 | UI_To_Int (DT_Entry_Count (E)); |
| 5260 | |
| 5261 | begin |
| 5262 | if not Is_Interface (Etype (Typ)) then |
| 5263 | |
| 5264 | -- Inherit first secondary dispatch table |
| 5265 | |
| 5266 | Append_To (Elab_Code, |
| 5267 | Build_Inherit_Predefined_Prims (Loc, |
| 5268 | Old_Tag_Node => |
| 5269 | Unchecked_Convert_To (RTE (RE_Tag), |
| acf97c11 |
5270 | New_Reference_To |
| 5271 | (Node |
| 5272 | (Next_Elmt (Sec_DT_Ancestor)), |
| 5273 | Loc)), |
| cdb1c38f |
5274 | New_Tag_Node => |
| 5275 | Unchecked_Convert_To (RTE (RE_Tag), |
| 5276 | New_Reference_To |
| acf97c11 |
5277 | (Node (Next_Elmt (Sec_DT_Typ)), |
| 5278 | Loc)))); |
| cdb1c38f |
5279 | |
| 5280 | if Num_Prims /= 0 then |
| 5281 | Append_To (Elab_Code, |
| 5282 | Build_Inherit_Prims (Loc, |
| 5283 | Typ => Node (Iface), |
| 5284 | Old_Tag_Node => |
| 5285 | Unchecked_Convert_To |
| 5286 | (RTE (RE_Tag), |
| 5287 | New_Reference_To |
| 5288 | (Node (Sec_DT_Ancestor), |
| 5289 | Loc)), |
| 5290 | New_Tag_Node => |
| 5291 | Unchecked_Convert_To |
| 5292 | (RTE (RE_Tag), |
| 5293 | New_Reference_To |
| 5294 | (Node (Sec_DT_Typ), Loc)), |
| 5295 | Num_Prims => Num_Prims)); |
| 5296 | end if; |
| 5297 | end if; |
| 5298 | |
| 5299 | Next_Elmt (Sec_DT_Ancestor); |
| 5300 | Next_Elmt (Sec_DT_Typ); |
| 343d35dc |
5301 | |
| acf97c11 |
5302 | -- Skip the secondary dispatch table of |
| 5303 | -- predefined primitives |
| 5304 | |
| 5305 | Next_Elmt (Sec_DT_Ancestor); |
| 5306 | Next_Elmt (Sec_DT_Typ); |
| 5307 | |
| cdb1c38f |
5308 | if not Is_Interface (Etype (Typ)) then |
| 5309 | |
| 5310 | -- Inherit second secondary dispatch table |
| 343d35dc |
5311 | |
| 343d35dc |
5312 | Append_To (Elab_Code, |
| 5313 | Build_Inherit_Predefined_Prims (Loc, |
| 5314 | Old_Tag_Node => |
| 5315 | Unchecked_Convert_To (RTE (RE_Tag), |
| 5316 | New_Reference_To |
| acf97c11 |
5317 | (Node |
| 5318 | (Next_Elmt (Sec_DT_Ancestor)), |
| 5319 | Loc)), |
| 343d35dc |
5320 | New_Tag_Node => |
| 5321 | Unchecked_Convert_To (RTE (RE_Tag), |
| 5322 | New_Reference_To |
| acf97c11 |
5323 | (Node (Next_Elmt (Sec_DT_Typ)), |
| 5324 | Loc)))); |
| 343d35dc |
5325 | |
| 5326 | if Num_Prims /= 0 then |
| 5327 | Append_To (Elab_Code, |
| 5328 | Build_Inherit_Prims (Loc, |
| 17e14451 |
5329 | Typ => Node (Iface), |
| 343d35dc |
5330 | Old_Tag_Node => |
| 5331 | Unchecked_Convert_To |
| 5332 | (RTE (RE_Tag), |
| 5333 | New_Reference_To |
| 5334 | (Node (Sec_DT_Ancestor), |
| 5335 | Loc)), |
| 5336 | New_Tag_Node => |
| 5337 | Unchecked_Convert_To |
| 5338 | (RTE (RE_Tag), |
| 5339 | New_Reference_To |
| 5340 | (Node (Sec_DT_Typ), Loc)), |
| 17e14451 |
5341 | Num_Prims => Num_Prims)); |
| 343d35dc |
5342 | end if; |
| cdb1c38f |
5343 | end if; |
| 5344 | end; |
| af647dc7 |
5345 | |
| 5346 | Next_Elmt (Sec_DT_Ancestor); |
| 5347 | Next_Elmt (Sec_DT_Typ); |
| acf97c11 |
5348 | |
| 5349 | -- Skip the secondary dispatch table of |
| 5350 | -- predefined primitives |
| 5351 | |
| 5352 | Next_Elmt (Sec_DT_Ancestor); |
| 5353 | Next_Elmt (Sec_DT_Typ); |
| 5354 | |
| af647dc7 |
5355 | Next_Elmt (Iface); |
| 5356 | end if; |
| d62940bf |
5357 | |
| af647dc7 |
5358 | Next_Entity (E); |
| 5359 | end loop; |
| 5360 | end if; |
| 5361 | end Copy_Secondary_DTs; |
| d62940bf |
5362 | |
| af647dc7 |
5363 | begin |
| 725a69d2 |
5364 | if Present (Node (Sec_DT_Ancestor)) |
| 5365 | and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant |
| 5366 | then |
| af647dc7 |
5367 | -- Handle private types |
| 76a1c25b |
5368 | |
| af647dc7 |
5369 | if Present (Full_View (Typ)) then |
| 5370 | Copy_Secondary_DTs (Full_View (Typ)); |
| 5371 | else |
| 5372 | Copy_Secondary_DTs (Typ); |
| 5373 | end if; |
| 76a1c25b |
5374 | end if; |
| af647dc7 |
5375 | end; |
| 5376 | end if; |
| 76a1c25b |
5377 | end if; |
| 343d35dc |
5378 | end if; |
| d62940bf |
5379 | |
| 343d35dc |
5380 | -- Generate code to register the Tag in the External_Tag hash table for |
| 5381 | -- the pure Ada type only. |
| d62940bf |
5382 | |
| 343d35dc |
5383 | -- Register_Tag (Dt_Ptr); |
| d62940bf |
5384 | |
| 725a69d2 |
5385 | -- Skip this action in the following cases: |
| 5386 | -- 1) if Register_Tag is not available. |
| 5387 | -- 2) in No_Run_Time mode. |
| 5388 | -- 3) if Typ is an abstract interface type (the secondary tags will |
| 5389 | -- be registered later in types implementing this interface type). |
| 5390 | -- 4) if Typ is not defined at the library level (this is required |
| 5391 | -- to avoid adding concurrency control to the hash table used |
| 5392 | -- by the run-time to register the tags). |
| d62940bf |
5393 | |
| 76a1c25b |
5394 | -- Generate: |
| 5395 | -- if No_Reg then |
| 725a69d2 |
5396 | -- [ Elab_Code ] |
| 5397 | -- [ Register_Tag (Dt_Ptr); ] |
| 76a1c25b |
5398 | -- No_Reg := False; |
| 5399 | -- end if; |
| 5400 | |
| cdb1c38f |
5401 | if not No_Run_Time_Mode |
| 5402 | and then Is_Library_Level_Entity (Typ) |
| 5403 | and then RTE_Available (RE_Register_Tag) |
| 5404 | then |
| 725a69d2 |
5405 | Append_To (Elab_Code, |
| cdb1c38f |
5406 | Make_Procedure_Call_Statement (Loc, |
| 5407 | Name => New_Reference_To (RTE (RE_Register_Tag), Loc), |
| 5408 | Parameter_Associations => |
| 5409 | New_List (New_Reference_To (DT_Ptr, Loc)))); |
| d62940bf |
5410 | end if; |
| 5411 | |
| cdb1c38f |
5412 | Append_To (Elab_Code, |
| 5413 | Make_Assignment_Statement (Loc, |
| 5414 | Name => New_Reference_To (No_Reg, Loc), |
| 5415 | Expression => New_Reference_To (Standard_False, Loc))); |
| 5416 | |
| 5417 | Append_To (Result, |
| 5418 | Make_Implicit_If_Statement (Typ, |
| 5419 | Condition => New_Reference_To (No_Reg, Loc), |
| 5420 | Then_Statements => Elab_Code)); |
| 5421 | |
| 17e14451 |
5422 | -- Populate the two auxiliary tables used for dispatching |
| 5423 | -- asynchronous, conditional and timed selects for synchronized |
| 5424 | -- types that implement a limited interface. |
| 5425 | |
| 5426 | if Ada_Version >= Ada_05 |
| 5427 | and then Is_Concurrent_Record_Type (Typ) |
| 5428 | and then Has_Abstract_Interfaces (Typ) |
| 5429 | then |
| 5430 | Append_List_To (Result, |
| 5431 | Make_Select_Specific_Data_Table (Typ)); |
| 5432 | end if; |
| 5433 | |
| cc60bd16 |
5434 | -- Remember entities containing dispatch tables |
| acf97c11 |
5435 | |
| cc60bd16 |
5436 | Append_Elmt (Predef_Prims, DT_Decl); |
| 5437 | Append_Elmt (DT, DT_Decl); |
| acf97c11 |
5438 | |
| 725a69d2 |
5439 | Analyze_List (Result, Suppress => All_Checks); |
| 17e14451 |
5440 | Set_Has_Dispatch_Table (Typ); |
| 5441 | |
| cc60bd16 |
5442 | -- Mark entities containing dispatch tables. Required by the |
| 5443 | -- backend to handle them properly. |
| 5444 | |
| 5445 | if not Is_Interface (Typ) then |
| 5446 | declare |
| 5447 | Elmt : Elmt_Id; |
| 5448 | |
| 5449 | begin |
| 5450 | -- Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have |
| 5451 | -- the decoration required by the backend |
| 5452 | |
| 5453 | Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr)); |
| 5454 | Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr)); |
| 5455 | |
| 5456 | -- Object declarations |
| 5457 | |
| 5458 | Elmt := First_Elmt (DT_Decl); |
| 5459 | while Present (Elmt) loop |
| 5460 | Set_Is_Dispatch_Table_Entity (Node (Elmt)); |
| 5461 | pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype |
| 5462 | or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype); |
| 5463 | Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt))); |
| 5464 | Next_Elmt (Elmt); |
| 5465 | end loop; |
| 5466 | |
| 5467 | -- Aggregates initializing dispatch tables |
| 5468 | |
| 5469 | Elmt := First_Elmt (DT_Aggr); |
| 5470 | while Present (Elmt) loop |
| 5471 | Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt))); |
| 5472 | Next_Elmt (Elmt); |
| 5473 | end loop; |
| 5474 | end; |
| 5475 | end if; |
| 5476 | |
| 76a1c25b |
5477 | return Result; |
| 5478 | end Make_DT; |
| d62940bf |
5479 | |
| 76a1c25b |
5480 | ------------------------------------- |
| 5481 | -- Make_Select_Specific_Data_Table -- |
| 5482 | ------------------------------------- |
| d62940bf |
5483 | |
| 76a1c25b |
5484 | function Make_Select_Specific_Data_Table |
| 5485 | (Typ : Entity_Id) return List_Id |
| 5486 | is |
| 5487 | Assignments : constant List_Id := New_List; |
| 5488 | Loc : constant Source_Ptr := Sloc (Typ); |
| d62940bf |
5489 | |
| 68f95949 |
5490 | Conc_Typ : Entity_Id; |
| 5491 | Decls : List_Id; |
| 5492 | DT_Ptr : Entity_Id; |
| 5493 | Prim : Entity_Id; |
| 5494 | Prim_Als : Entity_Id; |
| 5495 | Prim_Elmt : Elmt_Id; |
| 5496 | Prim_Pos : Uint; |
| 343d35dc |
5497 | Nb_Prim : Nat := 0; |
| d62940bf |
5498 | |
| 76a1c25b |
5499 | type Examined_Array is array (Int range <>) of Boolean; |
| d62940bf |
5500 | |
| 76a1c25b |
5501 | function Find_Entry_Index (E : Entity_Id) return Uint; |
| 5502 | -- Given an entry, find its index in the visible declarations of the |
| 5503 | -- corresponding concurrent type of Typ. |
| d62940bf |
5504 | |
| 76a1c25b |
5505 | ---------------------- |
| 5506 | -- Find_Entry_Index -- |
| 5507 | ---------------------- |
| d62940bf |
5508 | |
| 76a1c25b |
5509 | function Find_Entry_Index (E : Entity_Id) return Uint is |
| 5510 | Index : Uint := Uint_1; |
| 5511 | Subp_Decl : Entity_Id; |
| d62940bf |
5512 | |
| 76a1c25b |
5513 | begin |
| 5514 | if Present (Decls) |
| 5515 | and then not Is_Empty_List (Decls) |
| 5516 | then |
| 5517 | Subp_Decl := First (Decls); |
| 5518 | while Present (Subp_Decl) loop |
| 5519 | if Nkind (Subp_Decl) = N_Entry_Declaration then |
| 5520 | if Defining_Identifier (Subp_Decl) = E then |
| 5521 | return Index; |
| 5522 | end if; |
| d62940bf |
5523 | |
| 76a1c25b |
5524 | Index := Index + 1; |
| 5525 | end if; |
| d62940bf |
5526 | |
| 76a1c25b |
5527 | Next (Subp_Decl); |
| 5528 | end loop; |
| 5529 | end if; |
| d62940bf |
5530 | |
| 76a1c25b |
5531 | return Uint_0; |
| 5532 | end Find_Entry_Index; |
| 5533 | |
| 5534 | -- Start of processing for Make_Select_Specific_Data_Table |
| 5535 | |
| 5536 | begin |
| 68f95949 |
5537 | pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| 5538 | |
| 76a1c25b |
5539 | DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); |
| d62940bf |
5540 | |
| 76a1c25b |
5541 | if Present (Corresponding_Concurrent_Type (Typ)) then |
| 5542 | Conc_Typ := Corresponding_Concurrent_Type (Typ); |
| 5543 | |
| 17e14451 |
5544 | if Present (Full_View (Conc_Typ)) then |
| 5545 | Conc_Typ := Full_View (Conc_Typ); |
| 5546 | end if; |
| 5547 | |
| 76a1c25b |
5548 | if Ekind (Conc_Typ) = E_Protected_Type then |
| 5549 | Decls := Visible_Declarations (Protected_Definition ( |
| 5550 | Parent (Conc_Typ))); |
| d62940bf |
5551 | else |
| 5552 | pragma Assert (Ekind (Conc_Typ) = E_Task_Type); |
| 76a1c25b |
5553 | Decls := Visible_Declarations (Task_Definition ( |
| 5554 | Parent (Conc_Typ))); |
| 5555 | end if; |
| 5556 | end if; |
| d62940bf |
5557 | |
| 76a1c25b |
5558 | -- Count the non-predefined primitive operations |
| d62940bf |
5559 | |
| 76a1c25b |
5560 | Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| 5561 | while Present (Prim_Elmt) loop |
| af647dc7 |
5562 | Prim := Node (Prim_Elmt); |
| 5563 | |
| 5564 | if not (Is_Predefined_Dispatching_Operation (Prim) |
| 5565 | or else Is_Predefined_Dispatching_Alias (Prim)) |
| 5566 | then |
| 76a1c25b |
5567 | Nb_Prim := Nb_Prim + 1; |
| 5568 | end if; |
| d62940bf |
5569 | |
| 76a1c25b |
5570 | Next_Elmt (Prim_Elmt); |
| 5571 | end loop; |
| d62940bf |
5572 | |
| 76a1c25b |
5573 | declare |
| 68f95949 |
5574 | Examined : Examined_Array (1 .. Nb_Prim) := (others => False); |
| d62940bf |
5575 | |
| 76a1c25b |
5576 | begin |
| 5577 | Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| 5578 | while Present (Prim_Elmt) loop |
| 5579 | Prim := Node (Prim_Elmt); |
| d62940bf |
5580 | |
| af647dc7 |
5581 | -- Look for primitive overriding an abstract interface subprogram |
| d62940bf |
5582 | |
| af647dc7 |
5583 | if Present (Abstract_Interface_Alias (Prim)) |
| 5584 | and then not Examined (UI_To_Int (DT_Position (Alias (Prim)))) |
| 5585 | then |
| 5586 | Prim_Pos := DT_Position (Alias (Prim)); |
| 5587 | pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim); |
| 5588 | Examined (UI_To_Int (Prim_Pos)) := True; |
| d62940bf |
5589 | |
| af647dc7 |
5590 | -- Set the primitive operation kind regardless of subprogram |
| 5591 | -- type. Generate: |
| 5592 | -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>); |
| d62940bf |
5593 | |
| af647dc7 |
5594 | Append_To (Assignments, |
| 725a69d2 |
5595 | Make_Procedure_Call_Statement (Loc, |
| 5596 | Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc), |
| 5597 | Parameter_Associations => New_List ( |
| 5598 | New_Reference_To (DT_Ptr, Loc), |
| 5599 | Make_Integer_Literal (Loc, Prim_Pos), |
| 5600 | Prim_Op_Kind (Alias (Prim), Typ)))); |
| 68f95949 |
5601 | |
| af647dc7 |
5602 | -- Retrieve the root of the alias chain |
| 68f95949 |
5603 | |
| af647dc7 |
5604 | Prim_Als := Prim; |
| 5605 | while Present (Alias (Prim_Als)) loop |
| 5606 | Prim_Als := Alias (Prim_Als); |
| 5607 | end loop; |
| 68f95949 |
5608 | |
| af647dc7 |
5609 | -- In the case of an entry wrapper, set the entry index |
| 68f95949 |
5610 | |
| af647dc7 |
5611 | if Ekind (Prim) = E_Procedure |
| 5612 | and then Is_Primitive_Wrapper (Prim_Als) |
| 5613 | and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry |
| 5614 | then |
| 5615 | -- Generate: |
| 5616 | -- Ada.Tags.Set_Entry_Index |
| 5617 | -- (DT_Ptr, <position>, <index>); |
| 68f95949 |
5618 | |
| af647dc7 |
5619 | Append_To (Assignments, |
| 725a69d2 |
5620 | Make_Procedure_Call_Statement (Loc, |
| 5621 | Name => |
| 5622 | New_Reference_To (RTE (RE_Set_Entry_Index), Loc), |
| 5623 | Parameter_Associations => New_List ( |
| 5624 | New_Reference_To (DT_Ptr, Loc), |
| 5625 | Make_Integer_Literal (Loc, Prim_Pos), |
| 5626 | Make_Integer_Literal (Loc, |
| 5627 | Find_Entry_Index (Wrapped_Entity (Prim_Als)))))); |
| 76a1c25b |
5628 | end if; |
| 5629 | end if; |
| 5630 | |
| 76a1c25b |
5631 | Next_Elmt (Prim_Elmt); |
| 5632 | end loop; |
| 5633 | end; |
| 5634 | |
| 5635 | return Assignments; |
| 5636 | end Make_Select_Specific_Data_Table; |
| d62940bf |
5637 | |
| 17e14451 |
5638 | --------------- |
| 5639 | -- Make_Tags -- |
| 5640 | --------------- |
| 5641 | |
| 5642 | function Make_Tags (Typ : Entity_Id) return List_Id is |
| acf97c11 |
5643 | Loc : constant Source_Ptr := Sloc (Typ); |
| 5644 | Tname : constant Name_Id := Chars (Typ); |
| 5645 | Result : constant List_Id := New_List; |
| 5646 | AI_Tag_Comp : Elmt_Id; |
| 5647 | DT : Node_Id; |
| 5648 | DT_Constr_List : List_Id; |
| 5649 | DT_Ptr : Node_Id; |
| 5650 | Predef_Prims_Ptr : Node_Id; |
| 5651 | Iface_DT_Ptr : Node_Id; |
| 5652 | Nb_Prim : Nat; |
| 5653 | Suffix_Index : Int; |
| 5654 | Typ_Name : Name_Id; |
| 5655 | Typ_Comps : Elist_Id; |
| 17e14451 |
5656 | |
| 5657 | begin |
| 5658 | -- 1) Generate the primary and secondary tag entities |
| 5659 | |
| 5660 | -- Collect the components associated with secondary dispatch tables |
| 5661 | |
| 5662 | if Has_Abstract_Interfaces (Typ) then |
| 5663 | Collect_Interface_Components (Typ, Typ_Comps); |
| 5664 | end if; |
| 5665 | |
| acf97c11 |
5666 | -- 1) Generate the primary tag entities |
| 5667 | |
| 5668 | -- Primary dispatch table containing user-defined primitives |
| 17e14451 |
5669 | |
| 5670 | DT_Ptr := Make_Defining_Identifier (Loc, |
| 5671 | New_External_Name (Tname, 'P')); |
| 5672 | Set_Etype (DT_Ptr, RTE (RE_Tag)); |
| 17e14451 |
5673 | |
| acf97c11 |
5674 | -- Primary dispatch table containing predefined primitives |
| 5675 | |
| 5676 | Predef_Prims_Ptr := |
| 5677 | Make_Defining_Identifier (Loc, |
| 5678 | Chars => New_External_Name (Tname, 'Y')); |
| 5679 | Set_Etype (Predef_Prims_Ptr, RTE (RE_Address)); |
| 5680 | |
| 24971415 |
5681 | -- Import the forward declaration of the Dispatch Table wrapper record |
| 5682 | -- (Make_DT will take care of its exportation) |
| 7854e190 |
5683 | |
| e7e688dd |
5684 | if Building_Static_DT (Typ) then |
| acf97c11 |
5685 | DT := |
| 5686 | Make_Defining_Identifier (Loc, |
| 5687 | Chars => New_External_Name (Tname, 'T')); |
| 24971415 |
5688 | |
| 5689 | -- Generate: |
| 5690 | -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim); |
| 5691 | -- $pragma import (ada, DT); |
| 5692 | |
| 5693 | Set_Is_Imported (DT); |
| 5694 | |
| 24971415 |
5695 | -- The scope must be set now to call Get_External_Name |
| 5696 | |
| 5697 | Set_Scope (DT, Current_Scope); |
| 5698 | |
| 5699 | Get_External_Name (DT, True); |
| 5700 | Set_Interface_Name (DT, |
| 17e14451 |
5701 | Make_String_Literal (Loc, |
| 5702 | Strval => String_From_Name_Buffer)); |
| 5703 | |
| 24971415 |
5704 | -- Ensure proper Sprint output of this implicit importation |
| 17e14451 |
5705 | |
| 24971415 |
5706 | Set_Is_Internal (DT); |
| 17e14451 |
5707 | |
| 24971415 |
5708 | -- Save this entity to allow Make_DT to generate its exportation |
| 5709 | |
| 5710 | Set_Dispatch_Table_Wrapper (Typ, DT); |
| 5711 | |
| 5712 | if Has_DT (Typ) then |
| acf97c11 |
5713 | |
| 24971415 |
5714 | -- Calculate the number of primitives of the dispatch table and |
| 5715 | -- the size of the Type_Specific_Data record. |
| 5716 | |
| 5717 | Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); |
| 5718 | |
| 5719 | -- If the tagged type has no primitives we add a dummy slot |
| 5720 | -- whose address will be the tag of this type. |
| 5721 | |
| 5722 | if Nb_Prim = 0 then |
| 5723 | DT_Constr_List := |
| 5724 | New_List (Make_Integer_Literal (Loc, 1)); |
| 5725 | else |
| 5726 | DT_Constr_List := |
| 5727 | New_List (Make_Integer_Literal (Loc, Nb_Prim)); |
| 5728 | end if; |
| 5729 | |
| 5730 | Append_To (Result, |
| 5731 | Make_Object_Declaration (Loc, |
| 5732 | Defining_Identifier => DT, |
| 5733 | Aliased_Present => True, |
| 5734 | Constant_Present => True, |
| 5735 | Object_Definition => |
| 5736 | Make_Subtype_Indication (Loc, |
| 5737 | Subtype_Mark => |
| 5738 | New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc), |
| 5739 | Constraint => Make_Index_Or_Discriminant_Constraint (Loc, |
| 5740 | Constraints => DT_Constr_List)))); |
| 5741 | |
| 5742 | Append_To (Result, |
| 5743 | Make_Object_Declaration (Loc, |
| 5744 | Defining_Identifier => DT_Ptr, |
| 5745 | Constant_Present => True, |
| 5746 | Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), |
| 5747 | Expression => |
| 5748 | Unchecked_Convert_To (RTE (RE_Tag), |
| 5749 | Make_Attribute_Reference (Loc, |
| 5750 | Prefix => |
| 5751 | Make_Selected_Component (Loc, |
| 5752 | Prefix => New_Reference_To (DT, Loc), |
| 5753 | Selector_Name => |
| 5754 | New_Occurrence_Of |
| 5755 | (RTE_Record_Component (RE_Prims_Ptr), Loc)), |
| 5756 | Attribute_Name => Name_Address)))); |
| 5757 | |
| acf97c11 |
5758 | Append_To (Result, |
| 5759 | Make_Object_Declaration (Loc, |
| 5760 | Defining_Identifier => Predef_Prims_Ptr, |
| 5761 | Constant_Present => True, |
| 5762 | Object_Definition => New_Reference_To |
| 5763 | (RTE (RE_Address), Loc), |
| 5764 | Expression => |
| 5765 | Make_Attribute_Reference (Loc, |
| 5766 | Prefix => |
| 5767 | Make_Selected_Component (Loc, |
| 5768 | Prefix => New_Reference_To (DT, Loc), |
| 5769 | Selector_Name => |
| 5770 | New_Occurrence_Of |
| 5771 | (RTE_Record_Component (RE_Predef_Prims), Loc)), |
| 5772 | Attribute_Name => Name_Address))); |
| 5773 | |
| 24971415 |
5774 | -- No dispatch table required |
| 5775 | |
| 5776 | else |
| 5777 | Append_To (Result, |
| 5778 | Make_Object_Declaration (Loc, |
| 5779 | Defining_Identifier => DT, |
| 5780 | Aliased_Present => True, |
| 5781 | Constant_Present => True, |
| 5782 | Object_Definition => |
| 5783 | New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); |
| 5784 | |
| 5785 | Append_To (Result, |
| 5786 | Make_Object_Declaration (Loc, |
| 5787 | Defining_Identifier => DT_Ptr, |
| 5788 | Constant_Present => True, |
| 5789 | Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), |
| 5790 | Expression => |
| 5791 | Unchecked_Convert_To (RTE (RE_Tag), |
| 5792 | Make_Attribute_Reference (Loc, |
| 5793 | Prefix => |
| 5794 | Make_Selected_Component (Loc, |
| 5795 | Prefix => New_Reference_To (DT, Loc), |
| 5796 | Selector_Name => |
| 5797 | New_Occurrence_Of |
| 5798 | (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), |
| 5799 | Attribute_Name => Name_Address)))); |
| 5800 | end if; |
| 5801 | |
| 5802 | Set_Is_True_Constant (DT_Ptr); |
| e7e688dd |
5803 | Set_Is_Statically_Allocated (DT_Ptr); |
| 17e14451 |
5804 | end if; |
| 5805 | |
| 5806 | pragma Assert (No (Access_Disp_Table (Typ))); |
| 5807 | Set_Access_Disp_Table (Typ, New_Elmt_List); |
| 5808 | Append_Elmt (DT_Ptr, Access_Disp_Table (Typ)); |
| acf97c11 |
5809 | Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ)); |
| 17e14451 |
5810 | |
| 5811 | -- 2) Generate the secondary tag entities |
| 5812 | |
| 5813 | if Has_Abstract_Interfaces (Typ) then |
| 5814 | Suffix_Index := 0; |
| 5815 | |
| 5816 | -- For each interface type we build an unique external name |
| 5817 | -- associated with its corresponding secondary dispatch table. |
| 5818 | -- This external name will be used to declare an object that |
| 5819 | -- references this secondary dispatch table, value that will be |
| 5820 | -- used for the elaboration of Typ's objects and also for the |
| 5821 | -- elaboration of objects of derivations of Typ that do not |
| 5822 | -- override the primitive operation of this interface type. |
| 5823 | |
| 5824 | AI_Tag_Comp := First_Elmt (Typ_Comps); |
| 5825 | while Present (AI_Tag_Comp) loop |
| 5826 | Get_Secondary_DT_External_Name |
| cdb1c38f |
5827 | (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index); |
| 5828 | |
| 5829 | Typ_Name := Name_Find; |
| 17e14451 |
5830 | |
| acf97c11 |
5831 | -- Secondary dispatch table referencing thunks to user-defined |
| 5832 | -- primitives covered by this interface. |
| 5833 | |
| 17e14451 |
5834 | Iface_DT_Ptr := |
| 5835 | Make_Defining_Identifier (Loc, |
| 5836 | Chars => New_External_Name (Typ_Name, 'P')); |
| 5837 | Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); |
| 5838 | Set_Ekind (Iface_DT_Ptr, E_Constant); |
| cdb1c38f |
5839 | Set_Is_Tag (Iface_DT_Ptr); |
| 5840 | Set_Has_Thunks (Iface_DT_Ptr); |
| 17e14451 |
5841 | Set_Is_Statically_Allocated (Iface_DT_Ptr); |
| 5842 | Set_Is_True_Constant (Iface_DT_Ptr); |
| cdb1c38f |
5843 | Set_Related_Type |
| 5844 | (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); |
| 5845 | Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); |
| 5846 | |
| acf97c11 |
5847 | -- Secondary dispatch table referencing thunks to predefined |
| 5848 | -- primitives. |
| 5849 | |
| 5850 | Iface_DT_Ptr := |
| 5851 | Make_Defining_Identifier (Loc, |
| 5852 | Chars => New_External_Name (Typ_Name, 'Y')); |
| 5853 | Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); |
| 5854 | Set_Ekind (Iface_DT_Ptr, E_Constant); |
| 5855 | Set_Is_Tag (Iface_DT_Ptr); |
| 5856 | Set_Has_Thunks (Iface_DT_Ptr); |
| 5857 | Set_Is_Statically_Allocated (Iface_DT_Ptr); |
| 5858 | Set_Is_True_Constant (Iface_DT_Ptr); |
| 5859 | Set_Related_Type |
| 5860 | (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); |
| 5861 | Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); |
| 5862 | |
| 5863 | -- Secondary dispatch table referencing user-defined primitives |
| 5864 | -- covered by this interface. |
| 5865 | |
| cdb1c38f |
5866 | Iface_DT_Ptr := |
| 5867 | Make_Defining_Identifier (Loc, |
| 5868 | Chars => New_External_Name (Typ_Name, 'D')); |
| 5869 | Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); |
| 5870 | Set_Ekind (Iface_DT_Ptr, E_Constant); |
| 5871 | Set_Is_Tag (Iface_DT_Ptr); |
| 5872 | Set_Is_Statically_Allocated (Iface_DT_Ptr); |
| 5873 | Set_Is_True_Constant (Iface_DT_Ptr); |
| 5874 | Set_Related_Type |
| 5875 | (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); |
| 17e14451 |
5876 | Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); |
| 5877 | |
| acf97c11 |
5878 | -- Secondary dispatch table referencing predefined primitives |
| 5879 | |
| 5880 | Iface_DT_Ptr := |
| 5881 | Make_Defining_Identifier (Loc, |
| 5882 | Chars => New_External_Name (Typ_Name, 'Z')); |
| 5883 | Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); |
| 5884 | Set_Ekind (Iface_DT_Ptr, E_Constant); |
| 5885 | Set_Is_Tag (Iface_DT_Ptr); |
| 5886 | Set_Is_Statically_Allocated (Iface_DT_Ptr); |
| 5887 | Set_Is_True_Constant (Iface_DT_Ptr); |
| 5888 | Set_Related_Type |
| 5889 | (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); |
| 5890 | Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); |
| 5891 | |
| 17e14451 |
5892 | Next_Elmt (AI_Tag_Comp); |
| 5893 | end loop; |
| 5894 | end if; |
| 5895 | |
| 5896 | -- 3) At the end of Access_Disp_Table we add the entity of an access |
| 5897 | -- type declaration. It is used by Build_Get_Prim_Op_Address to |
| 5898 | -- expand dispatching calls through the primary dispatch table. |
| 5899 | |
| 5900 | -- Generate: |
| cc60bd16 |
5901 | -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr; |
| 17e14451 |
5902 | -- type Typ_DT_Acc is access Typ_DT; |
| 5903 | |
| 5904 | declare |
| 5905 | Name_DT_Prims : constant Name_Id := |
| 5906 | New_External_Name (Tname, 'G'); |
| 5907 | Name_DT_Prims_Acc : constant Name_Id := |
| 5908 | New_External_Name (Tname, 'H'); |
| 5909 | DT_Prims : constant Entity_Id := |
| 5910 | Make_Defining_Identifier (Loc, Name_DT_Prims); |
| 5911 | DT_Prims_Acc : constant Entity_Id := |
| 5912 | Make_Defining_Identifier (Loc, |
| 5913 | Name_DT_Prims_Acc); |
| 5914 | begin |
| 5915 | Append_To (Result, |
| 5916 | Make_Full_Type_Declaration (Loc, |
| 5917 | Defining_Identifier => DT_Prims, |
| 5918 | Type_Definition => |
| 5919 | Make_Constrained_Array_Definition (Loc, |
| 5920 | Discrete_Subtype_Definitions => New_List ( |
| 5921 | Make_Range (Loc, |
| 5922 | Low_Bound => Make_Integer_Literal (Loc, 1), |
| 5923 | High_Bound => Make_Integer_Literal (Loc, |
| 5924 | DT_Entry_Count |
| 5925 | (First_Tag_Component (Typ))))), |
| 5926 | Component_Definition => |
| 5927 | Make_Component_Definition (Loc, |
| 5928 | Subtype_Indication => |
| cc60bd16 |
5929 | New_Reference_To (RTE (RE_Prim_Ptr), Loc))))); |
| 17e14451 |
5930 | |
| 5931 | Append_To (Result, |
| 5932 | Make_Full_Type_Declaration (Loc, |
| 5933 | Defining_Identifier => DT_Prims_Acc, |
| 5934 | Type_Definition => |
| 5935 | Make_Access_To_Object_Definition (Loc, |
| 5936 | Subtype_Indication => |
| 5937 | New_Occurrence_Of (DT_Prims, Loc)))); |
| 5938 | |
| 5939 | Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ)); |
| 5940 | |
| 5941 | -- Analyze the resulting list and suppress the generation of the |
| 5942 | -- Init_Proc associated with the above array declaration because |
| 5943 | -- we never use such type in object declarations; this type is only |
| 5944 | -- used to simplify the expansion associated with dispatching calls. |
| 5945 | |
| 5946 | Analyze_List (Result); |
| 5947 | Set_Suppress_Init_Proc (Base_Type (DT_Prims)); |
| cc60bd16 |
5948 | |
| 5949 | -- Mark entity of dispatch table. Required by the backend to handle |
| 5950 | -- the properly. |
| 5951 | |
| 5952 | Set_Is_Dispatch_Table_Entity (DT_Prims); |
| 17e14451 |
5953 | end; |
| 5954 | |
| cdb1c38f |
5955 | Set_Ekind (DT_Ptr, E_Constant); |
| 5956 | Set_Is_Tag (DT_Ptr); |
| 5957 | Set_Related_Type (DT_Ptr, Typ); |
| 5958 | |
| 17e14451 |
5959 | return Result; |
| 5960 | end Make_Tags; |
| 5961 | |
| ee6ba406 |
5962 | ----------------------------------- |
| 5963 | -- Original_View_In_Visible_Part -- |
| 5964 | ----------------------------------- |
| 5965 | |
| 5966 | function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is |
| 5967 | Scop : constant Entity_Id := Scope (Typ); |
| 5968 | |
| 5969 | begin |
| 5970 | -- The scope must be a package |
| 5971 | |
| 5972 | if Ekind (Scop) /= E_Package |
| 5973 | and then Ekind (Scop) /= E_Generic_Package |
| 5974 | then |
| 5975 | return False; |
| 5976 | end if; |
| 5977 | |
| 5978 | -- A type with a private declaration has a private view declared in |
| 5979 | -- the visible part. |
| 5980 | |
| 5981 | if Has_Private_Declaration (Typ) then |
| 5982 | return True; |
| 5983 | end if; |
| 5984 | |
| 5985 | return List_Containing (Parent (Typ)) = |
| 5986 | Visible_Declarations (Specification (Unit_Declaration_Node (Scop))); |
| 5987 | end Original_View_In_Visible_Part; |
| 5988 | |
| d62940bf |
5989 | ------------------ |
| 5990 | -- Prim_Op_Kind -- |
| 5991 | ------------------ |
| 5992 | |
| 5993 | function Prim_Op_Kind |
| 5994 | (Prim : Entity_Id; |
| 5995 | Typ : Entity_Id) return Node_Id |
| 5996 | is |
| 5997 | Full_Typ : Entity_Id := Typ; |
| 5998 | Loc : constant Source_Ptr := Sloc (Prim); |
| 68f95949 |
5999 | Prim_Op : Entity_Id; |
| d62940bf |
6000 | |
| 6001 | begin |
| 6002 | -- Retrieve the original primitive operation |
| 6003 | |
| 68f95949 |
6004 | Prim_Op := Prim; |
| d62940bf |
6005 | while Present (Alias (Prim_Op)) loop |
| 6006 | Prim_Op := Alias (Prim_Op); |
| 6007 | end loop; |
| 6008 | |
| 6009 | if Ekind (Typ) = E_Record_Type |
| 6010 | and then Present (Corresponding_Concurrent_Type (Typ)) |
| 6011 | then |
| 6012 | Full_Typ := Corresponding_Concurrent_Type (Typ); |
| 6013 | end if; |
| 6014 | |
| 6015 | if Ekind (Prim_Op) = E_Function then |
| 6016 | |
| 6017 | -- Protected function |
| 6018 | |
| 6019 | if Ekind (Full_Typ) = E_Protected_Type then |
| 6020 | return New_Reference_To (RTE (RE_POK_Protected_Function), Loc); |
| 6021 | |
| 76a1c25b |
6022 | -- Task function |
| 6023 | |
| 6024 | elsif Ekind (Full_Typ) = E_Task_Type then |
| 6025 | return New_Reference_To (RTE (RE_POK_Task_Function), Loc); |
| 6026 | |
| d62940bf |
6027 | -- Regular function |
| 6028 | |
| 6029 | else |
| 6030 | return New_Reference_To (RTE (RE_POK_Function), Loc); |
| 6031 | end if; |
| 6032 | |
| 6033 | else |
| 6034 | pragma Assert (Ekind (Prim_Op) = E_Procedure); |
| 6035 | |
| 6036 | if Ekind (Full_Typ) = E_Protected_Type then |
| 6037 | |
| 6038 | -- Protected entry |
| 6039 | |
| 6040 | if Is_Primitive_Wrapper (Prim_Op) |
| 6041 | and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry |
| 6042 | then |
| 6043 | return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc); |
| 6044 | |
| 6045 | -- Protected procedure |
| 6046 | |
| 6047 | else |
| 6048 | return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc); |
| 6049 | end if; |
| 6050 | |
| 6051 | elsif Ekind (Full_Typ) = E_Task_Type then |
| 6052 | |
| 6053 | -- Task entry |
| 6054 | |
| 6055 | if Is_Primitive_Wrapper (Prim_Op) |
| 6056 | and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry |
| 6057 | then |
| 6058 | return New_Reference_To (RTE (RE_POK_Task_Entry), Loc); |
| 6059 | |
| 6060 | -- Task "procedure". These are the internally Expander-generated |
| 6061 | -- procedures (task body for instance). |
| 6062 | |
| 6063 | else |
| 6064 | return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc); |
| 6065 | end if; |
| 6066 | |
| 6067 | -- Regular procedure |
| 6068 | |
| 6069 | else |
| 6070 | return New_Reference_To (RTE (RE_POK_Procedure), Loc); |
| 6071 | end if; |
| 6072 | end if; |
| 6073 | end Prim_Op_Kind; |
| 6074 | |
| 725a69d2 |
6075 | ------------------------ |
| 6076 | -- Register_Primitive -- |
| 6077 | ------------------------ |
| 6078 | |
| 6079 | procedure Register_Primitive |
| 6080 | (Loc : Source_Ptr; |
| 6081 | Prim : Entity_Id; |
| 6082 | Ins_Nod : Node_Id) |
| 6083 | is |
| cdb1c38f |
6084 | DT_Ptr : Entity_Id; |
| 6085 | Iface_Prim : Entity_Id; |
| 6086 | Iface_Typ : Entity_Id; |
| 6087 | Iface_DT_Ptr : Entity_Id; |
| 6088 | Iface_DT_Elmt : Elmt_Id; |
| 6089 | L : List_Id; |
| 6090 | Pos : Uint; |
| 6091 | Tag : Entity_Id; |
| cc60bd16 |
6092 | Tag_Typ : Entity_Id; |
| cdb1c38f |
6093 | Thunk_Id : Entity_Id; |
| 6094 | Thunk_Code : Node_Id; |
| 725a69d2 |
6095 | |
| 6096 | begin |
| 6097 | pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| 6098 | |
| 6099 | if not RTE_Available (RE_Tag) then |
| 6100 | return; |
| 6101 | end if; |
| 6102 | |
| 6103 | if not Present (Abstract_Interface_Alias (Prim)) then |
| cc60bd16 |
6104 | Tag_Typ := Scope (DTC_Entity (Prim)); |
| acf97c11 |
6105 | Pos := DT_Position (Prim); |
| cc60bd16 |
6106 | Tag := First_Tag_Component (Tag_Typ); |
| 725a69d2 |
6107 | |
| 6108 | if Is_Predefined_Dispatching_Operation (Prim) |
| 6109 | or else Is_Predefined_Dispatching_Alias (Prim) |
| 6110 | then |
| cc60bd16 |
6111 | DT_Ptr := |
| 6112 | Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ)))); |
| 6113 | |
| 725a69d2 |
6114 | Insert_After (Ins_Nod, |
| 6115 | Build_Set_Predefined_Prim_Op_Address (Loc, |
| 6116 | Tag_Node => New_Reference_To (DT_Ptr, Loc), |
| 6117 | Position => Pos, |
| acf97c11 |
6118 | Address_Node => |
| cc60bd16 |
6119 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
| acf97c11 |
6120 | Make_Attribute_Reference (Loc, |
| 6121 | Prefix => New_Reference_To (Prim, Loc), |
| 6122 | Attribute_Name => Name_Unrestricted_Access)))); |
| 725a69d2 |
6123 | |
| cc60bd16 |
6124 | -- Register copy of the pointer to the 'size primitive in the TSD. |
| 6125 | |
| 6126 | if Chars (Prim) = Name_uSize |
| 6127 | and then RTE_Record_Component_Available (RE_Size_Func) |
| 6128 | then |
| 6129 | DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); |
| 6130 | Insert_After (Ins_Nod, |
| 6131 | Build_Set_Size_Function (Loc, |
| 6132 | Tag_Node => New_Reference_To (DT_Ptr, Loc), |
| 6133 | Size_Func => Prim)); |
| 6134 | end if; |
| 6135 | |
| 725a69d2 |
6136 | else |
| 6137 | pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); |
| 6138 | |
| cc60bd16 |
6139 | DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); |
| 725a69d2 |
6140 | Insert_After (Ins_Nod, |
| 6141 | Build_Set_Prim_Op_Address (Loc, |
| cc60bd16 |
6142 | Typ => Tag_Typ, |
| 725a69d2 |
6143 | Tag_Node => New_Reference_To (DT_Ptr, Loc), |
| 6144 | Position => Pos, |
| acf97c11 |
6145 | Address_Node => |
| cc60bd16 |
6146 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
| acf97c11 |
6147 | Make_Attribute_Reference (Loc, |
| 6148 | Prefix => New_Reference_To (Prim, Loc), |
| 6149 | Attribute_Name => Name_Unrestricted_Access)))); |
| 725a69d2 |
6150 | end if; |
| 6151 | |
| 6152 | -- Ada 2005 (AI-251): Primitive associated with an interface type |
| 6153 | -- Generate the code of the thunk only if the interface type is not an |
| 6154 | -- immediate ancestor of Typ; otherwise the dispatch table associated |
| 6155 | -- with the interface is the primary dispatch table and we have nothing |
| 6156 | -- else to do here. |
| 6157 | |
| 6158 | else |
| cc60bd16 |
6159 | Tag_Typ := Find_Dispatching_Type (Alias (Prim)); |
| 725a69d2 |
6160 | Iface_Typ := Find_Dispatching_Type (Abstract_Interface_Alias (Prim)); |
| 6161 | |
| 6162 | pragma Assert (Is_Interface (Iface_Typ)); |
| 6163 | |
| 17e14451 |
6164 | Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); |
| 725a69d2 |
6165 | |
| cc60bd16 |
6166 | if not Is_Parent (Iface_Typ, Tag_Typ) |
| 725a69d2 |
6167 | and then Present (Thunk_Code) |
| 6168 | then |
| 17e14451 |
6169 | -- Comment needed on why checks are suppressed. This is not just |
| 6170 | -- efficiency, but fundamental functionality (see 1.295 RH, which |
| 6171 | -- still does not answer this question) ??? |
| 6172 | |
| 725a69d2 |
6173 | Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks); |
| 6174 | |
| 6175 | -- Generate the code necessary to fill the appropriate entry of |
| 6176 | -- the secondary dispatch table of Prim's controlling type with |
| 6177 | -- Thunk_Id's address. |
| 6178 | |
| cc60bd16 |
6179 | Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ); |
| cdb1c38f |
6180 | Iface_DT_Ptr := Node (Iface_DT_Elmt); |
| 6181 | pragma Assert (Has_Thunks (Iface_DT_Ptr)); |
| 6182 | |
| acf97c11 |
6183 | Iface_Prim := Abstract_Interface_Alias (Prim); |
| 6184 | Pos := DT_Position (Iface_Prim); |
| 6185 | Tag := First_Tag_Component (Iface_Typ); |
| 6186 | L := New_List; |
| 725a69d2 |
6187 | |
| 6188 | if Is_Predefined_Dispatching_Operation (Prim) |
| 6189 | or else Is_Predefined_Dispatching_Alias (Prim) |
| 6190 | then |
| cdb1c38f |
6191 | Append_To (L, |
| 725a69d2 |
6192 | Build_Set_Predefined_Prim_Op_Address (Loc, |
| acf97c11 |
6193 | Tag_Node => |
| 6194 | New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc), |
| 725a69d2 |
6195 | Position => Pos, |
| 6196 | Address_Node => |
| cc60bd16 |
6197 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
| acf97c11 |
6198 | Make_Attribute_Reference (Loc, |
| 6199 | Prefix => New_Reference_To (Thunk_Id, Loc), |
| 6200 | Attribute_Name => Name_Unrestricted_Access)))); |
| cdb1c38f |
6201 | |
| acf97c11 |
6202 | Next_Elmt (Iface_DT_Elmt); |
| cdb1c38f |
6203 | Next_Elmt (Iface_DT_Elmt); |
| 6204 | Iface_DT_Ptr := Node (Iface_DT_Elmt); |
| 6205 | pragma Assert (not Has_Thunks (Iface_DT_Ptr)); |
| 6206 | |
| 6207 | Append_To (L, |
| 6208 | Build_Set_Predefined_Prim_Op_Address (Loc, |
| acf97c11 |
6209 | Tag_Node => |
| 6210 | New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc), |
| cdb1c38f |
6211 | Position => Pos, |
| 6212 | Address_Node => |
| cc60bd16 |
6213 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
| acf97c11 |
6214 | Make_Attribute_Reference (Loc, |
| 6215 | Prefix => New_Reference_To (Alias (Prim), Loc), |
| 6216 | Attribute_Name => Name_Unrestricted_Access)))); |
| cdb1c38f |
6217 | |
| 6218 | Insert_Actions_After (Ins_Nod, L); |
| 6219 | |
| 725a69d2 |
6220 | else |
| 6221 | pragma Assert (Pos /= Uint_0 |
| 6222 | and then Pos <= DT_Entry_Count (Tag)); |
| 6223 | |
| cdb1c38f |
6224 | Append_To (L, |
| 6225 | Build_Set_Prim_Op_Address (Loc, |
| 6226 | Typ => Iface_Typ, |
| 6227 | Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), |
| 6228 | Position => Pos, |
| acf97c11 |
6229 | Address_Node => |
| cc60bd16 |
6230 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
| acf97c11 |
6231 | Make_Attribute_Reference (Loc, |
| 6232 | Prefix => New_Reference_To (Thunk_Id, Loc), |
| 6233 | Attribute_Name => Name_Unrestricted_Access)))); |
| cdb1c38f |
6234 | |
| acf97c11 |
6235 | Next_Elmt (Iface_DT_Elmt); |
| cdb1c38f |
6236 | Next_Elmt (Iface_DT_Elmt); |
| 6237 | Iface_DT_Ptr := Node (Iface_DT_Elmt); |
| 6238 | pragma Assert (not Has_Thunks (Iface_DT_Ptr)); |
| 6239 | |
| 6240 | Append_To (L, |
| 725a69d2 |
6241 | Build_Set_Prim_Op_Address (Loc, |
| 6242 | Typ => Iface_Typ, |
| 6243 | Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), |
| 6244 | Position => Pos, |
| acf97c11 |
6245 | Address_Node => |
| cc60bd16 |
6246 | Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
| acf97c11 |
6247 | Make_Attribute_Reference (Loc, |
| 6248 | Prefix => New_Reference_To (Alias (Prim), Loc), |
| 6249 | Attribute_Name => Name_Unrestricted_Access)))); |
| cdb1c38f |
6250 | |
| 6251 | Insert_Actions_After (Ins_Nod, L); |
| 725a69d2 |
6252 | end if; |
| 6253 | end if; |
| 6254 | end if; |
| 6255 | end Register_Primitive; |
| 6256 | |
| ee6ba406 |
6257 | ------------------------- |
| 6258 | -- Set_All_DT_Position -- |
| 6259 | ------------------------- |
| 6260 | |
| 6261 | procedure Set_All_DT_Position (Typ : Entity_Id) is |
| ee6ba406 |
6262 | |
| aad6babd |
6263 | procedure Validate_Position (Prim : Entity_Id); |
| 36b938a3 |
6264 | -- Check that the position assigned to Prim is completely safe |
| aad6babd |
6265 | -- (it has not been assigned to a previously defined primitive |
| 6266 | -- operation of Typ) |
| 6267 | |
| 6268 | ----------------------- |
| 6269 | -- Validate_Position -- |
| 6270 | ----------------------- |
| 6271 | |
| 6272 | procedure Validate_Position (Prim : Entity_Id) is |
| af647dc7 |
6273 | Op_Elmt : Elmt_Id; |
| 6274 | Op : Entity_Id; |
| d62940bf |
6275 | |
| aad6babd |
6276 | begin |
| af647dc7 |
6277 | -- Aliased primitives are safe |
| 6278 | |
| 6279 | if Present (Alias (Prim)) then |
| 6280 | return; |
| 6281 | end if; |
| 6282 | |
| 6283 | Op_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| 6284 | while Present (Op_Elmt) loop |
| 6285 | Op := Node (Op_Elmt); |
| 6286 | |
| 6287 | -- No need to check against itself |
| 6288 | |
| 6289 | if Op = Prim then |
| 6290 | null; |
| 6291 | |
| aad6babd |
6292 | -- Primitive operations covering abstract interfaces are |
| 6293 | -- allocated later |
| 6294 | |
| af647dc7 |
6295 | elsif Present (Abstract_Interface_Alias (Op)) then |
| aad6babd |
6296 | null; |
| 6297 | |
| 68f95949 |
6298 | -- Predefined dispatching operations are completely safe. They |
| 6299 | -- are allocated at fixed positions in a separate table. |
| aad6babd |
6300 | |
| af647dc7 |
6301 | elsif Is_Predefined_Dispatching_Operation (Op) |
| 6302 | or else Is_Predefined_Dispatching_Alias (Op) |
| 6303 | then |
| aad6babd |
6304 | null; |
| ee6ba406 |
6305 | |
| aad6babd |
6306 | -- Aliased subprograms are safe |
| 6307 | |
| af647dc7 |
6308 | elsif Present (Alias (Op)) then |
| aad6babd |
6309 | null; |
| 6310 | |
| af647dc7 |
6311 | elsif DT_Position (Op) = DT_Position (Prim) |
| 6312 | and then not Is_Predefined_Dispatching_Operation (Op) |
| 6313 | and then not Is_Predefined_Dispatching_Operation (Prim) |
| 6314 | and then not Is_Predefined_Dispatching_Alias (Op) |
| 6315 | and then not Is_Predefined_Dispatching_Alias (Prim) |
| 6316 | then |
| d62940bf |
6317 | |
| 6318 | -- Handle aliased subprograms |
| 6319 | |
| 6320 | declare |
| 6321 | Op_1 : Entity_Id; |
| 6322 | Op_2 : Entity_Id; |
| 6323 | |
| 6324 | begin |
| af647dc7 |
6325 | Op_1 := Op; |
| d62940bf |
6326 | loop |
| 6327 | if Present (Overridden_Operation (Op_1)) then |
| 6328 | Op_1 := Overridden_Operation (Op_1); |
| 6329 | elsif Present (Alias (Op_1)) then |
| 6330 | Op_1 := Alias (Op_1); |
| 6331 | else |
| 6332 | exit; |
| 6333 | end if; |
| 6334 | end loop; |
| 6335 | |
| 6336 | Op_2 := Prim; |
| 6337 | loop |
| 6338 | if Present (Overridden_Operation (Op_2)) then |
| 6339 | Op_2 := Overridden_Operation (Op_2); |
| 6340 | elsif Present (Alias (Op_2)) then |
| 6341 | Op_2 := Alias (Op_2); |
| 6342 | else |
| 6343 | exit; |
| 6344 | end if; |
| 6345 | end loop; |
| 6346 | |
| 6347 | if Op_1 /= Op_2 then |
| 6348 | raise Program_Error; |
| 6349 | end if; |
| 6350 | end; |
| aad6babd |
6351 | end if; |
| 6352 | |
| af647dc7 |
6353 | Next_Elmt (Op_Elmt); |
| aad6babd |
6354 | end loop; |
| 6355 | end Validate_Position; |
| 6356 | |
| af647dc7 |
6357 | -- Local variables |
| 6358 | |
| 6359 | Parent_Typ : constant Entity_Id := Etype (Typ); |
| af647dc7 |
6360 | First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ)); |
| 6361 | The_Tag : constant Entity_Id := First_Tag_Component (Typ); |
| 6362 | |
| 6363 | Adjusted : Boolean := False; |
| 6364 | Finalized : Boolean := False; |
| 6365 | |
| 343d35dc |
6366 | Count_Prim : Nat; |
| 6367 | DT_Length : Nat; |
| 6368 | Nb_Prim : Nat; |
| af647dc7 |
6369 | Prim : Entity_Id; |
| 6370 | Prim_Elmt : Elmt_Id; |
| 6371 | |
| aad6babd |
6372 | -- Start of processing for Set_All_DT_Position |
| 6373 | |
| 6374 | begin |
| 343d35dc |
6375 | -- Set the DT_Position for each primitive operation. Perform some |
| 36b938a3 |
6376 | -- sanity checks to avoid to build completely inconsistent dispatch |
| 343d35dc |
6377 | -- tables. |
| ee6ba406 |
6378 | |
| 343d35dc |
6379 | -- First stage: Set the DTC entity of all the primitive operations |
| 6380 | -- This is required to properly read the DT_Position attribute in |
| 6381 | -- the latter stages. |
| ee6ba406 |
6382 | |
| 343d35dc |
6383 | Prim_Elmt := First_Prim; |
| 6384 | Count_Prim := 0; |
| 6385 | while Present (Prim_Elmt) loop |
| 6386 | Prim := Node (Prim_Elmt); |
| ee6ba406 |
6387 | |
| 343d35dc |
6388 | -- Predefined primitives have a separate dispatch table |
| ee6ba406 |
6389 | |
| 343d35dc |
6390 | if not (Is_Predefined_Dispatching_Operation (Prim) |
| 6391 | or else Is_Predefined_Dispatching_Alias (Prim)) |
| 6392 | then |
| 6393 | Count_Prim := Count_Prim + 1; |
| 6394 | end if; |
| ee6ba406 |
6395 | |
| 725a69d2 |
6396 | Set_DTC_Entity_Value (Typ, Prim); |
| ee6ba406 |
6397 | |
| 343d35dc |
6398 | -- Clear any previous value of the DT_Position attribute. In this |
| 6399 | -- way we ensure that the final position of all the primitives is |
| 36b938a3 |
6400 | -- established by the following stages of this algorithm. |
| ee6ba406 |
6401 | |
| 343d35dc |
6402 | Set_DT_Position (Prim, No_Uint); |
| ee6ba406 |
6403 | |
| 343d35dc |
6404 | Next_Elmt (Prim_Elmt); |
| 6405 | end loop; |
| ee6ba406 |
6406 | |
| 343d35dc |
6407 | declare |
| acf97c11 |
6408 | Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean := |
| 6409 | (others => False); |
| 6410 | |
| 343d35dc |
6411 | E : Entity_Id; |
| ee6ba406 |
6412 | |
| 725a69d2 |
6413 | procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id); |
| 6414 | -- Called if Typ is declared in a nested package or a public child |
| 6415 | -- package to handle inherited primitives that were inherited by Typ |
| 6416 | -- in the visible part, but whose declaration was deferred because |
| 6417 | -- the parent operation was private and not visible at that point. |
| 6418 | |
| 343d35dc |
6419 | procedure Set_Fixed_Prim (Pos : Nat); |
| 6420 | -- Sets to true an element of the Fixed_Prim table to indicate |
| 6421 | -- that this entry of the dispatch table of Typ is occupied. |
| ee6ba406 |
6422 | |
| 725a69d2 |
6423 | ------------------------------------------ |
| 6424 | -- Handle_Inherited_Private_Subprograms -- |
| 6425 | ------------------------------------------ |
| 6426 | |
| 6427 | procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is |
| 6428 | Op_List : Elist_Id; |
| 6429 | Op_Elmt : Elmt_Id; |
| 6430 | Op_Elmt_2 : Elmt_Id; |
| 6431 | Prim_Op : Entity_Id; |
| 6432 | Parent_Subp : Entity_Id; |
| 6433 | |
| 6434 | begin |
| 6435 | Op_List := Primitive_Operations (Typ); |
| 6436 | |
| 6437 | Op_Elmt := First_Elmt (Op_List); |
| 6438 | while Present (Op_Elmt) loop |
| 6439 | Prim_Op := Node (Op_Elmt); |
| 6440 | |
| 6441 | -- Search primitives that are implicit operations with an |
| 6442 | -- internal name whose parent operation has a normal name. |
| 6443 | |
| 6444 | if Present (Alias (Prim_Op)) |
| 6445 | and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ |
| 6446 | and then not Comes_From_Source (Prim_Op) |
| 6447 | and then Is_Internal_Name (Chars (Prim_Op)) |
| 6448 | and then not Is_Internal_Name (Chars (Alias (Prim_Op))) |
| 6449 | then |
| 6450 | Parent_Subp := Alias (Prim_Op); |
| 6451 | |
| 6452 | -- Check if the type has an explicit overriding for this |
| 6453 | -- primitive. |
| 6454 | |
| 6455 | Op_Elmt_2 := Next_Elmt (Op_Elmt); |
| 6456 | while Present (Op_Elmt_2) loop |
| 6457 | if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp) |
| 6458 | and then Type_Conformant (Prim_Op, Node (Op_Elmt_2)) |
| 6459 | then |
| 6460 | Set_DT_Position (Prim_Op, DT_Position (Parent_Subp)); |
| 6461 | Set_DT_Position (Node (Op_Elmt_2), |
| 6462 | DT_Position (Parent_Subp)); |
| 6463 | Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op))); |
| 6464 | |
| 6465 | goto Next_Primitive; |
| 6466 | end if; |
| 6467 | |
| 6468 | Next_Elmt (Op_Elmt_2); |
| 6469 | end loop; |
| 6470 | end if; |
| 6471 | |
| 6472 | <<Next_Primitive>> |
| 6473 | Next_Elmt (Op_Elmt); |
| 6474 | end loop; |
| 6475 | end Handle_Inherited_Private_Subprograms; |
| 6476 | |
| 343d35dc |
6477 | -------------------- |
| 6478 | -- Set_Fixed_Prim -- |
| 6479 | -------------------- |
| ee6ba406 |
6480 | |
| 343d35dc |
6481 | procedure Set_Fixed_Prim (Pos : Nat) is |
| ee6ba406 |
6482 | begin |
| 343d35dc |
6483 | pragma Assert (Pos >= 0 and then Pos <= Count_Prim); |
| 6484 | Fixed_Prim (Pos) := True; |
| 6485 | exception |
| 6486 | when Constraint_Error => |
| 6487 | raise Program_Error; |
| 6488 | end Set_Fixed_Prim; |
| ee6ba406 |
6489 | |
| 343d35dc |
6490 | begin |
| 725a69d2 |
6491 | -- In case of nested packages and public child package it may be |
| 6492 | -- necessary a special management on inherited subprograms so that |
| 6493 | -- the dispatch table is properly filled. |
| 6494 | |
| 6495 | if Ekind (Scope (Scope (Typ))) = E_Package |
| 6496 | and then Scope (Scope (Typ)) /= Standard_Standard |
| 6497 | and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ)) |
| 6498 | or else |
| 6499 | (Nkind (Parent (Typ)) = N_Private_Extension_Declaration |
| 6500 | and then Is_Generic_Type (Typ))) |
| 6501 | and then In_Open_Scopes (Scope (Etype (Typ))) |
| 6502 | and then Typ = Base_Type (Typ) |
| 6503 | then |
| 6504 | Handle_Inherited_Private_Subprograms (Typ); |
| 6505 | end if; |
| 6506 | |
| 343d35dc |
6507 | -- Second stage: Register fixed entries |
| ee6ba406 |
6508 | |
| 343d35dc |
6509 | Nb_Prim := 0; |
| 6510 | Prim_Elmt := First_Prim; |
| 6511 | while Present (Prim_Elmt) loop |
| 6512 | Prim := Node (Prim_Elmt); |
| ee6ba406 |
6513 | |
| 343d35dc |
6514 | -- Predefined primitives have a separate table and all its |
| 6515 | -- entries are at predefined fixed positions. |
| ee6ba406 |
6516 | |
| 343d35dc |
6517 | if Is_Predefined_Dispatching_Operation (Prim) then |
| 6518 | Set_DT_Position (Prim, Default_Prim_Op_Position (Prim)); |
| ee6ba406 |
6519 | |
| 343d35dc |
6520 | elsif Is_Predefined_Dispatching_Alias (Prim) then |
| 6521 | E := Alias (Prim); |
| 6522 | while Present (Alias (E)) loop |
| 6523 | E := Alias (E); |
| 6524 | end loop; |
| d62940bf |
6525 | |
| 343d35dc |
6526 | Set_DT_Position (Prim, Default_Prim_Op_Position (E)); |
| d62940bf |
6527 | |
| 343d35dc |
6528 | -- Overriding primitives of ancestor abstract interfaces |
| ee6ba406 |
6529 | |
| 343d35dc |
6530 | elsif Present (Abstract_Interface_Alias (Prim)) |
| 6531 | and then Is_Parent |
| 6532 | (Find_Dispatching_Type |
| 6533 | (Abstract_Interface_Alias (Prim)), |
| 6534 | Typ) |
| 6535 | then |
| 6536 | pragma Assert (DT_Position (Prim) = No_Uint |
| 6537 | and then Present (DTC_Entity |
| 6538 | (Abstract_Interface_Alias (Prim)))); |
| ee6ba406 |
6539 | |
| 343d35dc |
6540 | E := Abstract_Interface_Alias (Prim); |
| 6541 | Set_DT_Position (Prim, DT_Position (E)); |
| aad6babd |
6542 | |
| 343d35dc |
6543 | pragma Assert |
| 6544 | (DT_Position (Alias (Prim)) = No_Uint |
| 6545 | or else DT_Position (Alias (Prim)) = DT_Position (E)); |
| 6546 | Set_DT_Position (Alias (Prim), DT_Position (E)); |
| 6547 | Set_Fixed_Prim (UI_To_Int (DT_Position (Prim))); |
| af647dc7 |
6548 | |
| 343d35dc |
6549 | -- Overriding primitives must use the same entry as the |
| 36b938a3 |
6550 | -- overridden primitive. |
| af647dc7 |
6551 | |
| 343d35dc |
6552 | elsif not Present (Abstract_Interface_Alias (Prim)) |
| 6553 | and then Present (Alias (Prim)) |
| 17e14451 |
6554 | and then Chars (Prim) = Chars (Alias (Prim)) |
| 343d35dc |
6555 | and then Find_Dispatching_Type (Alias (Prim)) /= Typ |
| 6556 | and then Is_Parent |
| 6557 | (Find_Dispatching_Type (Alias (Prim)), Typ) |
| 6558 | and then Present (DTC_Entity (Alias (Prim))) |
| af647dc7 |
6559 | then |
| 343d35dc |
6560 | E := Alias (Prim); |
| 6561 | Set_DT_Position (Prim, DT_Position (E)); |
| aad6babd |
6562 | |
| 343d35dc |
6563 | if not Is_Predefined_Dispatching_Alias (E) then |
| 6564 | Set_Fixed_Prim (UI_To_Int (DT_Position (E))); |
| 6565 | end if; |
| 9dfe12ae |
6566 | end if; |
| ee6ba406 |
6567 | |
| aad6babd |
6568 | Next_Elmt (Prim_Elmt); |
| 6569 | end loop; |
| 6570 | |
| 343d35dc |
6571 | -- Third stage: Fix the position of all the new primitives |
| 6572 | -- Entries associated with primitives covering interfaces |
| 6573 | -- are handled in a latter round. |
| aad6babd |
6574 | |
| 343d35dc |
6575 | Prim_Elmt := First_Prim; |
| 6576 | while Present (Prim_Elmt) loop |
| 6577 | Prim := Node (Prim_Elmt); |
| aad6babd |
6578 | |
| 343d35dc |
6579 | -- Skip primitives previously set entries |
| aad6babd |
6580 | |
| 343d35dc |
6581 | if DT_Position (Prim) /= No_Uint then |
| 6582 | null; |
| aad6babd |
6583 | |
| 343d35dc |
6584 | -- Primitives covering interface primitives are handled later |
| aad6babd |
6585 | |
| 343d35dc |
6586 | elsif Present (Abstract_Interface_Alias (Prim)) then |
| 6587 | null; |
| aad6babd |
6588 | |
| 343d35dc |
6589 | else |
| 6590 | -- Take the next available position in the DT |
| aad6babd |
6591 | |
| 343d35dc |
6592 | loop |
| 6593 | Nb_Prim := Nb_Prim + 1; |
| 6594 | pragma Assert (Nb_Prim <= Count_Prim); |
| 6595 | exit when not Fixed_Prim (Nb_Prim); |
| 6596 | end loop; |
| aad6babd |
6597 | |
| 343d35dc |
6598 | Set_DT_Position (Prim, UI_From_Int (Nb_Prim)); |
| 6599 | Set_Fixed_Prim (Nb_Prim); |
| 6600 | end if; |
| aad6babd |
6601 | |
| 343d35dc |
6602 | Next_Elmt (Prim_Elmt); |
| 6603 | end loop; |
| 6604 | end; |
| aad6babd |
6605 | |
| 343d35dc |
6606 | -- Fourth stage: Complete the decoration of primitives covering |
| 6607 | -- interfaces (that is, propagate the DT_Position attribute |
| 6608 | -- from the aliased primitive) |
| aad6babd |
6609 | |
| 343d35dc |
6610 | Prim_Elmt := First_Prim; |
| 6611 | while Present (Prim_Elmt) loop |
| 6612 | Prim := Node (Prim_Elmt); |
| aad6babd |
6613 | |
| 343d35dc |
6614 | if DT_Position (Prim) = No_Uint |
| 6615 | and then Present (Abstract_Interface_Alias (Prim)) |
| 6616 | then |
| 6617 | pragma Assert (Present (Alias (Prim)) |
| 6618 | and then Find_Dispatching_Type (Alias (Prim)) = Typ); |
| aad6babd |
6619 | |
| 343d35dc |
6620 | -- Check if this entry will be placed in the primary DT |
| aad6babd |
6621 | |
| 343d35dc |
6622 | if Is_Parent (Find_Dispatching_Type |
| 6623 | (Abstract_Interface_Alias (Prim)), |
| 6624 | Typ) |
| ee6ba406 |
6625 | then |
| 343d35dc |
6626 | pragma Assert (DT_Position (Alias (Prim)) /= No_Uint); |
| 6627 | Set_DT_Position (Prim, DT_Position (Alias (Prim))); |
| aad6babd |
6628 | |
| 343d35dc |
6629 | -- Otherwise it will be placed in the secondary DT |
| aad6babd |
6630 | |
| 343d35dc |
6631 | else |
| 6632 | pragma Assert |
| 6633 | (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint); |
| 6634 | Set_DT_Position (Prim, |
| 6635 | DT_Position (Abstract_Interface_Alias (Prim))); |
| aad6babd |
6636 | end if; |
| 343d35dc |
6637 | end if; |
| aad6babd |
6638 | |
| 343d35dc |
6639 | Next_Elmt (Prim_Elmt); |
| 6640 | end loop; |
| d62940bf |
6641 | |
| 343d35dc |
6642 | -- Generate listing showing the contents of the dispatch tables. |
| 6643 | -- This action is done before some further static checks because |
| 6644 | -- in case of critical errors caused by a wrong dispatch table |
| 6645 | -- we need to see the contents of such table. |
| d62940bf |
6646 | |
| 343d35dc |
6647 | if Debug_Flag_ZZ then |
| 6648 | Write_DT (Typ); |
| 6649 | end if; |
| aad6babd |
6650 | |
| 343d35dc |
6651 | -- Final stage: Ensure that the table is correct plus some further |
| 6652 | -- verifications concerning the primitives. |
| aad6babd |
6653 | |
| 343d35dc |
6654 | Prim_Elmt := First_Prim; |
| 6655 | DT_Length := 0; |
| 6656 | while Present (Prim_Elmt) loop |
| 6657 | Prim := Node (Prim_Elmt); |
| aad6babd |
6658 | |
| 343d35dc |
6659 | -- At this point all the primitives MUST have a position |
| acf97c11 |
6660 | -- in the dispatch table. |
| aad6babd |
6661 | |
| 343d35dc |
6662 | if DT_Position (Prim) = No_Uint then |
| 6663 | raise Program_Error; |
| 6664 | end if; |
| aad6babd |
6665 | |
| 343d35dc |
6666 | -- Calculate real size of the dispatch table |
| aad6babd |
6667 | |
| 343d35dc |
6668 | if not (Is_Predefined_Dispatching_Operation (Prim) |
| 6669 | or else Is_Predefined_Dispatching_Alias (Prim)) |
| 6670 | and then UI_To_Int (DT_Position (Prim)) > DT_Length |
| 6671 | then |
| 6672 | DT_Length := UI_To_Int (DT_Position (Prim)); |
| 6673 | end if; |
| aad6babd |
6674 | |
| 36b938a3 |
6675 | -- Ensure that the assigned position to non-predefined |
| 343d35dc |
6676 | -- dispatching operations in the dispatch table is correct. |
| aad6babd |
6677 | |
| 343d35dc |
6678 | if not (Is_Predefined_Dispatching_Operation (Prim) |
| 6679 | or else Is_Predefined_Dispatching_Alias (Prim)) |
| 6680 | then |
| 6681 | Validate_Position (Prim); |
| 6682 | end if; |
| ee6ba406 |
6683 | |
| 343d35dc |
6684 | if Chars (Prim) = Name_Finalize then |
| 6685 | Finalized := True; |
| 6686 | end if; |
| ee6ba406 |
6687 | |
| 343d35dc |
6688 | if Chars (Prim) = Name_Adjust then |
| 6689 | Adjusted := True; |
| 6690 | end if; |
| af647dc7 |
6691 | |
| 343d35dc |
6692 | -- An abstract operation cannot be declared in the private part |
| 6693 | -- for a visible abstract type, because it could never be over- |
| 6694 | -- ridden. For explicit declarations this is checked at the |
| 6695 | -- point of declaration, but for inherited operations it must |
| 6696 | -- be done when building the dispatch table. |
| 6697 | |
| 6698 | -- Ada 2005 (AI-251): Hidden entities associated with abstract |
| 6699 | -- interface primitives are not taken into account because the |
| 6700 | -- check is done with the aliased primitive. |
| 6701 | |
| 6702 | if Is_Abstract_Type (Typ) |
| 6703 | and then Is_Abstract_Subprogram (Prim) |
| 6704 | and then Present (Alias (Prim)) |
| 6705 | and then not Present (Abstract_Interface_Alias (Prim)) |
| 6706 | and then Is_Derived_Type (Typ) |
| 6707 | and then In_Private_Part (Current_Scope) |
| 6708 | and then |
| 6709 | List_Containing (Parent (Prim)) = |
| 6710 | Private_Declarations |
| 6711 | (Specification (Unit_Declaration_Node (Current_Scope))) |
| 6712 | and then Original_View_In_Visible_Part (Typ) |
| 6713 | then |
| 6714 | -- We exclude Input and Output stream operations because |
| 6715 | -- Limited_Controlled inherits useless Input and Output |
| 6716 | -- stream operations from Root_Controlled, which can |
| 6717 | -- never be overridden. |
| ee6ba406 |
6718 | |
| 343d35dc |
6719 | if not Is_TSS (Prim, TSS_Stream_Input) |
| 6720 | and then |
| 6721 | not Is_TSS (Prim, TSS_Stream_Output) |
| ee6ba406 |
6722 | then |
| 343d35dc |
6723 | Error_Msg_NE |
| 6724 | ("abstract inherited private operation&" & |
| 17e14451 |
6725 | " must be overridden (RM 3.9.3(10))", |
| 343d35dc |
6726 | Parent (Typ), Prim); |
| ee6ba406 |
6727 | end if; |
| 343d35dc |
6728 | end if; |
| aad6babd |
6729 | |
| 343d35dc |
6730 | Next_Elmt (Prim_Elmt); |
| 6731 | end loop; |
| ee6ba406 |
6732 | |
| 343d35dc |
6733 | -- Additional check |
| aad6babd |
6734 | |
| 343d35dc |
6735 | if Is_Controlled (Typ) then |
| 6736 | if not Finalized then |
| 6737 | Error_Msg_N |
| 6738 | ("controlled type has no explicit Finalize method?", Typ); |
| ee6ba406 |
6739 | |
| 343d35dc |
6740 | elsif not Adjusted then |
| 6741 | Error_Msg_N |
| 6742 | ("controlled type has no explicit Adjust method?", Typ); |
| ee6ba406 |
6743 | end if; |
| 343d35dc |
6744 | end if; |
| ee6ba406 |
6745 | |
| 343d35dc |
6746 | -- Set the final size of the Dispatch Table |
| aad6babd |
6747 | |
| 343d35dc |
6748 | Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length)); |
| ee6ba406 |
6749 | |
| 725a69d2 |
6750 | -- The derived type must have at least as many components as its parent |
| acf97c11 |
6751 | -- (for root types Etype points to itself and the test cannot fail). |
| aad6babd |
6752 | |
| 725a69d2 |
6753 | if DT_Entry_Count (The_Tag) < |
| 6754 | DT_Entry_Count (First_Tag_Component (Parent_Typ)) |
| 6755 | then |
| 6756 | raise Program_Error; |
| aad6babd |
6757 | end if; |
| ee6ba406 |
6758 | end Set_All_DT_Position; |
| 6759 | |
| 6760 | ----------------------------- |
| 6761 | -- Set_Default_Constructor -- |
| 6762 | ----------------------------- |
| 6763 | |
| 6764 | procedure Set_Default_Constructor (Typ : Entity_Id) is |
| 6765 | Loc : Source_Ptr; |
| 6766 | Init : Entity_Id; |
| 6767 | Param : Entity_Id; |
| ee6ba406 |
6768 | E : Entity_Id; |
| 6769 | |
| 6770 | begin |
| 6771 | -- Look for the default constructor entity. For now only the |
| 6772 | -- default constructor has the flag Is_Constructor. |
| 6773 | |
| 6774 | E := Next_Entity (Typ); |
| 6775 | while Present (E) |
| 6776 | and then (Ekind (E) /= E_Function or else not Is_Constructor (E)) |
| 6777 | loop |
| 6778 | Next_Entity (E); |
| 6779 | end loop; |
| 6780 | |
| 6781 | -- Create the init procedure |
| 6782 | |
| 6783 | if Present (E) then |
| 6784 | Loc := Sloc (E); |
| 9dfe12ae |
6785 | Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ)); |
| ee6ba406 |
6786 | Param := Make_Defining_Identifier (Loc, Name_X); |
| 9dfe12ae |
6787 | |
| 6788 | Discard_Node ( |
| ee6ba406 |
6789 | Make_Subprogram_Declaration (Loc, |
| 6790 | Make_Procedure_Specification (Loc, |
| 6791 | Defining_Unit_Name => Init, |
| 6792 | Parameter_Specifications => New_List ( |
| 6793 | Make_Parameter_Specification (Loc, |
| 6794 | Defining_Identifier => Param, |
| 9dfe12ae |
6795 | Parameter_Type => New_Reference_To (Typ, Loc)))))); |
| ee6ba406 |
6796 | |
| 6797 | Set_Init_Proc (Typ, Init); |
| 9dfe12ae |
6798 | Set_Is_Imported (Init); |
| ee6ba406 |
6799 | Set_Interface_Name (Init, Interface_Name (E)); |
| 9dfe12ae |
6800 | Set_Convention (Init, Convention_C); |
| 6801 | Set_Is_Public (Init); |
| ee6ba406 |
6802 | Set_Has_Completion (Init); |
| 6803 | |
| 9dfe12ae |
6804 | -- If there are no constructors, mark the type as abstract since we |
| ee6ba406 |
6805 | -- won't be able to declare objects of that type. |
| 6806 | |
| 6807 | else |
| 343d35dc |
6808 | Set_Is_Abstract_Type (Typ); |
| ee6ba406 |
6809 | end if; |
| 6810 | end Set_Default_Constructor; |
| 6811 | |
| 725a69d2 |
6812 | -------------------------- |
| 6813 | -- Set_DTC_Entity_Value -- |
| 6814 | -------------------------- |
| 6815 | |
| 6816 | procedure Set_DTC_Entity_Value |
| 6817 | (Tagged_Type : Entity_Id; |
| 6818 | Prim : Entity_Id) |
| 6819 | is |
| 6820 | begin |
| 6821 | if Present (Abstract_Interface_Alias (Prim)) |
| 6822 | and then Is_Interface |
| 6823 | (Find_Dispatching_Type |
| 6824 | (Abstract_Interface_Alias (Prim))) |
| 6825 | then |
| 6826 | Set_DTC_Entity (Prim, |
| 6827 | Find_Interface_Tag |
| 6828 | (T => Tagged_Type, |
| 6829 | Iface => Find_Dispatching_Type |
| 6830 | (Abstract_Interface_Alias (Prim)))); |
| 6831 | else |
| 6832 | Set_DTC_Entity (Prim, |
| 6833 | First_Tag_Component (Tagged_Type)); |
| 6834 | end if; |
| 6835 | end Set_DTC_Entity_Value; |
| 6836 | |
| 952af0b9 |
6837 | ----------------- |
| 6838 | -- Tagged_Kind -- |
| 6839 | ----------------- |
| 6840 | |
| 6841 | function Tagged_Kind (T : Entity_Id) return Node_Id is |
| 6842 | Conc_Typ : Entity_Id; |
| 6843 | Loc : constant Source_Ptr := Sloc (T); |
| 6844 | |
| 6845 | begin |
| 68f95949 |
6846 | pragma Assert |
| 6847 | (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind)); |
| 952af0b9 |
6848 | |
| 6849 | -- Abstract kinds |
| 6850 | |
| 343d35dc |
6851 | if Is_Abstract_Type (T) then |
| 952af0b9 |
6852 | if Is_Limited_Record (T) then |
| 6853 | return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc); |
| 6854 | else |
| 6855 | return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc); |
| 6856 | end if; |
| 6857 | |
| 6858 | -- Concurrent kinds |
| 6859 | |
| 6860 | elsif Is_Concurrent_Record_Type (T) then |
| 6861 | Conc_Typ := Corresponding_Concurrent_Type (T); |
| 6862 | |
| 17e14451 |
6863 | if Present (Full_View (Conc_Typ)) then |
| 6864 | Conc_Typ := Full_View (Conc_Typ); |
| 6865 | end if; |
| 6866 | |
| 952af0b9 |
6867 | if Ekind (Conc_Typ) = E_Protected_Type then |
| 6868 | return New_Reference_To (RTE (RE_TK_Protected), Loc); |
| 6869 | else |
| 6870 | pragma Assert (Ekind (Conc_Typ) = E_Task_Type); |
| 6871 | return New_Reference_To (RTE (RE_TK_Task), Loc); |
| 6872 | end if; |
| 6873 | |
| 6874 | -- Regular tagged kinds |
| 6875 | |
| 6876 | else |
| 6877 | if Is_Limited_Record (T) then |
| 6878 | return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc); |
| 6879 | else |
| 6880 | return New_Reference_To (RTE (RE_TK_Tagged), Loc); |
| 6881 | end if; |
| 6882 | end if; |
| 6883 | end Tagged_Kind; |
| 6884 | |
| aad6babd |
6885 | -------------- |
| 6886 | -- Write_DT -- |
| 6887 | -------------- |
| 6888 | |
| 6889 | procedure Write_DT (Typ : Entity_Id) is |
| 6890 | Elmt : Elmt_Id; |
| 6891 | Prim : Node_Id; |
| 6892 | |
| 6893 | begin |
| 6894 | -- Protect this procedure against wrong usage. Required because it will |
| 6895 | -- be used directly from GDB |
| 6896 | |
| 17e14451 |
6897 | if not (Typ <= Last_Node_Id) |
| aad6babd |
6898 | or else not Is_Tagged_Type (Typ) |
| 6899 | then |
| d62940bf |
6900 | Write_Str ("wrong usage: Write_DT must be used with tagged types"); |
| aad6babd |
6901 | Write_Eol; |
| 6902 | return; |
| 6903 | end if; |
| 6904 | |
| 6905 | Write_Int (Int (Typ)); |
| 6906 | Write_Str (": "); |
| 6907 | Write_Name (Chars (Typ)); |
| 6908 | |
| 6909 | if Is_Interface (Typ) then |
| 6910 | Write_Str (" is interface"); |
| 6911 | end if; |
| 6912 | |
| 6913 | Write_Eol; |
| 6914 | |
| 6915 | Elmt := First_Elmt (Primitive_Operations (Typ)); |
| 6916 | while Present (Elmt) loop |
| 6917 | Prim := Node (Elmt); |
| 6918 | Write_Str (" - "); |
| 6919 | |
| 6920 | -- Indicate if this primitive will be allocated in the primary |
| 6921 | -- dispatch table or in a secondary dispatch table associated |
| 6922 | -- with an abstract interface type |
| 6923 | |
| 6924 | if Present (DTC_Entity (Prim)) then |
| 6925 | if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then |
| 6926 | Write_Str ("[P] "); |
| 6927 | else |
| 6928 | Write_Str ("[s] "); |
| 6929 | end if; |
| 6930 | end if; |
| 6931 | |
| 6932 | -- Output the node of this primitive operation and its name |
| 6933 | |
| 6934 | Write_Int (Int (Prim)); |
| 6935 | Write_Str (": "); |
| 68f95949 |
6936 | |
| 6937 | if Is_Predefined_Dispatching_Operation (Prim) then |
| 6938 | Write_Str ("(predefined) "); |
| 6939 | end if; |
| 6940 | |
| aad6babd |
6941 | Write_Name (Chars (Prim)); |
| 6942 | |
| 6943 | -- Indicate if this primitive has an aliased primitive |
| 6944 | |
| 6945 | if Present (Alias (Prim)) then |
| 6946 | Write_Str (" (alias = "); |
| 6947 | Write_Int (Int (Alias (Prim))); |
| 6948 | |
| 6949 | -- If the DTC_Entity attribute is already set we can also output |
| 6950 | -- the name of the interface covered by this primitive (if any) |
| 6951 | |
| 6952 | if Present (DTC_Entity (Alias (Prim))) |
| 6953 | and then Is_Interface (Scope (DTC_Entity (Alias (Prim)))) |
| 6954 | then |
| 6955 | Write_Str (" from interface "); |
| 6956 | Write_Name (Chars (Scope (DTC_Entity (Alias (Prim))))); |
| 6957 | end if; |
| 6958 | |
| 6959 | if Present (Abstract_Interface_Alias (Prim)) then |
| 6960 | Write_Str (", AI_Alias of "); |
| 6961 | Write_Name (Chars (Scope (DTC_Entity |
| 6962 | (Abstract_Interface_Alias (Prim))))); |
| 6963 | Write_Char (':'); |
| 6964 | Write_Int (Int (Abstract_Interface_Alias (Prim))); |
| 6965 | end if; |
| 6966 | |
| 6967 | Write_Str (")"); |
| 6968 | end if; |
| 6969 | |
| 6970 | -- Display the final position of this primitive in its associated |
| 6971 | -- (primary or secondary) dispatch table |
| 6972 | |
| 6973 | if Present (DTC_Entity (Prim)) |
| 6974 | and then DT_Position (Prim) /= No_Uint |
| 6975 | then |
| 6976 | Write_Str (" at #"); |
| 6977 | Write_Int (UI_To_Int (DT_Position (Prim))); |
| 6978 | end if; |
| 6979 | |
| 343d35dc |
6980 | if Is_Abstract_Subprogram (Prim) then |
| aad6babd |
6981 | Write_Str (" is abstract;"); |
| af647dc7 |
6982 | |
| 6983 | -- Check if this is a null primitive |
| 6984 | |
| 6985 | elsif Comes_From_Source (Prim) |
| 6986 | and then Ekind (Prim) = E_Procedure |
| 6987 | and then Null_Present (Parent (Prim)) |
| 6988 | then |
| 6989 | Write_Str (" is null;"); |
| aad6babd |
6990 | end if; |
| 6991 | |
| 6992 | Write_Eol; |
| 6993 | |
| 6994 | Next_Elmt (Elmt); |
| 6995 | end loop; |
| 6996 | end Write_DT; |
| 6997 | |
| ee6ba406 |
6998 | end Exp_Disp; |
projects / thirdparty / gcc.git / blame