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