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