Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/exp_sel.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 ------------------------------------------------------------------------------ | |
2 -- -- | |
3 -- GNAT COMPILER COMPONENTS -- | |
4 -- -- | |
5 -- E X P _ S E L -- | |
6 -- -- | |
7 -- B o d y -- | |
8 -- -- | |
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- | |
10 -- -- | |
11 -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 -- terms of the GNU General Public License as published by the Free Soft- -- | |
13 -- ware Foundation; either version 3, or (at your option) any later ver- -- | |
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
17 -- for more details. You should have received a copy of the GNU General -- | |
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to -- | |
19 -- http://www.gnu.org/licenses for a complete copy of the license. -- | |
20 -- -- | |
21 -- GNAT was originally developed by the GNAT team at New York University. -- | |
22 -- Extensive contributions were provided by Ada Core Technologies Inc. -- | |
23 -- -- | |
24 ------------------------------------------------------------------------------ | |
25 | |
26 with Einfo; use Einfo; | |
27 with Nlists; use Nlists; | |
28 with Nmake; use Nmake; | |
29 with Opt; use Opt; | |
30 with Rtsfind; use Rtsfind; | |
31 with Sinfo; use Sinfo; | |
32 with Snames; use Snames; | |
33 with Stand; use Stand; | |
34 with Tbuild; use Tbuild; | |
35 | |
36 package body Exp_Sel is | |
37 | |
38 ----------------------- | |
39 -- Build_Abort_Block -- | |
40 ----------------------- | |
41 | |
42 function Build_Abort_Block | |
43 (Loc : Source_Ptr; | |
44 Abr_Blk_Ent : Entity_Id; | |
45 Cln_Blk_Ent : Entity_Id; | |
46 Blk : Node_Id) return Node_Id | |
47 is | |
48 begin | |
49 return | |
50 Make_Block_Statement (Loc, | |
51 Identifier => New_Occurrence_Of (Abr_Blk_Ent, Loc), | |
52 | |
53 Declarations => No_List, | |
54 | |
55 Handled_Statement_Sequence => | |
56 Make_Handled_Sequence_Of_Statements (Loc, | |
57 Statements => | |
58 New_List ( | |
59 Make_Implicit_Label_Declaration (Loc, | |
60 Defining_Identifier => Cln_Blk_Ent, | |
61 Label_Construct => Blk), | |
62 Blk), | |
63 | |
64 Exception_Handlers => | |
65 New_List (Build_Abort_Block_Handler (Loc)))); | |
66 end Build_Abort_Block; | |
67 | |
68 ------------------------------- | |
69 -- Build_Abort_Block_Handler -- | |
70 ------------------------------- | |
71 | |
72 function Build_Abort_Block_Handler (Loc : Source_Ptr) return Node_Id is | |
73 Stmt : Node_Id; | |
74 | |
75 begin | |
76 | |
77 -- With ZCX exceptions, aborts are not defered in handlers. With SJLJ, | |
78 -- they are deferred at the beginning of Abort_Signal handlers. | |
79 | |
80 if ZCX_Exceptions then | |
81 Stmt := Make_Null_Statement (Loc); | |
82 | |
83 else | |
84 Stmt := | |
85 Make_Procedure_Call_Statement (Loc, | |
86 Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc), | |
87 Parameter_Associations => No_List); | |
88 end if; | |
89 | |
90 return Make_Implicit_Exception_Handler (Loc, | |
91 Exception_Choices => | |
92 New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)), | |
93 Statements => New_List (Stmt)); | |
94 end Build_Abort_Block_Handler; | |
95 | |
96 ------------- | |
97 -- Build_B -- | |
98 ------------- | |
99 | |
100 function Build_B | |
101 (Loc : Source_Ptr; | |
102 Decls : List_Id) return Entity_Id | |
103 is | |
104 B : constant Entity_Id := Make_Temporary (Loc, 'B'); | |
105 begin | |
106 Append_To (Decls, | |
107 Make_Object_Declaration (Loc, | |
108 Defining_Identifier => B, | |
109 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), | |
110 Expression => New_Occurrence_Of (Standard_False, Loc))); | |
111 return B; | |
112 end Build_B; | |
113 | |
114 ------------- | |
115 -- Build_C -- | |
116 ------------- | |
117 | |
118 function Build_C | |
119 (Loc : Source_Ptr; | |
120 Decls : List_Id) return Entity_Id | |
121 is | |
122 C : constant Entity_Id := Make_Temporary (Loc, 'C'); | |
123 begin | |
124 Append_To (Decls, | |
125 Make_Object_Declaration (Loc, | |
126 Defining_Identifier => C, | |
127 Object_Definition => | |
128 New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc))); | |
129 return C; | |
130 end Build_C; | |
131 | |
132 ------------------------- | |
133 -- Build_Cleanup_Block -- | |
134 ------------------------- | |
135 | |
136 function Build_Cleanup_Block | |
137 (Loc : Source_Ptr; | |
138 Blk_Ent : Entity_Id; | |
139 Stmts : List_Id; | |
140 Clean_Ent : Entity_Id) return Node_Id | |
141 is | |
142 Cleanup_Block : constant Node_Id := | |
143 Make_Block_Statement (Loc, | |
144 Identifier => | |
145 New_Occurrence_Of (Blk_Ent, Loc), | |
146 Declarations => No_List, | |
147 Handled_Statement_Sequence => | |
148 Make_Handled_Sequence_Of_Statements (Loc, | |
149 Statements => Stmts), | |
150 Is_Asynchronous_Call_Block => True); | |
151 | |
152 begin | |
153 Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent); | |
154 | |
155 return Cleanup_Block; | |
156 end Build_Cleanup_Block; | |
157 | |
158 ------------- | |
159 -- Build_K -- | |
160 ------------- | |
161 | |
162 function Build_K | |
163 (Loc : Source_Ptr; | |
164 Decls : List_Id; | |
165 Obj : Entity_Id) return Entity_Id | |
166 is | |
167 K : constant Entity_Id := Make_Temporary (Loc, 'K'); | |
168 Tag_Node : Node_Id; | |
169 | |
170 begin | |
171 if Tagged_Type_Expansion then | |
172 Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), Obj); | |
173 else | |
174 Tag_Node := | |
175 Make_Attribute_Reference (Loc, | |
176 Prefix => Obj, | |
177 Attribute_Name => Name_Tag); | |
178 end if; | |
179 | |
180 Append_To (Decls, | |
181 Make_Object_Declaration (Loc, | |
182 Defining_Identifier => K, | |
183 Object_Definition => | |
184 New_Occurrence_Of (RTE (RE_Tagged_Kind), Loc), | |
185 Expression => | |
186 Make_Function_Call (Loc, | |
187 Name => New_Occurrence_Of (RTE (RE_Get_Tagged_Kind), Loc), | |
188 Parameter_Associations => New_List (Tag_Node)))); | |
189 return K; | |
190 end Build_K; | |
191 | |
192 ------------- | |
193 -- Build_S -- | |
194 ------------- | |
195 | |
196 function Build_S | |
197 (Loc : Source_Ptr; | |
198 Decls : List_Id) return Entity_Id | |
199 is | |
200 S : constant Entity_Id := Make_Temporary (Loc, 'S'); | |
201 begin | |
202 Append_To (Decls, | |
203 Make_Object_Declaration (Loc, | |
204 Defining_Identifier => S, | |
205 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); | |
206 return S; | |
207 end Build_S; | |
208 | |
209 ------------------------ | |
210 -- Build_S_Assignment -- | |
211 ------------------------ | |
212 | |
213 function Build_S_Assignment | |
214 (Loc : Source_Ptr; | |
215 S : Entity_Id; | |
216 Obj : Entity_Id; | |
217 Call_Ent : Entity_Id) return Node_Id | |
218 is | |
219 Typ : constant Entity_Id := Etype (Obj); | |
220 | |
221 begin | |
222 if Tagged_Type_Expansion then | |
223 return | |
224 Make_Assignment_Statement (Loc, | |
225 Name => New_Occurrence_Of (S, Loc), | |
226 Expression => | |
227 Make_Function_Call (Loc, | |
228 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), | |
229 Parameter_Associations => New_List ( | |
230 Unchecked_Convert_To (RTE (RE_Tag), Obj), | |
231 Make_Integer_Literal (Loc, DT_Position (Call_Ent))))); | |
232 | |
233 -- VM targets | |
234 | |
235 else | |
236 return | |
237 Make_Assignment_Statement (Loc, | |
238 Name => New_Occurrence_Of (S, Loc), | |
239 Expression => | |
240 Make_Function_Call (Loc, | |
241 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), | |
242 | |
243 Parameter_Associations => New_List ( | |
244 | |
245 -- Obj_Typ | |
246 | |
247 Make_Attribute_Reference (Loc, | |
248 Prefix => Obj, | |
249 Attribute_Name => Name_Tag), | |
250 | |
251 -- Iface_Typ | |
252 | |
253 Make_Attribute_Reference (Loc, | |
254 Prefix => New_Occurrence_Of (Typ, Loc), | |
255 Attribute_Name => Name_Tag), | |
256 | |
257 -- Position | |
258 | |
259 Make_Integer_Literal (Loc, DT_Position (Call_Ent))))); | |
260 end if; | |
261 end Build_S_Assignment; | |
262 | |
263 end Exp_Sel; |