1 |
706 |
jeremybenn |
------------------------------------------------------------------------------
|
2 |
|
|
-- --
|
3 |
|
|
-- GNAT COMPILER COMPONENTS --
|
4 |
|
|
-- --
|
5 |
|
|
-- E X P _ I N T R --
|
6 |
|
|
-- --
|
7 |
|
|
-- B o d y --
|
8 |
|
|
-- --
|
9 |
|
|
-- Copyright (C) 1992-2012, 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 Atree; use Atree;
|
27 |
|
|
with Checks; use Checks;
|
28 |
|
|
with Einfo; use Einfo;
|
29 |
|
|
with Elists; use Elists;
|
30 |
|
|
with Errout; use Errout;
|
31 |
|
|
with Exp_Atag; use Exp_Atag;
|
32 |
|
|
with Exp_Ch4; use Exp_Ch4;
|
33 |
|
|
with Exp_Ch7; use Exp_Ch7;
|
34 |
|
|
with Exp_Ch11; use Exp_Ch11;
|
35 |
|
|
with Exp_Code; use Exp_Code;
|
36 |
|
|
with Exp_Fixd; use Exp_Fixd;
|
37 |
|
|
with Exp_Util; use Exp_Util;
|
38 |
|
|
with Freeze; use Freeze;
|
39 |
|
|
with Namet; use Namet;
|
40 |
|
|
with Nmake; use Nmake;
|
41 |
|
|
with Nlists; use Nlists;
|
42 |
|
|
with Opt; use Opt;
|
43 |
|
|
with Restrict; use Restrict;
|
44 |
|
|
with Rident; use Rident;
|
45 |
|
|
with Rtsfind; use Rtsfind;
|
46 |
|
|
with Sem; use Sem;
|
47 |
|
|
with Sem_Eval; use Sem_Eval;
|
48 |
|
|
with Sem_Res; use Sem_Res;
|
49 |
|
|
with Sem_Type; use Sem_Type;
|
50 |
|
|
with Sem_Util; use Sem_Util;
|
51 |
|
|
with Sinfo; use Sinfo;
|
52 |
|
|
with Sinput; use Sinput;
|
53 |
|
|
with Snames; use Snames;
|
54 |
|
|
with Stand; use Stand;
|
55 |
|
|
with Stringt; use Stringt;
|
56 |
|
|
with Targparm; use Targparm;
|
57 |
|
|
with Tbuild; use Tbuild;
|
58 |
|
|
with Uintp; use Uintp;
|
59 |
|
|
with Urealp; use Urealp;
|
60 |
|
|
|
61 |
|
|
package body Exp_Intr is
|
62 |
|
|
|
63 |
|
|
-----------------------
|
64 |
|
|
-- Local Subprograms --
|
65 |
|
|
-----------------------
|
66 |
|
|
|
67 |
|
|
procedure Expand_Binary_Operator_Call (N : Node_Id);
|
68 |
|
|
-- Expand a call to an intrinsic arithmetic operator when the operand
|
69 |
|
|
-- types or sizes are not identical.
|
70 |
|
|
|
71 |
|
|
procedure Expand_Is_Negative (N : Node_Id);
|
72 |
|
|
-- Expand a call to the intrinsic Is_Negative function
|
73 |
|
|
|
74 |
|
|
procedure Expand_Dispatching_Constructor_Call (N : Node_Id);
|
75 |
|
|
-- Expand a call to an instantiation of Generic_Dispatching_Constructor
|
76 |
|
|
-- into a dispatching call to the actual subprogram associated with the
|
77 |
|
|
-- Constructor formal subprogram, passing it the Parameters actual of
|
78 |
|
|
-- the call to the instantiation and dispatching based on call's Tag
|
79 |
|
|
-- parameter.
|
80 |
|
|
|
81 |
|
|
procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id);
|
82 |
|
|
-- Expand a call to Exception_Information/Message/Name. The first
|
83 |
|
|
-- parameter, N, is the node for the function call, and Ent is the
|
84 |
|
|
-- entity for the corresponding routine in the Ada.Exceptions package.
|
85 |
|
|
|
86 |
|
|
procedure Expand_Import_Call (N : Node_Id);
|
87 |
|
|
-- Expand a call to Import_Address/Longest_Integer/Value. The parameter
|
88 |
|
|
-- N is the node for the function call.
|
89 |
|
|
|
90 |
|
|
procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind);
|
91 |
|
|
-- Expand an intrinsic shift operation, N and E are from the call to
|
92 |
|
|
-- Expand_Intrinsic_Call (call node and subprogram spec entity) and
|
93 |
|
|
-- K is the kind for the shift node
|
94 |
|
|
|
95 |
|
|
procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id);
|
96 |
|
|
-- Expand a call to an instantiation of Unchecked_Conversion into a node
|
97 |
|
|
-- N_Unchecked_Type_Conversion.
|
98 |
|
|
|
99 |
|
|
procedure Expand_Unc_Deallocation (N : Node_Id);
|
100 |
|
|
-- Expand a call to an instantiation of Unchecked_Deallocation into a node
|
101 |
|
|
-- N_Free_Statement and appropriate context.
|
102 |
|
|
|
103 |
|
|
procedure Expand_To_Address (N : Node_Id);
|
104 |
|
|
procedure Expand_To_Pointer (N : Node_Id);
|
105 |
|
|
-- Expand a call to corresponding function, declared in an instance of
|
106 |
|
|
-- System.Address_To_Access_Conversions.
|
107 |
|
|
|
108 |
|
|
procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id);
|
109 |
|
|
-- Rewrite the node by the appropriate string or positive constant.
|
110 |
|
|
-- Nam can be one of the following:
|
111 |
|
|
-- Name_File - expand string that is the name of source file
|
112 |
|
|
-- Name_Line - expand integer line number
|
113 |
|
|
-- Name_Source_Location - expand string of form file:line
|
114 |
|
|
-- Name_Enclosing_Entity - expand string with name of enclosing entity
|
115 |
|
|
|
116 |
|
|
---------------------------------
|
117 |
|
|
-- Expand_Binary_Operator_Call --
|
118 |
|
|
---------------------------------
|
119 |
|
|
|
120 |
|
|
procedure Expand_Binary_Operator_Call (N : Node_Id) is
|
121 |
|
|
T1 : constant Entity_Id := Underlying_Type (Etype (Left_Opnd (N)));
|
122 |
|
|
T2 : constant Entity_Id := Underlying_Type (Etype (Right_Opnd (N)));
|
123 |
|
|
TR : constant Entity_Id := Etype (N);
|
124 |
|
|
T3 : Entity_Id;
|
125 |
|
|
Res : Node_Id;
|
126 |
|
|
|
127 |
|
|
Siz : constant Uint := UI_Max (RM_Size (T1), RM_Size (T2));
|
128 |
|
|
-- Maximum of operand sizes
|
129 |
|
|
|
130 |
|
|
begin
|
131 |
|
|
-- Nothing to do if the operands have the same modular type
|
132 |
|
|
|
133 |
|
|
if Base_Type (T1) = Base_Type (T2)
|
134 |
|
|
and then Is_Modular_Integer_Type (T1)
|
135 |
|
|
then
|
136 |
|
|
return;
|
137 |
|
|
end if;
|
138 |
|
|
|
139 |
|
|
-- Use Unsigned_32 for sizes of 32 or below, else Unsigned_64
|
140 |
|
|
|
141 |
|
|
if Siz > 32 then
|
142 |
|
|
T3 := RTE (RE_Unsigned_64);
|
143 |
|
|
else
|
144 |
|
|
T3 := RTE (RE_Unsigned_32);
|
145 |
|
|
end if;
|
146 |
|
|
|
147 |
|
|
-- Copy operator node, and reset type and entity fields, for
|
148 |
|
|
-- subsequent reanalysis.
|
149 |
|
|
|
150 |
|
|
Res := New_Copy (N);
|
151 |
|
|
Set_Etype (Res, T3);
|
152 |
|
|
|
153 |
|
|
case Nkind (N) is
|
154 |
|
|
when N_Op_And =>
|
155 |
|
|
Set_Entity (Res, Standard_Op_And);
|
156 |
|
|
when N_Op_Or =>
|
157 |
|
|
Set_Entity (Res, Standard_Op_Or);
|
158 |
|
|
when N_Op_Xor =>
|
159 |
|
|
Set_Entity (Res, Standard_Op_Xor);
|
160 |
|
|
when others =>
|
161 |
|
|
raise Program_Error;
|
162 |
|
|
end case;
|
163 |
|
|
|
164 |
|
|
-- Convert operands to large enough intermediate type
|
165 |
|
|
|
166 |
|
|
Set_Left_Opnd (Res,
|
167 |
|
|
Unchecked_Convert_To (T3, Relocate_Node (Left_Opnd (N))));
|
168 |
|
|
Set_Right_Opnd (Res,
|
169 |
|
|
Unchecked_Convert_To (T3, Relocate_Node (Right_Opnd (N))));
|
170 |
|
|
|
171 |
|
|
-- Analyze and resolve result formed by conversion to target type
|
172 |
|
|
|
173 |
|
|
Rewrite (N, Unchecked_Convert_To (TR, Res));
|
174 |
|
|
Analyze_And_Resolve (N, TR);
|
175 |
|
|
end Expand_Binary_Operator_Call;
|
176 |
|
|
|
177 |
|
|
-----------------------------------------
|
178 |
|
|
-- Expand_Dispatching_Constructor_Call --
|
179 |
|
|
-----------------------------------------
|
180 |
|
|
|
181 |
|
|
-- Transform a call to an instantiation of Generic_Dispatching_Constructor
|
182 |
|
|
-- of the form:
|
183 |
|
|
|
184 |
|
|
-- GDC_Instance (The_Tag, Parameters'Access)
|
185 |
|
|
|
186 |
|
|
-- to a class-wide conversion of a dispatching call to the actual
|
187 |
|
|
-- associated with the formal subprogram Construct, designating The_Tag
|
188 |
|
|
-- as the controlling tag of the call:
|
189 |
|
|
|
190 |
|
|
-- T'Class (Construct'Actual (Params)) -- Controlling tag is The_Tag
|
191 |
|
|
|
192 |
|
|
-- which will eventually be expanded to the following:
|
193 |
|
|
|
194 |
|
|
-- T'Class (The_Tag.all (Construct'Actual'Index).all (Params))
|
195 |
|
|
|
196 |
|
|
-- A class-wide membership test is also generated, preceding the call, to
|
197 |
|
|
-- ensure that the controlling tag denotes a type in T'Class.
|
198 |
|
|
|
199 |
|
|
procedure Expand_Dispatching_Constructor_Call (N : Node_Id) is
|
200 |
|
|
Loc : constant Source_Ptr := Sloc (N);
|
201 |
|
|
Tag_Arg : constant Node_Id := First_Actual (N);
|
202 |
|
|
Param_Arg : constant Node_Id := Next_Actual (Tag_Arg);
|
203 |
|
|
Subp_Decl : constant Node_Id := Parent (Parent (Entity (Name (N))));
|
204 |
|
|
Inst_Pkg : constant Node_Id := Parent (Subp_Decl);
|
205 |
|
|
Act_Rename : Node_Id;
|
206 |
|
|
Act_Constr : Entity_Id;
|
207 |
|
|
Iface_Tag : Node_Id := Empty;
|
208 |
|
|
Cnstr_Call : Node_Id;
|
209 |
|
|
Result_Typ : Entity_Id;
|
210 |
|
|
|
211 |
|
|
begin
|
212 |
|
|
-- The subprogram is the third actual in the instantiation, and is
|
213 |
|
|
-- retrieved from the corresponding renaming declaration. However,
|
214 |
|
|
-- freeze nodes may appear before, so we retrieve the declaration
|
215 |
|
|
-- with an explicit loop.
|
216 |
|
|
|
217 |
|
|
Act_Rename := First (Visible_Declarations (Inst_Pkg));
|
218 |
|
|
while Nkind (Act_Rename) /= N_Subprogram_Renaming_Declaration loop
|
219 |
|
|
Next (Act_Rename);
|
220 |
|
|
end loop;
|
221 |
|
|
|
222 |
|
|
Act_Constr := Entity (Name (Act_Rename));
|
223 |
|
|
Result_Typ := Class_Wide_Type (Etype (Act_Constr));
|
224 |
|
|
|
225 |
|
|
-- Ada 2005 (AI-251): If the result is an interface type, the function
|
226 |
|
|
-- returns a class-wide interface type (otherwise the resulting object
|
227 |
|
|
-- would be abstract!)
|
228 |
|
|
|
229 |
|
|
if Is_Interface (Etype (Act_Constr)) then
|
230 |
|
|
Set_Etype (Act_Constr, Result_Typ);
|
231 |
|
|
|
232 |
|
|
-- If the result type is not parent of Tag_Arg then we need to
|
233 |
|
|
-- locate the tag of the secondary dispatch table.
|
234 |
|
|
|
235 |
|
|
if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg),
|
236 |
|
|
Use_Full_View => True)
|
237 |
|
|
and then Tagged_Type_Expansion
|
238 |
|
|
then
|
239 |
|
|
-- Obtain the reference to the Ada.Tags service before generating
|
240 |
|
|
-- the Object_Declaration node to ensure that if this service is
|
241 |
|
|
-- not available in the runtime then we generate a clear error.
|
242 |
|
|
|
243 |
|
|
declare
|
244 |
|
|
Fname : constant Node_Id :=
|
245 |
|
|
New_Reference_To (RTE (RE_Secondary_Tag), Loc);
|
246 |
|
|
|
247 |
|
|
begin
|
248 |
|
|
pragma Assert (not Is_Interface (Etype (Tag_Arg)));
|
249 |
|
|
|
250 |
|
|
Iface_Tag :=
|
251 |
|
|
Make_Object_Declaration (Loc,
|
252 |
|
|
Defining_Identifier => Make_Temporary (Loc, 'V'),
|
253 |
|
|
Object_Definition =>
|
254 |
|
|
New_Reference_To (RTE (RE_Tag), Loc),
|
255 |
|
|
Expression =>
|
256 |
|
|
Make_Function_Call (Loc,
|
257 |
|
|
Name => Fname,
|
258 |
|
|
Parameter_Associations => New_List (
|
259 |
|
|
Relocate_Node (Tag_Arg),
|
260 |
|
|
New_Reference_To
|
261 |
|
|
(Node (First_Elmt (Access_Disp_Table
|
262 |
|
|
(Etype (Etype (Act_Constr))))),
|
263 |
|
|
Loc))));
|
264 |
|
|
Insert_Action (N, Iface_Tag);
|
265 |
|
|
end;
|
266 |
|
|
end if;
|
267 |
|
|
end if;
|
268 |
|
|
|
269 |
|
|
-- Create the call to the actual Constructor function
|
270 |
|
|
|
271 |
|
|
Cnstr_Call :=
|
272 |
|
|
Make_Function_Call (Loc,
|
273 |
|
|
Name => New_Occurrence_Of (Act_Constr, Loc),
|
274 |
|
|
Parameter_Associations => New_List (Relocate_Node (Param_Arg)));
|
275 |
|
|
|
276 |
|
|
-- Establish its controlling tag from the tag passed to the instance
|
277 |
|
|
-- The tag may be given by a function call, in which case a temporary
|
278 |
|
|
-- should be generated now, to prevent out-of-order insertions during
|
279 |
|
|
-- the expansion of that call when stack-checking is enabled.
|
280 |
|
|
|
281 |
|
|
if Present (Iface_Tag) then
|
282 |
|
|
Set_Controlling_Argument (Cnstr_Call,
|
283 |
|
|
New_Occurrence_Of (Defining_Identifier (Iface_Tag), Loc));
|
284 |
|
|
else
|
285 |
|
|
Remove_Side_Effects (Tag_Arg);
|
286 |
|
|
Set_Controlling_Argument (Cnstr_Call,
|
287 |
|
|
Relocate_Node (Tag_Arg));
|
288 |
|
|
end if;
|
289 |
|
|
|
290 |
|
|
-- Rewrite and analyze the call to the instance as a class-wide
|
291 |
|
|
-- conversion of the call to the actual constructor.
|
292 |
|
|
|
293 |
|
|
Rewrite (N, Convert_To (Result_Typ, Cnstr_Call));
|
294 |
|
|
Analyze_And_Resolve (N, Etype (Act_Constr));
|
295 |
|
|
|
296 |
|
|
-- Do not generate a run-time check on the built object if tag
|
297 |
|
|
-- checks are suppressed for the result type or VM_Target /= No_VM
|
298 |
|
|
|
299 |
|
|
if Tag_Checks_Suppressed (Etype (Result_Typ))
|
300 |
|
|
or else not Tagged_Type_Expansion
|
301 |
|
|
then
|
302 |
|
|
null;
|
303 |
|
|
|
304 |
|
|
-- Generate a class-wide membership test to ensure that the call's tag
|
305 |
|
|
-- argument denotes a type within the class. We must keep separate the
|
306 |
|
|
-- case in which the Result_Type of the constructor function is a tagged
|
307 |
|
|
-- type from the case in which it is an abstract interface because the
|
308 |
|
|
-- run-time subprogram required to check these cases differ (and have
|
309 |
|
|
-- one difference in their parameters profile).
|
310 |
|
|
|
311 |
|
|
-- Call CW_Membership if the Result_Type is a tagged type to look for
|
312 |
|
|
-- the tag in the table of ancestor tags.
|
313 |
|
|
|
314 |
|
|
elsif not Is_Interface (Result_Typ) then
|
315 |
|
|
declare
|
316 |
|
|
Obj_Tag_Node : Node_Id := Duplicate_Subexpr (Tag_Arg);
|
317 |
|
|
CW_Test_Node : Node_Id;
|
318 |
|
|
|
319 |
|
|
begin
|
320 |
|
|
Build_CW_Membership (Loc,
|
321 |
|
|
Obj_Tag_Node => Obj_Tag_Node,
|
322 |
|
|
Typ_Tag_Node =>
|
323 |
|
|
New_Reference_To (
|
324 |
|
|
Node (First_Elmt (Access_Disp_Table (
|
325 |
|
|
Root_Type (Result_Typ)))), Loc),
|
326 |
|
|
Related_Nod => N,
|
327 |
|
|
New_Node => CW_Test_Node);
|
328 |
|
|
|
329 |
|
|
Insert_Action (N,
|
330 |
|
|
Make_Implicit_If_Statement (N,
|
331 |
|
|
Condition =>
|
332 |
|
|
Make_Op_Not (Loc, CW_Test_Node),
|
333 |
|
|
Then_Statements =>
|
334 |
|
|
New_List (Make_Raise_Statement (Loc,
|
335 |
|
|
New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
|
336 |
|
|
end;
|
337 |
|
|
|
338 |
|
|
-- Call IW_Membership test if the Result_Type is an abstract interface
|
339 |
|
|
-- to look for the tag in the table of interface tags.
|
340 |
|
|
|
341 |
|
|
else
|
342 |
|
|
Insert_Action (N,
|
343 |
|
|
Make_Implicit_If_Statement (N,
|
344 |
|
|
Condition =>
|
345 |
|
|
Make_Op_Not (Loc,
|
346 |
|
|
Make_Function_Call (Loc,
|
347 |
|
|
Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
|
348 |
|
|
Parameter_Associations => New_List (
|
349 |
|
|
Make_Attribute_Reference (Loc,
|
350 |
|
|
Prefix => Duplicate_Subexpr (Tag_Arg),
|
351 |
|
|
Attribute_Name => Name_Address),
|
352 |
|
|
|
353 |
|
|
New_Reference_To (
|
354 |
|
|
Node (First_Elmt (Access_Disp_Table (
|
355 |
|
|
Root_Type (Result_Typ)))), Loc)))),
|
356 |
|
|
Then_Statements =>
|
357 |
|
|
New_List (
|
358 |
|
|
Make_Raise_Statement (Loc,
|
359 |
|
|
Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
|
360 |
|
|
end if;
|
361 |
|
|
end Expand_Dispatching_Constructor_Call;
|
362 |
|
|
|
363 |
|
|
---------------------------
|
364 |
|
|
-- Expand_Exception_Call --
|
365 |
|
|
---------------------------
|
366 |
|
|
|
367 |
|
|
-- If the function call is not within an exception handler, then the call
|
368 |
|
|
-- is replaced by a null string. Otherwise the appropriate routine in
|
369 |
|
|
-- Ada.Exceptions is called passing the choice parameter specification
|
370 |
|
|
-- from the enclosing handler. If the enclosing handler lacks a choice
|
371 |
|
|
-- parameter, then one is supplied.
|
372 |
|
|
|
373 |
|
|
procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is
|
374 |
|
|
Loc : constant Source_Ptr := Sloc (N);
|
375 |
|
|
P : Node_Id;
|
376 |
|
|
E : Entity_Id;
|
377 |
|
|
|
378 |
|
|
begin
|
379 |
|
|
-- Climb up parents to see if we are in exception handler
|
380 |
|
|
|
381 |
|
|
P := Parent (N);
|
382 |
|
|
loop
|
383 |
|
|
-- Case of not in exception handler, replace by null string
|
384 |
|
|
|
385 |
|
|
if No (P) then
|
386 |
|
|
Rewrite (N,
|
387 |
|
|
Make_String_Literal (Loc,
|
388 |
|
|
Strval => ""));
|
389 |
|
|
exit;
|
390 |
|
|
|
391 |
|
|
-- Case of in exception handler
|
392 |
|
|
|
393 |
|
|
elsif Nkind (P) = N_Exception_Handler then
|
394 |
|
|
|
395 |
|
|
-- Handler cannot be used for a local raise, and furthermore, this
|
396 |
|
|
-- is a violation of the No_Exception_Propagation restriction.
|
397 |
|
|
|
398 |
|
|
Set_Local_Raise_Not_OK (P);
|
399 |
|
|
Check_Restriction (No_Exception_Propagation, N);
|
400 |
|
|
|
401 |
|
|
-- If no choice parameter present, then put one there. Note that
|
402 |
|
|
-- we do not need to put it on the entity chain, since no one will
|
403 |
|
|
-- be referencing it by normal visibility methods.
|
404 |
|
|
|
405 |
|
|
if No (Choice_Parameter (P)) then
|
406 |
|
|
E := Make_Temporary (Loc, 'E');
|
407 |
|
|
Set_Choice_Parameter (P, E);
|
408 |
|
|
Set_Ekind (E, E_Variable);
|
409 |
|
|
Set_Etype (E, RTE (RE_Exception_Occurrence));
|
410 |
|
|
Set_Scope (E, Current_Scope);
|
411 |
|
|
end if;
|
412 |
|
|
|
413 |
|
|
Rewrite (N,
|
414 |
|
|
Make_Function_Call (Loc,
|
415 |
|
|
Name => New_Occurrence_Of (RTE (Ent), Loc),
|
416 |
|
|
Parameter_Associations => New_List (
|
417 |
|
|
New_Occurrence_Of (Choice_Parameter (P), Loc))));
|
418 |
|
|
exit;
|
419 |
|
|
|
420 |
|
|
-- Keep climbing!
|
421 |
|
|
|
422 |
|
|
else
|
423 |
|
|
P := Parent (P);
|
424 |
|
|
end if;
|
425 |
|
|
end loop;
|
426 |
|
|
|
427 |
|
|
Analyze_And_Resolve (N, Standard_String);
|
428 |
|
|
end Expand_Exception_Call;
|
429 |
|
|
|
430 |
|
|
------------------------
|
431 |
|
|
-- Expand_Import_Call --
|
432 |
|
|
------------------------
|
433 |
|
|
|
434 |
|
|
-- The function call must have a static string as its argument. We create
|
435 |
|
|
-- a dummy variable which uses this string as the external name in an
|
436 |
|
|
-- Import pragma. The result is then obtained as the address of this
|
437 |
|
|
-- dummy variable, converted to the appropriate target type.
|
438 |
|
|
|
439 |
|
|
procedure Expand_Import_Call (N : Node_Id) is
|
440 |
|
|
Loc : constant Source_Ptr := Sloc (N);
|
441 |
|
|
Ent : constant Entity_Id := Entity (Name (N));
|
442 |
|
|
Str : constant Node_Id := First_Actual (N);
|
443 |
|
|
Dum : constant Entity_Id := Make_Temporary (Loc, 'D');
|
444 |
|
|
|
445 |
|
|
begin
|
446 |
|
|
Insert_Actions (N, New_List (
|
447 |
|
|
Make_Object_Declaration (Loc,
|
448 |
|
|
Defining_Identifier => Dum,
|
449 |
|
|
Object_Definition =>
|
450 |
|
|
New_Occurrence_Of (Standard_Character, Loc)),
|
451 |
|
|
|
452 |
|
|
Make_Pragma (Loc,
|
453 |
|
|
Chars => Name_Import,
|
454 |
|
|
Pragma_Argument_Associations => New_List (
|
455 |
|
|
Make_Pragma_Argument_Association (Loc,
|
456 |
|
|
Expression => Make_Identifier (Loc, Name_Ada)),
|
457 |
|
|
|
458 |
|
|
Make_Pragma_Argument_Association (Loc,
|
459 |
|
|
Expression => Make_Identifier (Loc, Chars (Dum))),
|
460 |
|
|
|
461 |
|
|
Make_Pragma_Argument_Association (Loc,
|
462 |
|
|
Chars => Name_Link_Name,
|
463 |
|
|
Expression => Relocate_Node (Str))))));
|
464 |
|
|
|
465 |
|
|
Rewrite (N,
|
466 |
|
|
Unchecked_Convert_To (Etype (Ent),
|
467 |
|
|
Make_Attribute_Reference (Loc,
|
468 |
|
|
Prefix => Make_Identifier (Loc, Chars (Dum)),
|
469 |
|
|
Attribute_Name => Name_Address)));
|
470 |
|
|
|
471 |
|
|
Analyze_And_Resolve (N, Etype (Ent));
|
472 |
|
|
end Expand_Import_Call;
|
473 |
|
|
|
474 |
|
|
---------------------------
|
475 |
|
|
-- Expand_Intrinsic_Call --
|
476 |
|
|
---------------------------
|
477 |
|
|
|
478 |
|
|
procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is
|
479 |
|
|
Nam : Name_Id;
|
480 |
|
|
|
481 |
|
|
begin
|
482 |
|
|
-- If an external name is specified for the intrinsic, it is handled
|
483 |
|
|
-- by the back-end: leave the call node unchanged for now.
|
484 |
|
|
|
485 |
|
|
if Present (Interface_Name (E)) then
|
486 |
|
|
return;
|
487 |
|
|
end if;
|
488 |
|
|
|
489 |
|
|
-- If the intrinsic subprogram is generic, gets its original name
|
490 |
|
|
|
491 |
|
|
if Present (Parent (E))
|
492 |
|
|
and then Present (Generic_Parent (Parent (E)))
|
493 |
|
|
then
|
494 |
|
|
Nam := Chars (Generic_Parent (Parent (E)));
|
495 |
|
|
else
|
496 |
|
|
Nam := Chars (E);
|
497 |
|
|
end if;
|
498 |
|
|
|
499 |
|
|
if Nam = Name_Asm then
|
500 |
|
|
Expand_Asm_Call (N);
|
501 |
|
|
|
502 |
|
|
elsif Nam = Name_Divide then
|
503 |
|
|
Expand_Decimal_Divide_Call (N);
|
504 |
|
|
|
505 |
|
|
elsif Nam = Name_Exception_Information then
|
506 |
|
|
Expand_Exception_Call (N, RE_Exception_Information);
|
507 |
|
|
|
508 |
|
|
elsif Nam = Name_Exception_Message then
|
509 |
|
|
Expand_Exception_Call (N, RE_Exception_Message);
|
510 |
|
|
|
511 |
|
|
elsif Nam = Name_Exception_Name then
|
512 |
|
|
Expand_Exception_Call (N, RE_Exception_Name_Simple);
|
513 |
|
|
|
514 |
|
|
elsif Nam = Name_Generic_Dispatching_Constructor then
|
515 |
|
|
Expand_Dispatching_Constructor_Call (N);
|
516 |
|
|
|
517 |
|
|
elsif Nam = Name_Import_Address
|
518 |
|
|
or else
|
519 |
|
|
Nam = Name_Import_Largest_Value
|
520 |
|
|
or else
|
521 |
|
|
Nam = Name_Import_Value
|
522 |
|
|
then
|
523 |
|
|
Expand_Import_Call (N);
|
524 |
|
|
|
525 |
|
|
elsif Nam = Name_Is_Negative then
|
526 |
|
|
Expand_Is_Negative (N);
|
527 |
|
|
|
528 |
|
|
elsif Nam = Name_Rotate_Left then
|
529 |
|
|
Expand_Shift (N, E, N_Op_Rotate_Left);
|
530 |
|
|
|
531 |
|
|
elsif Nam = Name_Rotate_Right then
|
532 |
|
|
Expand_Shift (N, E, N_Op_Rotate_Right);
|
533 |
|
|
|
534 |
|
|
elsif Nam = Name_Shift_Left then
|
535 |
|
|
Expand_Shift (N, E, N_Op_Shift_Left);
|
536 |
|
|
|
537 |
|
|
elsif Nam = Name_Shift_Right then
|
538 |
|
|
Expand_Shift (N, E, N_Op_Shift_Right);
|
539 |
|
|
|
540 |
|
|
elsif Nam = Name_Shift_Right_Arithmetic then
|
541 |
|
|
Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic);
|
542 |
|
|
|
543 |
|
|
elsif Nam = Name_Unchecked_Conversion then
|
544 |
|
|
Expand_Unc_Conversion (N, E);
|
545 |
|
|
|
546 |
|
|
elsif Nam = Name_Unchecked_Deallocation then
|
547 |
|
|
Expand_Unc_Deallocation (N);
|
548 |
|
|
|
549 |
|
|
elsif Nam = Name_To_Address then
|
550 |
|
|
Expand_To_Address (N);
|
551 |
|
|
|
552 |
|
|
elsif Nam = Name_To_Pointer then
|
553 |
|
|
Expand_To_Pointer (N);
|
554 |
|
|
|
555 |
|
|
elsif Nam = Name_File
|
556 |
|
|
or else Nam = Name_Line
|
557 |
|
|
or else Nam = Name_Source_Location
|
558 |
|
|
or else Nam = Name_Enclosing_Entity
|
559 |
|
|
then
|
560 |
|
|
Expand_Source_Info (N, Nam);
|
561 |
|
|
|
562 |
|
|
-- If we have a renaming, expand the call to the original operation,
|
563 |
|
|
-- which must itself be intrinsic, since renaming requires matching
|
564 |
|
|
-- conventions and this has already been checked.
|
565 |
|
|
|
566 |
|
|
elsif Present (Alias (E)) then
|
567 |
|
|
Expand_Intrinsic_Call (N, Alias (E));
|
568 |
|
|
|
569 |
|
|
elsif Nkind (N) in N_Binary_Op then
|
570 |
|
|
Expand_Binary_Operator_Call (N);
|
571 |
|
|
|
572 |
|
|
-- The only other case is where an external name was specified,
|
573 |
|
|
-- since this is the only way that an otherwise unrecognized
|
574 |
|
|
-- name could escape the checking in Sem_Prag. Nothing needs
|
575 |
|
|
-- to be done in such a case, since we pass such a call to the
|
576 |
|
|
-- back end unchanged.
|
577 |
|
|
|
578 |
|
|
else
|
579 |
|
|
null;
|
580 |
|
|
end if;
|
581 |
|
|
end Expand_Intrinsic_Call;
|
582 |
|
|
|
583 |
|
|
------------------------
|
584 |
|
|
-- Expand_Is_Negative --
|
585 |
|
|
------------------------
|
586 |
|
|
|
587 |
|
|
procedure Expand_Is_Negative (N : Node_Id) is
|
588 |
|
|
Loc : constant Source_Ptr := Sloc (N);
|
589 |
|
|
Opnd : constant Node_Id := Relocate_Node (First_Actual (N));
|
590 |
|
|
|
591 |
|
|
begin
|
592 |
|
|
|
593 |
|
|
-- We replace the function call by the following expression
|
594 |
|
|
|
595 |
|
|
-- if Opnd < 0.0 then
|
596 |
|
|
-- True
|
597 |
|
|
-- else
|
598 |
|
|
-- if Opnd > 0.0 then
|
599 |
|
|
-- False;
|
600 |
|
|
-- else
|
601 |
|
|
-- Float_Unsigned!(Float (Opnd)) /= 0
|
602 |
|
|
-- end if;
|
603 |
|
|
-- end if;
|
604 |
|
|
|
605 |
|
|
Rewrite (N,
|
606 |
|
|
Make_Conditional_Expression (Loc,
|
607 |
|
|
Expressions => New_List (
|
608 |
|
|
Make_Op_Lt (Loc,
|
609 |
|
|
Left_Opnd => Duplicate_Subexpr (Opnd),
|
610 |
|
|
Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
|
611 |
|
|
|
612 |
|
|
New_Occurrence_Of (Standard_True, Loc),
|
613 |
|
|
|
614 |
|
|
Make_Conditional_Expression (Loc,
|
615 |
|
|
Expressions => New_List (
|
616 |
|
|
Make_Op_Gt (Loc,
|
617 |
|
|
Left_Opnd => Duplicate_Subexpr_No_Checks (Opnd),
|
618 |
|
|
Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
|
619 |
|
|
|
620 |
|
|
New_Occurrence_Of (Standard_False, Loc),
|
621 |
|
|
|
622 |
|
|
Make_Op_Ne (Loc,
|
623 |
|
|
Left_Opnd =>
|
624 |
|
|
Unchecked_Convert_To
|
625 |
|
|
(RTE (RE_Float_Unsigned),
|
626 |
|
|
Convert_To
|
627 |
|
|
(Standard_Float,
|
628 |
|
|
Duplicate_Subexpr_No_Checks (Opnd))),
|
629 |
|
|
Right_Opnd =>
|
630 |
|
|
Make_Integer_Literal (Loc, 0)))))));
|
631 |
|
|
|
632 |
|
|
Analyze_And_Resolve (N, Standard_Boolean);
|
633 |
|
|
end Expand_Is_Negative;
|
634 |
|
|
|
635 |
|
|
------------------
|
636 |
|
|
-- Expand_Shift --
|
637 |
|
|
------------------
|
638 |
|
|
|
639 |
|
|
-- This procedure is used to convert a call to a shift function to the
|
640 |
|
|
-- corresponding operator node. This conversion is not done by the usual
|
641 |
|
|
-- circuit for converting calls to operator functions (e.g. "+"(1,2)) to
|
642 |
|
|
-- operator nodes, because shifts are not predefined operators.
|
643 |
|
|
|
644 |
|
|
-- As a result, whenever a shift is used in the source program, it will
|
645 |
|
|
-- remain as a call until converted by this routine to the operator node
|
646 |
|
|
-- form which Gigi is expecting to see.
|
647 |
|
|
|
648 |
|
|
-- Note: it is possible for the expander to generate shift operator nodes
|
649 |
|
|
-- directly, which will be analyzed in the normal manner by calling Analyze
|
650 |
|
|
-- and Resolve. Such shift operator nodes will not be seen by Expand_Shift.
|
651 |
|
|
|
652 |
|
|
procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is
|
653 |
|
|
Loc : constant Source_Ptr := Sloc (N);
|
654 |
|
|
Typ : constant Entity_Id := Etype (N);
|
655 |
|
|
Left : constant Node_Id := First_Actual (N);
|
656 |
|
|
Right : constant Node_Id := Next_Actual (Left);
|
657 |
|
|
Ltyp : constant Node_Id := Etype (Left);
|
658 |
|
|
Rtyp : constant Node_Id := Etype (Right);
|
659 |
|
|
Snode : Node_Id;
|
660 |
|
|
|
661 |
|
|
begin
|
662 |
|
|
Snode := New_Node (K, Loc);
|
663 |
|
|
Set_Left_Opnd (Snode, Relocate_Node (Left));
|
664 |
|
|
Set_Right_Opnd (Snode, Relocate_Node (Right));
|
665 |
|
|
Set_Chars (Snode, Chars (E));
|
666 |
|
|
Set_Etype (Snode, Base_Type (Typ));
|
667 |
|
|
Set_Entity (Snode, E);
|
668 |
|
|
|
669 |
|
|
if Compile_Time_Known_Value (Type_High_Bound (Rtyp))
|
670 |
|
|
and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp)
|
671 |
|
|
then
|
672 |
|
|
Set_Shift_Count_OK (Snode, True);
|
673 |
|
|
end if;
|
674 |
|
|
|
675 |
|
|
-- Do the rewrite. Note that we don't call Analyze and Resolve on
|
676 |
|
|
-- this node, because it already got analyzed and resolved when
|
677 |
|
|
-- it was a function call!
|
678 |
|
|
|
679 |
|
|
Rewrite (N, Snode);
|
680 |
|
|
Set_Analyzed (N);
|
681 |
|
|
end Expand_Shift;
|
682 |
|
|
|
683 |
|
|
------------------------
|
684 |
|
|
-- Expand_Source_Info --
|
685 |
|
|
------------------------
|
686 |
|
|
|
687 |
|
|
procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is
|
688 |
|
|
Loc : constant Source_Ptr := Sloc (N);
|
689 |
|
|
Ent : Entity_Id;
|
690 |
|
|
|
691 |
|
|
procedure Write_Entity_Name (E : Entity_Id);
|
692 |
|
|
-- Recursive procedure to construct string for qualified name of
|
693 |
|
|
-- enclosing program unit. The qualification stops at an enclosing
|
694 |
|
|
-- scope has no source name (block or loop). If entity is a subprogram
|
695 |
|
|
-- instance, skip enclosing wrapper package.
|
696 |
|
|
|
697 |
|
|
-----------------------
|
698 |
|
|
-- Write_Entity_Name --
|
699 |
|
|
-----------------------
|
700 |
|
|
|
701 |
|
|
procedure Write_Entity_Name (E : Entity_Id) is
|
702 |
|
|
SDef : Source_Ptr;
|
703 |
|
|
TDef : constant Source_Buffer_Ptr :=
|
704 |
|
|
Source_Text (Get_Source_File_Index (Sloc (E)));
|
705 |
|
|
|
706 |
|
|
begin
|
707 |
|
|
-- Nothing to do if at outer level
|
708 |
|
|
|
709 |
|
|
if Scope (E) = Standard_Standard then
|
710 |
|
|
null;
|
711 |
|
|
|
712 |
|
|
-- If scope comes from source, write its name
|
713 |
|
|
|
714 |
|
|
elsif Comes_From_Source (Scope (E)) then
|
715 |
|
|
Write_Entity_Name (Scope (E));
|
716 |
|
|
Add_Char_To_Name_Buffer ('.');
|
717 |
|
|
|
718 |
|
|
-- If in wrapper package skip past it
|
719 |
|
|
|
720 |
|
|
elsif Is_Wrapper_Package (Scope (E)) then
|
721 |
|
|
Write_Entity_Name (Scope (Scope (E)));
|
722 |
|
|
Add_Char_To_Name_Buffer ('.');
|
723 |
|
|
|
724 |
|
|
-- Otherwise nothing to output (happens in unnamed block statements)
|
725 |
|
|
|
726 |
|
|
else
|
727 |
|
|
null;
|
728 |
|
|
end if;
|
729 |
|
|
|
730 |
|
|
-- Loop to output the name
|
731 |
|
|
|
732 |
|
|
-- is this right wrt wide char encodings ??? (no!)
|
733 |
|
|
|
734 |
|
|
SDef := Sloc (E);
|
735 |
|
|
while TDef (SDef) in '0' .. '9'
|
736 |
|
|
or else TDef (SDef) >= 'A'
|
737 |
|
|
or else TDef (SDef) = ASCII.ESC
|
738 |
|
|
loop
|
739 |
|
|
Add_Char_To_Name_Buffer (TDef (SDef));
|
740 |
|
|
SDef := SDef + 1;
|
741 |
|
|
end loop;
|
742 |
|
|
end Write_Entity_Name;
|
743 |
|
|
|
744 |
|
|
-- Start of processing for Expand_Source_Info
|
745 |
|
|
|
746 |
|
|
begin
|
747 |
|
|
-- Integer cases
|
748 |
|
|
|
749 |
|
|
if Nam = Name_Line then
|
750 |
|
|
Rewrite (N,
|
751 |
|
|
Make_Integer_Literal (Loc,
|
752 |
|
|
Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc)))));
|
753 |
|
|
Analyze_And_Resolve (N, Standard_Positive);
|
754 |
|
|
|
755 |
|
|
-- String cases
|
756 |
|
|
|
757 |
|
|
else
|
758 |
|
|
Name_Len := 0;
|
759 |
|
|
|
760 |
|
|
case Nam is
|
761 |
|
|
when Name_File =>
|
762 |
|
|
Get_Decoded_Name_String
|
763 |
|
|
(Reference_Name (Get_Source_File_Index (Loc)));
|
764 |
|
|
|
765 |
|
|
when Name_Source_Location =>
|
766 |
|
|
Build_Location_String (Loc);
|
767 |
|
|
|
768 |
|
|
when Name_Enclosing_Entity =>
|
769 |
|
|
|
770 |
|
|
-- Skip enclosing blocks to reach enclosing unit
|
771 |
|
|
|
772 |
|
|
Ent := Current_Scope;
|
773 |
|
|
while Present (Ent) loop
|
774 |
|
|
exit when Ekind (Ent) /= E_Block
|
775 |
|
|
and then Ekind (Ent) /= E_Loop;
|
776 |
|
|
Ent := Scope (Ent);
|
777 |
|
|
end loop;
|
778 |
|
|
|
779 |
|
|
-- Ent now points to the relevant defining entity
|
780 |
|
|
|
781 |
|
|
Write_Entity_Name (Ent);
|
782 |
|
|
|
783 |
|
|
when others =>
|
784 |
|
|
raise Program_Error;
|
785 |
|
|
end case;
|
786 |
|
|
|
787 |
|
|
Rewrite (N,
|
788 |
|
|
Make_String_Literal (Loc,
|
789 |
|
|
Strval => String_From_Name_Buffer));
|
790 |
|
|
Analyze_And_Resolve (N, Standard_String);
|
791 |
|
|
end if;
|
792 |
|
|
|
793 |
|
|
Set_Is_Static_Expression (N);
|
794 |
|
|
end Expand_Source_Info;
|
795 |
|
|
|
796 |
|
|
---------------------------
|
797 |
|
|
-- Expand_Unc_Conversion --
|
798 |
|
|
---------------------------
|
799 |
|
|
|
800 |
|
|
procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is
|
801 |
|
|
Func : constant Entity_Id := Entity (Name (N));
|
802 |
|
|
Conv : Node_Id;
|
803 |
|
|
Ftyp : Entity_Id;
|
804 |
|
|
Ttyp : Entity_Id;
|
805 |
|
|
|
806 |
|
|
begin
|
807 |
|
|
-- Rewrite as unchecked conversion node. Note that we must convert
|
808 |
|
|
-- the operand to the formal type of the input parameter of the
|
809 |
|
|
-- function, so that the resulting N_Unchecked_Type_Conversion
|
810 |
|
|
-- call indicates the correct types for Gigi.
|
811 |
|
|
|
812 |
|
|
-- Right now, we only do this if a scalar type is involved. It is
|
813 |
|
|
-- not clear if it is needed in other cases. If we do attempt to
|
814 |
|
|
-- do the conversion unconditionally, it crashes 3411-018. To be
|
815 |
|
|
-- investigated further ???
|
816 |
|
|
|
817 |
|
|
Conv := Relocate_Node (First_Actual (N));
|
818 |
|
|
Ftyp := Etype (First_Formal (Func));
|
819 |
|
|
|
820 |
|
|
if Is_Scalar_Type (Ftyp) then
|
821 |
|
|
Conv := Convert_To (Ftyp, Conv);
|
822 |
|
|
Set_Parent (Conv, N);
|
823 |
|
|
Analyze_And_Resolve (Conv);
|
824 |
|
|
end if;
|
825 |
|
|
|
826 |
|
|
-- The instantiation of Unchecked_Conversion creates a wrapper package,
|
827 |
|
|
-- and the target type is declared as a subtype of the actual. Recover
|
828 |
|
|
-- the actual, which is the subtype indic. in the subtype declaration
|
829 |
|
|
-- for the target type. This is semantically correct, and avoids
|
830 |
|
|
-- anomalies with access subtypes. For entities, leave type as is.
|
831 |
|
|
|
832 |
|
|
-- We do the analysis here, because we do not want the compiler
|
833 |
|
|
-- to try to optimize or otherwise reorganize the unchecked
|
834 |
|
|
-- conversion node.
|
835 |
|
|
|
836 |
|
|
Ttyp := Etype (E);
|
837 |
|
|
|
838 |
|
|
if Is_Entity_Name (Conv) then
|
839 |
|
|
null;
|
840 |
|
|
|
841 |
|
|
elsif Nkind (Parent (Ttyp)) = N_Subtype_Declaration then
|
842 |
|
|
Ttyp := Entity (Subtype_Indication (Parent (Etype (E))));
|
843 |
|
|
|
844 |
|
|
elsif Is_Itype (Ttyp) then
|
845 |
|
|
Ttyp :=
|
846 |
|
|
Entity (Subtype_Indication (Associated_Node_For_Itype (Ttyp)));
|
847 |
|
|
else
|
848 |
|
|
raise Program_Error;
|
849 |
|
|
end if;
|
850 |
|
|
|
851 |
|
|
Rewrite (N, Unchecked_Convert_To (Ttyp, Conv));
|
852 |
|
|
Set_Etype (N, Ttyp);
|
853 |
|
|
Set_Analyzed (N);
|
854 |
|
|
|
855 |
|
|
if Nkind (N) = N_Unchecked_Type_Conversion then
|
856 |
|
|
Expand_N_Unchecked_Type_Conversion (N);
|
857 |
|
|
end if;
|
858 |
|
|
end Expand_Unc_Conversion;
|
859 |
|
|
|
860 |
|
|
-----------------------------
|
861 |
|
|
-- Expand_Unc_Deallocation --
|
862 |
|
|
-----------------------------
|
863 |
|
|
|
864 |
|
|
-- Generate the following Code :
|
865 |
|
|
|
866 |
|
|
-- if Arg /= null then
|
867 |
|
|
-- <Finalize_Call> (.., T'Class(Arg.all), ..); -- for controlled types
|
868 |
|
|
-- Free (Arg);
|
869 |
|
|
-- Arg := Null;
|
870 |
|
|
-- end if;
|
871 |
|
|
|
872 |
|
|
-- For a task, we also generate a call to Free_Task to ensure that the
|
873 |
|
|
-- task itself is freed if it is terminated, ditto for a simple protected
|
874 |
|
|
-- object, with a call to Finalize_Protection. For composite types that
|
875 |
|
|
-- have tasks or simple protected objects as components, we traverse the
|
876 |
|
|
-- structures to find and terminate those components.
|
877 |
|
|
|
878 |
|
|
procedure Expand_Unc_Deallocation (N : Node_Id) is
|
879 |
|
|
Arg : constant Node_Id := First_Actual (N);
|
880 |
|
|
Loc : constant Source_Ptr := Sloc (N);
|
881 |
|
|
Typ : constant Entity_Id := Etype (Arg);
|
882 |
|
|
Desig_T : constant Entity_Id := Designated_Type (Typ);
|
883 |
|
|
Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ));
|
884 |
|
|
Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp);
|
885 |
|
|
Stmts : constant List_Id := New_List;
|
886 |
|
|
Needs_Fin : constant Boolean := Needs_Finalization (Desig_T);
|
887 |
|
|
|
888 |
|
|
Finalizer_Data : Finalization_Exception_Data;
|
889 |
|
|
|
890 |
|
|
Blk : Node_Id := Empty;
|
891 |
|
|
Deref : Node_Id;
|
892 |
|
|
Final_Code : List_Id;
|
893 |
|
|
Free_Arg : Node_Id;
|
894 |
|
|
Free_Node : Node_Id;
|
895 |
|
|
Gen_Code : Node_Id;
|
896 |
|
|
|
897 |
|
|
Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N);
|
898 |
|
|
-- This captures whether we know the argument to be non-null so that
|
899 |
|
|
-- we can avoid the test. The reason that we need to capture this is
|
900 |
|
|
-- that we analyze some generated statements before properly attaching
|
901 |
|
|
-- them to the tree, and that can disturb current value settings.
|
902 |
|
|
|
903 |
|
|
begin
|
904 |
|
|
-- Nothing to do if we know the argument is null
|
905 |
|
|
|
906 |
|
|
if Known_Null (N) then
|
907 |
|
|
return;
|
908 |
|
|
end if;
|
909 |
|
|
|
910 |
|
|
-- Processing for pointer to controlled type
|
911 |
|
|
|
912 |
|
|
if Needs_Fin then
|
913 |
|
|
Deref :=
|
914 |
|
|
Make_Explicit_Dereference (Loc,
|
915 |
|
|
Prefix => Duplicate_Subexpr_No_Checks (Arg));
|
916 |
|
|
|
917 |
|
|
-- If the type is tagged, then we must force dispatching on the
|
918 |
|
|
-- finalization call because the designated type may not be the
|
919 |
|
|
-- actual type of the object.
|
920 |
|
|
|
921 |
|
|
if Is_Tagged_Type (Desig_T)
|
922 |
|
|
and then not Is_Class_Wide_Type (Desig_T)
|
923 |
|
|
then
|
924 |
|
|
Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref);
|
925 |
|
|
|
926 |
|
|
elsif not Is_Tagged_Type (Desig_T) then
|
927 |
|
|
|
928 |
|
|
-- Set type of result, to force a conversion when needed (see
|
929 |
|
|
-- exp_ch7, Convert_View), given that Deep_Finalize may be
|
930 |
|
|
-- inherited from the parent type, and we need the type of the
|
931 |
|
|
-- expression to see whether the conversion is in fact needed.
|
932 |
|
|
|
933 |
|
|
Set_Etype (Deref, Desig_T);
|
934 |
|
|
end if;
|
935 |
|
|
|
936 |
|
|
-- The finalization call is expanded wrapped in a block to catch any
|
937 |
|
|
-- possible exception. If an exception does occur, then Program_Error
|
938 |
|
|
-- must be raised following the freeing of the object and its removal
|
939 |
|
|
-- from the finalization collection's list. We set a flag to record
|
940 |
|
|
-- that an exception was raised, and save its occurrence for use in
|
941 |
|
|
-- the later raise.
|
942 |
|
|
--
|
943 |
|
|
-- Generate:
|
944 |
|
|
-- Abort : constant Boolean :=
|
945 |
|
|
-- Exception_Occurrence (Get_Current_Excep.all.all) =
|
946 |
|
|
-- Standard'Abort_Signal'Identity;
|
947 |
|
|
-- <or>
|
948 |
|
|
-- Abort : constant Boolean := False; -- no abort
|
949 |
|
|
|
950 |
|
|
-- E : Exception_Occurrence;
|
951 |
|
|
-- Raised : Boolean := False;
|
952 |
|
|
--
|
953 |
|
|
-- begin
|
954 |
|
|
-- [Deep_]Finalize (Obj);
|
955 |
|
|
-- exception
|
956 |
|
|
-- when others =>
|
957 |
|
|
-- Raised := True;
|
958 |
|
|
-- Save_Occurrence (E, Get_Current_Excep.all.all);
|
959 |
|
|
-- end;
|
960 |
|
|
|
961 |
|
|
Build_Object_Declarations (Finalizer_Data, Stmts, Loc);
|
962 |
|
|
|
963 |
|
|
Final_Code := New_List (
|
964 |
|
|
Make_Block_Statement (Loc,
|
965 |
|
|
Handled_Statement_Sequence =>
|
966 |
|
|
Make_Handled_Sequence_Of_Statements (Loc,
|
967 |
|
|
Statements => New_List (
|
968 |
|
|
Make_Final_Call (Obj_Ref => Deref, Typ => Desig_T)),
|
969 |
|
|
Exception_Handlers => New_List (
|
970 |
|
|
Build_Exception_Handler (Finalizer_Data)))));
|
971 |
|
|
|
972 |
|
|
-- For .NET/JVM, detach the object from the containing finalization
|
973 |
|
|
-- collection before finalizing it.
|
974 |
|
|
|
975 |
|
|
if VM_Target /= No_VM and then Is_Controlled (Desig_T) then
|
976 |
|
|
Prepend_To (Final_Code,
|
977 |
|
|
Make_Detach_Call (New_Copy_Tree (Arg)));
|
978 |
|
|
end if;
|
979 |
|
|
|
980 |
|
|
-- If aborts are allowed, then the finalization code must be
|
981 |
|
|
-- protected by an abort defer/undefer pair.
|
982 |
|
|
|
983 |
|
|
if Abort_Allowed then
|
984 |
|
|
Prepend_To (Final_Code,
|
985 |
|
|
Build_Runtime_Call (Loc, RE_Abort_Defer));
|
986 |
|
|
|
987 |
|
|
Blk :=
|
988 |
|
|
Make_Block_Statement (Loc, Handled_Statement_Sequence =>
|
989 |
|
|
Make_Handled_Sequence_Of_Statements (Loc,
|
990 |
|
|
Statements => Final_Code,
|
991 |
|
|
At_End_Proc =>
|
992 |
|
|
New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)));
|
993 |
|
|
|
994 |
|
|
Append (Blk, Stmts);
|
995 |
|
|
else
|
996 |
|
|
Append_List_To (Stmts, Final_Code);
|
997 |
|
|
end if;
|
998 |
|
|
end if;
|
999 |
|
|
|
1000 |
|
|
-- For a task type, call Free_Task before freeing the ATCB
|
1001 |
|
|
|
1002 |
|
|
if Is_Task_Type (Desig_T) then
|
1003 |
|
|
declare
|
1004 |
|
|
Stat : Node_Id := Prev (N);
|
1005 |
|
|
Nam1 : Node_Id;
|
1006 |
|
|
Nam2 : Node_Id;
|
1007 |
|
|
|
1008 |
|
|
begin
|
1009 |
|
|
-- An Abort followed by a Free will not do what the user expects,
|
1010 |
|
|
-- because the abort is not immediate. This is worth a warning.
|
1011 |
|
|
|
1012 |
|
|
while Present (Stat)
|
1013 |
|
|
and then not Comes_From_Source (Original_Node (Stat))
|
1014 |
|
|
loop
|
1015 |
|
|
Prev (Stat);
|
1016 |
|
|
end loop;
|
1017 |
|
|
|
1018 |
|
|
if Present (Stat)
|
1019 |
|
|
and then Nkind (Original_Node (Stat)) = N_Abort_Statement
|
1020 |
|
|
then
|
1021 |
|
|
Stat := Original_Node (Stat);
|
1022 |
|
|
Nam1 := First (Names (Stat));
|
1023 |
|
|
Nam2 := Original_Node (First (Parameter_Associations (N)));
|
1024 |
|
|
|
1025 |
|
|
if Nkind (Nam1) = N_Explicit_Dereference
|
1026 |
|
|
and then Is_Entity_Name (Prefix (Nam1))
|
1027 |
|
|
and then Is_Entity_Name (Nam2)
|
1028 |
|
|
and then Entity (Prefix (Nam1)) = Entity (Nam2)
|
1029 |
|
|
then
|
1030 |
|
|
Error_Msg_N ("abort may take time to complete?", N);
|
1031 |
|
|
Error_Msg_N ("\deallocation might have no effect?", N);
|
1032 |
|
|
Error_Msg_N ("\safer to wait for termination.?", N);
|
1033 |
|
|
end if;
|
1034 |
|
|
end if;
|
1035 |
|
|
end;
|
1036 |
|
|
|
1037 |
|
|
Append_To
|
1038 |
|
|
(Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg)));
|
1039 |
|
|
|
1040 |
|
|
-- For composite types that contain tasks, recurse over the structure
|
1041 |
|
|
-- to build the selectors for the task subcomponents.
|
1042 |
|
|
|
1043 |
|
|
elsif Has_Task (Desig_T) then
|
1044 |
|
|
if Is_Record_Type (Desig_T) then
|
1045 |
|
|
Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T));
|
1046 |
|
|
|
1047 |
|
|
elsif Is_Array_Type (Desig_T) then
|
1048 |
|
|
Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T));
|
1049 |
|
|
end if;
|
1050 |
|
|
end if;
|
1051 |
|
|
|
1052 |
|
|
-- Same for simple protected types. Eventually call Finalize_Protection
|
1053 |
|
|
-- before freeing the PO for each protected component.
|
1054 |
|
|
|
1055 |
|
|
if Is_Simple_Protected_Type (Desig_T) then
|
1056 |
|
|
Append_To (Stmts,
|
1057 |
|
|
Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg)));
|
1058 |
|
|
|
1059 |
|
|
elsif Has_Simple_Protected_Object (Desig_T) then
|
1060 |
|
|
if Is_Record_Type (Desig_T) then
|
1061 |
|
|
Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T));
|
1062 |
|
|
elsif Is_Array_Type (Desig_T) then
|
1063 |
|
|
Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T));
|
1064 |
|
|
end if;
|
1065 |
|
|
end if;
|
1066 |
|
|
|
1067 |
|
|
-- Normal processing for non-controlled types
|
1068 |
|
|
|
1069 |
|
|
Free_Arg := Duplicate_Subexpr_No_Checks (Arg);
|
1070 |
|
|
Free_Node := Make_Free_Statement (Loc, Empty);
|
1071 |
|
|
Append_To (Stmts, Free_Node);
|
1072 |
|
|
Set_Storage_Pool (Free_Node, Pool);
|
1073 |
|
|
|
1074 |
|
|
-- Attach to tree before analysis of generated subtypes below
|
1075 |
|
|
|
1076 |
|
|
Set_Parent (Stmts, Parent (N));
|
1077 |
|
|
|
1078 |
|
|
-- Deal with storage pool
|
1079 |
|
|
|
1080 |
|
|
if Present (Pool) then
|
1081 |
|
|
|
1082 |
|
|
-- Freeing the secondary stack is meaningless
|
1083 |
|
|
|
1084 |
|
|
if Is_RTE (Pool, RE_SS_Pool) then
|
1085 |
|
|
null;
|
1086 |
|
|
|
1087 |
|
|
-- If the pool object is of a simple storage pool type, then attempt
|
1088 |
|
|
-- to locate the type's Deallocate procedure, if any, and set the
|
1089 |
|
|
-- free operation's procedure to call. If the type doesn't have a
|
1090 |
|
|
-- Deallocate (which is allowed), then the actual will simply be set
|
1091 |
|
|
-- to null.
|
1092 |
|
|
|
1093 |
|
|
elsif Present (Get_Rep_Pragma
|
1094 |
|
|
(Etype (Pool), Name_Simple_Storage_Pool_Type))
|
1095 |
|
|
then
|
1096 |
|
|
declare
|
1097 |
|
|
Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
|
1098 |
|
|
Dealloc_Op : Entity_Id;
|
1099 |
|
|
begin
|
1100 |
|
|
Dealloc_Op := Get_Name_Entity_Id (Name_Deallocate);
|
1101 |
|
|
while Present (Dealloc_Op) loop
|
1102 |
|
|
if Scope (Dealloc_Op) = Scope (Pool_Type)
|
1103 |
|
|
and then Present (First_Formal (Dealloc_Op))
|
1104 |
|
|
and then Etype (First_Formal (Dealloc_Op)) = Pool_Type
|
1105 |
|
|
then
|
1106 |
|
|
Set_Procedure_To_Call (Free_Node, Dealloc_Op);
|
1107 |
|
|
exit;
|
1108 |
|
|
else
|
1109 |
|
|
Dealloc_Op := Homonym (Dealloc_Op);
|
1110 |
|
|
end if;
|
1111 |
|
|
end loop;
|
1112 |
|
|
end;
|
1113 |
|
|
|
1114 |
|
|
-- Case of a class-wide pool type: make a dispatching call to
|
1115 |
|
|
-- Deallocate through the class-wide Deallocate_Any.
|
1116 |
|
|
|
1117 |
|
|
elsif Is_Class_Wide_Type (Etype (Pool)) then
|
1118 |
|
|
Set_Procedure_To_Call (Free_Node, RTE (RE_Deallocate_Any));
|
1119 |
|
|
|
1120 |
|
|
-- Case of a specific pool type: make a statically bound call
|
1121 |
|
|
|
1122 |
|
|
else
|
1123 |
|
|
Set_Procedure_To_Call (Free_Node,
|
1124 |
|
|
Find_Prim_Op (Etype (Pool), Name_Deallocate));
|
1125 |
|
|
end if;
|
1126 |
|
|
end if;
|
1127 |
|
|
|
1128 |
|
|
if Present (Procedure_To_Call (Free_Node)) then
|
1129 |
|
|
|
1130 |
|
|
-- For all cases of a Deallocate call, the back-end needs to be able
|
1131 |
|
|
-- to compute the size of the object being freed. This may require
|
1132 |
|
|
-- some adjustments for objects of dynamic size.
|
1133 |
|
|
--
|
1134 |
|
|
-- If the type is class wide, we generate an implicit type with the
|
1135 |
|
|
-- right dynamic size, so that the deallocate call gets the right
|
1136 |
|
|
-- size parameter computed by GIGI. Same for an access to
|
1137 |
|
|
-- unconstrained packed array.
|
1138 |
|
|
|
1139 |
|
|
if Is_Class_Wide_Type (Desig_T)
|
1140 |
|
|
or else
|
1141 |
|
|
(Is_Array_Type (Desig_T)
|
1142 |
|
|
and then not Is_Constrained (Desig_T)
|
1143 |
|
|
and then Is_Packed (Desig_T))
|
1144 |
|
|
then
|
1145 |
|
|
declare
|
1146 |
|
|
Deref : constant Node_Id :=
|
1147 |
|
|
Make_Explicit_Dereference (Loc,
|
1148 |
|
|
Duplicate_Subexpr_No_Checks (Arg));
|
1149 |
|
|
D_Subtyp : Node_Id;
|
1150 |
|
|
D_Type : Entity_Id;
|
1151 |
|
|
|
1152 |
|
|
begin
|
1153 |
|
|
-- Perform minor decoration as it is needed by the side effect
|
1154 |
|
|
-- removal mechanism.
|
1155 |
|
|
|
1156 |
|
|
Set_Etype (Deref, Desig_T);
|
1157 |
|
|
Set_Parent (Deref, Free_Node);
|
1158 |
|
|
D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T);
|
1159 |
|
|
|
1160 |
|
|
if Nkind (D_Subtyp) in N_Has_Entity then
|
1161 |
|
|
D_Type := Entity (D_Subtyp);
|
1162 |
|
|
|
1163 |
|
|
else
|
1164 |
|
|
D_Type := Make_Temporary (Loc, 'A');
|
1165 |
|
|
Insert_Action (Deref,
|
1166 |
|
|
Make_Subtype_Declaration (Loc,
|
1167 |
|
|
Defining_Identifier => D_Type,
|
1168 |
|
|
Subtype_Indication => D_Subtyp));
|
1169 |
|
|
end if;
|
1170 |
|
|
|
1171 |
|
|
-- Force freezing at the point of the dereference. For the
|
1172 |
|
|
-- class wide case, this avoids having the subtype frozen
|
1173 |
|
|
-- before the equivalent type.
|
1174 |
|
|
|
1175 |
|
|
Freeze_Itype (D_Type, Deref);
|
1176 |
|
|
|
1177 |
|
|
Set_Actual_Designated_Subtype (Free_Node, D_Type);
|
1178 |
|
|
end;
|
1179 |
|
|
|
1180 |
|
|
end if;
|
1181 |
|
|
end if;
|
1182 |
|
|
|
1183 |
|
|
-- Ada 2005 (AI-251): In case of abstract interface type we must
|
1184 |
|
|
-- displace the pointer to reference the base of the object to
|
1185 |
|
|
-- deallocate its memory, unless we're targetting a VM, in which case
|
1186 |
|
|
-- no special processing is required.
|
1187 |
|
|
|
1188 |
|
|
-- Generate:
|
1189 |
|
|
-- free (Base_Address (Obj_Ptr))
|
1190 |
|
|
|
1191 |
|
|
if Is_Interface (Directly_Designated_Type (Typ))
|
1192 |
|
|
and then Tagged_Type_Expansion
|
1193 |
|
|
then
|
1194 |
|
|
Set_Expression (Free_Node,
|
1195 |
|
|
Unchecked_Convert_To (Typ,
|
1196 |
|
|
Make_Function_Call (Loc,
|
1197 |
|
|
Name => New_Reference_To (RTE (RE_Base_Address), Loc),
|
1198 |
|
|
Parameter_Associations => New_List (
|
1199 |
|
|
Unchecked_Convert_To (RTE (RE_Address), Free_Arg)))));
|
1200 |
|
|
|
1201 |
|
|
-- Generate:
|
1202 |
|
|
-- free (Obj_Ptr)
|
1203 |
|
|
|
1204 |
|
|
else
|
1205 |
|
|
Set_Expression (Free_Node, Free_Arg);
|
1206 |
|
|
end if;
|
1207 |
|
|
|
1208 |
|
|
-- Only remaining step is to set result to null, or generate a raise of
|
1209 |
|
|
-- Constraint_Error if the target object is "not null".
|
1210 |
|
|
|
1211 |
|
|
if Can_Never_Be_Null (Etype (Arg)) then
|
1212 |
|
|
Append_To (Stmts,
|
1213 |
|
|
Make_Raise_Constraint_Error (Loc,
|
1214 |
|
|
Reason => CE_Access_Check_Failed));
|
1215 |
|
|
|
1216 |
|
|
else
|
1217 |
|
|
declare
|
1218 |
|
|
Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg);
|
1219 |
|
|
begin
|
1220 |
|
|
Set_Assignment_OK (Lhs);
|
1221 |
|
|
Append_To (Stmts,
|
1222 |
|
|
Make_Assignment_Statement (Loc,
|
1223 |
|
|
Name => Lhs,
|
1224 |
|
|
Expression => Make_Null (Loc)));
|
1225 |
|
|
end;
|
1226 |
|
|
end if;
|
1227 |
|
|
|
1228 |
|
|
-- Generate a test of whether any earlier finalization raised an
|
1229 |
|
|
-- exception, and in that case raise Program_Error with the previous
|
1230 |
|
|
-- exception occurrence.
|
1231 |
|
|
|
1232 |
|
|
-- Generate:
|
1233 |
|
|
-- if Raised and then not Abort then
|
1234 |
|
|
-- raise Program_Error; -- for .NET and
|
1235 |
|
|
-- -- restricted RTS
|
1236 |
|
|
-- <or>
|
1237 |
|
|
-- Raise_From_Controlled_Operation (E); -- all other cases
|
1238 |
|
|
-- end if;
|
1239 |
|
|
|
1240 |
|
|
if Needs_Fin then
|
1241 |
|
|
Append_To (Stmts, Build_Raise_Statement (Finalizer_Data));
|
1242 |
|
|
end if;
|
1243 |
|
|
|
1244 |
|
|
-- If we know the argument is non-null, then make a block statement
|
1245 |
|
|
-- that contains the required statements, no need for a test.
|
1246 |
|
|
|
1247 |
|
|
if Arg_Known_Non_Null then
|
1248 |
|
|
Gen_Code :=
|
1249 |
|
|
Make_Block_Statement (Loc,
|
1250 |
|
|
Handled_Statement_Sequence =>
|
1251 |
|
|
Make_Handled_Sequence_Of_Statements (Loc,
|
1252 |
|
|
Statements => Stmts));
|
1253 |
|
|
|
1254 |
|
|
-- If the argument may be null, wrap the statements inside an IF that
|
1255 |
|
|
-- does an explicit test to exclude the null case.
|
1256 |
|
|
|
1257 |
|
|
else
|
1258 |
|
|
Gen_Code :=
|
1259 |
|
|
Make_Implicit_If_Statement (N,
|
1260 |
|
|
Condition =>
|
1261 |
|
|
Make_Op_Ne (Loc,
|
1262 |
|
|
Left_Opnd => Duplicate_Subexpr (Arg),
|
1263 |
|
|
Right_Opnd => Make_Null (Loc)),
|
1264 |
|
|
Then_Statements => Stmts);
|
1265 |
|
|
end if;
|
1266 |
|
|
|
1267 |
|
|
-- Rewrite the call
|
1268 |
|
|
|
1269 |
|
|
Rewrite (N, Gen_Code);
|
1270 |
|
|
Analyze (N);
|
1271 |
|
|
|
1272 |
|
|
-- If we generated a block with an At_End_Proc, expand the exception
|
1273 |
|
|
-- handler. We need to wait until after everything else is analyzed.
|
1274 |
|
|
|
1275 |
|
|
if Present (Blk) then
|
1276 |
|
|
Expand_At_End_Handler
|
1277 |
|
|
(Handled_Statement_Sequence (Blk), Entity (Identifier (Blk)));
|
1278 |
|
|
end if;
|
1279 |
|
|
end Expand_Unc_Deallocation;
|
1280 |
|
|
|
1281 |
|
|
-----------------------
|
1282 |
|
|
-- Expand_To_Address --
|
1283 |
|
|
-----------------------
|
1284 |
|
|
|
1285 |
|
|
procedure Expand_To_Address (N : Node_Id) is
|
1286 |
|
|
Loc : constant Source_Ptr := Sloc (N);
|
1287 |
|
|
Arg : constant Node_Id := First_Actual (N);
|
1288 |
|
|
Obj : Node_Id;
|
1289 |
|
|
|
1290 |
|
|
begin
|
1291 |
|
|
Remove_Side_Effects (Arg);
|
1292 |
|
|
|
1293 |
|
|
Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg));
|
1294 |
|
|
|
1295 |
|
|
Rewrite (N,
|
1296 |
|
|
Make_Conditional_Expression (Loc,
|
1297 |
|
|
Expressions => New_List (
|
1298 |
|
|
Make_Op_Eq (Loc,
|
1299 |
|
|
Left_Opnd => New_Copy_Tree (Arg),
|
1300 |
|
|
Right_Opnd => Make_Null (Loc)),
|
1301 |
|
|
New_Occurrence_Of (RTE (RE_Null_Address), Loc),
|
1302 |
|
|
Make_Attribute_Reference (Loc,
|
1303 |
|
|
Prefix => Obj,
|
1304 |
|
|
Attribute_Name => Name_Address))));
|
1305 |
|
|
|
1306 |
|
|
Analyze_And_Resolve (N, RTE (RE_Address));
|
1307 |
|
|
end Expand_To_Address;
|
1308 |
|
|
|
1309 |
|
|
-----------------------
|
1310 |
|
|
-- Expand_To_Pointer --
|
1311 |
|
|
-----------------------
|
1312 |
|
|
|
1313 |
|
|
procedure Expand_To_Pointer (N : Node_Id) is
|
1314 |
|
|
Arg : constant Node_Id := First_Actual (N);
|
1315 |
|
|
|
1316 |
|
|
begin
|
1317 |
|
|
Rewrite (N, Unchecked_Convert_To (Etype (N), Arg));
|
1318 |
|
|
Analyze (N);
|
1319 |
|
|
end Expand_To_Pointer;
|
1320 |
|
|
|
1321 |
|
|
end Exp_Intr;
|