1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Einfo
; use Einfo
;
27 with Einfo
.Entities
; use Einfo
.Entities
;
28 with Nlists
; use Nlists
;
29 with Nmake
; use Nmake
;
30 with Rtsfind
; use Rtsfind
;
31 with Sem_Util
; use Sem_Util
;
32 with Snames
; use Snames
;
33 with Stand
; use Stand
;
34 with Tbuild
; use Tbuild
;
36 package body Exp_Sel
is
38 -----------------------
39 -- Build_Abort_Block --
40 -----------------------
42 function Build_Abort_Block
44 Abr_Blk_Ent
: Entity_Id
;
45 Cln_Blk_Ent
: Entity_Id
;
46 Blk
: Node_Id
) return Node_Id
50 Make_Block_Statement
(Loc
,
51 Identifier
=> New_Occurrence_Of
(Abr_Blk_Ent
, Loc
),
53 Declarations
=> No_List
,
55 Handled_Statement_Sequence
=>
56 Make_Handled_Sequence_Of_Statements
(Loc
,
59 Make_Implicit_Label_Declaration
(Loc
,
60 Defining_Identifier
=> Cln_Blk_Ent
,
61 Label_Construct
=> Blk
),
65 New_List
(Build_Abort_Block_Handler
(Loc
))));
66 end Build_Abort_Block
;
68 -------------------------------
69 -- Build_Abort_Block_Handler --
70 -------------------------------
72 function Build_Abort_Block_Handler
(Loc
: Source_Ptr
) return Node_Id
is
74 return Make_Implicit_Exception_Handler
(Loc
,
76 New_List
(New_Occurrence_Of
(Stand
.Abort_Signal
, Loc
)),
77 Statements
=> New_List
(Make_Null_Statement
(Loc
)));
78 end Build_Abort_Block_Handler
;
86 Decls
: List_Id
) return Entity_Id
88 B
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B');
91 Make_Object_Declaration
(Loc
,
92 Defining_Identifier
=> B
,
93 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
94 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
104 Decls
: List_Id
) return Entity_Id
106 C
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
109 Make_Object_Declaration
(Loc
,
110 Defining_Identifier
=> C
,
112 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
)));
116 -------------------------
117 -- Build_Cleanup_Block --
118 -------------------------
120 function Build_Cleanup_Block
124 Clean_Ent
: Entity_Id
) return Node_Id
126 Cleanup_Block
: constant Node_Id
:=
127 Make_Block_Statement
(Loc
,
129 New_Occurrence_Of
(Blk_Ent
, Loc
),
130 Declarations
=> No_List
,
131 Handled_Statement_Sequence
=>
132 Make_Handled_Sequence_Of_Statements
(Loc
,
133 Statements
=> Stmts
),
134 Is_Asynchronous_Call_Block
=> True);
137 Set_Entry_Cancel_Parameter
(Blk_Ent
, Clean_Ent
);
139 return Cleanup_Block
;
140 end Build_Cleanup_Block
;
149 Obj
: Entity_Id
) return Entity_Id
151 K
: constant Entity_Id
:= Make_Temporary
(Loc
, 'K');
152 Tag_Node
: constant Node_Id
:=
153 Make_Attribute_Reference
(Loc
,
154 Prefix
=> New_Copy_Tree
(Obj
),
155 Attribute_Name
=> Name_Tag
);
159 Make_Object_Declaration
(Loc
,
160 Defining_Identifier
=> K
,
162 New_Occurrence_Of
(RTE
(RE_Tagged_Kind
), Loc
),
164 Make_Function_Call
(Loc
,
165 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Tagged_Kind
), Loc
),
166 Parameter_Associations
=> New_List
(Tag_Node
))));
177 Decls
: List_Id
) return Entity_Id
179 S
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
182 Make_Object_Declaration
(Loc
,
183 Defining_Identifier
=> S
,
184 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
)));
188 ------------------------
189 -- Build_S_Assignment --
190 ------------------------
192 function Build_S_Assignment
196 Call_Ent
: Entity_Id
) return Node_Id
200 Make_Assignment_Statement
(Loc
,
201 Name
=> New_Occurrence_Of
(S
, Loc
),
203 Make_Function_Call
(Loc
,
204 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Offset_Index
), Loc
),
205 Parameter_Associations
=> New_List
(
206 Make_Attribute_Reference
(Loc
,
207 Prefix
=> New_Copy_Tree
(Obj
),
208 Attribute_Name
=> Name_Tag
),
209 Make_Integer_Literal
(Loc
, DT_Position
(Call_Ent
)))));
210 end Build_S_Assignment
;