]>
Commit | Line | Data |
---|---|---|
70482933 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- E X P _ I N T R -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
a8551b5f | 9 | -- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- |
70482933 RK |
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- -- |
70482933 RK |
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. -- | |
70482933 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
26 | with Atree; use Atree; | |
53cc4a7a | 27 | with Checks; use Checks; |
70482933 | 28 | with Einfo; use Einfo; |
d239991f | 29 | with Elists; use Elists; |
70482933 | 30 | with Errout; use Errout; |
62548837 | 31 | with Exp_Atag; use Exp_Atag; |
70482933 RK |
32 | with Exp_Ch4; use Exp_Ch4; |
33 | with Exp_Ch7; use Exp_Ch7; | |
f553e7bc | 34 | with Exp_Ch11; use Exp_Ch11; |
70482933 RK |
35 | with Exp_Code; use Exp_Code; |
36 | with Exp_Fixd; use Exp_Fixd; | |
37 | with Exp_Util; use Exp_Util; | |
191cab8d | 38 | with Freeze; use Freeze; |
70482933 RK |
39 | with Namet; use Namet; |
40 | with Nmake; use Nmake; | |
41 | with Nlists; use Nlists; | |
1f110335 | 42 | with Opt; use Opt; |
70482933 | 43 | with Restrict; use Restrict; |
62548837 | 44 | with Rident; use Rident; |
70482933 RK |
45 | with Rtsfind; use Rtsfind; |
46 | with Sem; use Sem; | |
47 | with Sem_Eval; use Sem_Eval; | |
48 | with Sem_Res; use Sem_Res; | |
ce2b6ba5 | 49 | with Sem_Type; use Sem_Type; |
70482933 RK |
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; | |
deb8dacc | 56 | with Targparm; use Targparm; |
70482933 RK |
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 | ||
955871d3 AC |
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 | ||
70482933 RK |
71 | procedure Expand_Is_Negative (N : Node_Id); |
72 | -- Expand a call to the intrinsic Is_Negative function | |
73 | ||
d239991f GD |
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 | ||
70482933 RK |
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 | |
5453d5bd | 92 | -- Expand_Intrinsic_Call (call node and subprogram spec entity) and |
70482933 RK |
93 | -- K is the kind for the shift node |
94 | ||
95 | procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id); | |
e14c931f | 96 | -- Expand a call to an instantiation of Unchecked_Conversion into a node |
70482933 RK |
97 | -- N_Unchecked_Type_Conversion. |
98 | ||
07fc65c4 | 99 | procedure Expand_Unc_Deallocation (N : Node_Id); |
70482933 RK |
100 | -- Expand a call to an instantiation of Unchecked_Deallocation into a node |
101 | -- N_Free_Statement and appropriate context. | |
102 | ||
fbf5a39b AC |
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 | |
e14c931f | 106 | -- System.Address_To_Access_Conversions. |
fbf5a39b | 107 | |
07fc65c4 | 108 | procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id); |
70482933 RK |
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 | ||
955871d3 AC |
116 | --------------------------------- |
117 | -- Expand_Binary_Operator_Call -- | |
118 | --------------------------------- | |
119 | ||
120 | procedure Expand_Binary_Operator_Call (N : Node_Id) is | |
437f8c1e AC |
121 | T1 : constant Entity_Id := Underlying_Type (Etype (Left_Opnd (N))); |
122 | T2 : constant Entity_Id := Underlying_Type (Etype (Right_Opnd (N))); | |
955871d3 AC |
123 | TR : constant Entity_Id := Etype (N); |
124 | T3 : Entity_Id; | |
125 | Res : Node_Id; | |
92252980 | 126 | |
c2db4b32 | 127 | Siz : constant Uint := UI_Max (RM_Size (T1), RM_Size (T2)); |
92252980 | 128 | -- Maximum of operand sizes |
955871d3 AC |
129 | |
130 | begin | |
90c63b09 | 131 | -- Nothing to do if the operands have the same modular type |
437f8c1e AC |
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 | ||
92252980 | 139 | -- Use Unsigned_32 for sizes of 32 or below, else Unsigned_64 |
955871d3 AC |
140 | |
141 | if Siz > 32 then | |
142 | T3 := RTE (RE_Unsigned_64); | |
143 | else | |
144 | T3 := RTE (RE_Unsigned_32); | |
145 | end if; | |
146 | ||
92252980 RD |
147 | -- Copy operator node, and reset type and entity fields, for |
148 | -- subsequent reanalysis. | |
149 | ||
955871d3 | 150 | Res := New_Copy (N); |
437f8c1e | 151 | Set_Etype (Res, T3); |
90c63b09 | 152 | |
437f8c1e AC |
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; | |
955871d3 | 163 | |
92252980 RD |
164 | -- Convert operands to large enough intermediate type |
165 | ||
955871d3 | 166 | Set_Left_Opnd (Res, |
92252980 | 167 | Unchecked_Convert_To (T3, Relocate_Node (Left_Opnd (N)))); |
955871d3 | 168 | Set_Right_Opnd (Res, |
92252980 RD |
169 | Unchecked_Convert_To (T3, Relocate_Node (Right_Opnd (N)))); |
170 | ||
171 | -- Analyze and resolve result formed by conversion to target type | |
955871d3 AC |
172 | |
173 | Rewrite (N, Unchecked_Convert_To (TR, Res)); | |
174 | Analyze_And_Resolve (N, TR); | |
175 | end Expand_Binary_Operator_Call; | |
176 | ||
d239991f GD |
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 | |
53cc4a7a JM |
187 | -- associated with the formal subprogram Construct, designating The_Tag |
188 | -- as the controlling tag of the call: | |
d239991f GD |
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 | ||
53cc4a7a JM |
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. | |
d239991f GD |
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); | |
191cab8d TQ |
205 | Act_Rename : Node_Id; |
206 | Act_Constr : Entity_Id; | |
c8b92217 | 207 | Iface_Tag : Node_Id := Empty; |
d239991f | 208 | Cnstr_Call : Node_Id; |
c8b92217 | 209 | Result_Typ : Entity_Id; |
d239991f GD |
210 | |
211 | begin | |
191cab8d TQ |
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 | ||
b545a0f6 JM |
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); | |
c8b92217 JM |
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 | ||
4ac2477e JM |
235 | if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg), |
236 | Use_Full_View => True) | |
abcd9db2 | 237 | and then Tagged_Type_Expansion |
4ac2477e | 238 | then |
9732e886 JM |
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; | |
c8b92217 | 266 | end if; |
b545a0f6 JM |
267 | end if; |
268 | ||
d239991f GD |
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 | |
62548837 RD |
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. | |
d239991f | 280 | |
c8b92217 JM |
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; | |
d239991f GD |
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 | ||
53cc4a7a | 296 | -- Do not generate a run-time check on the built object if tag |
c8b92217 | 297 | -- checks are suppressed for the result type or VM_Target /= No_VM |
53cc4a7a | 298 | |
c8b92217 | 299 | if Tag_Checks_Suppressed (Etype (Result_Typ)) |
1f110335 | 300 | or else not Tagged_Type_Expansion |
c8b92217 | 301 | then |
53cc4a7a JM |
302 | null; |
303 | ||
d239991f | 304 | -- Generate a class-wide membership test to ensure that the call's tag |
53cc4a7a JM |
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 | |
82878151 AC |
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; | |
53cc4a7a JM |
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, | |
b545a0f6 JM |
346 | Make_Function_Call (Loc, |
347 | Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc), | |
348 | Parameter_Associations => New_List ( | |
53cc4a7a | 349 | Make_Attribute_Reference (Loc, |
c8b92217 | 350 | Prefix => Duplicate_Subexpr (Tag_Arg), |
53cc4a7a JM |
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; | |
d239991f GD |
361 | end Expand_Dispatching_Constructor_Call; |
362 | ||
70482933 RK |
363 | --------------------------- |
364 | -- Expand_Exception_Call -- | |
365 | --------------------------- | |
366 | ||
62548837 RD |
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 | |
70482933 RK |
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; | |
70482933 RK |
377 | |
378 | begin | |
379 | -- Climb up parents to see if we are in exception handler | |
380 | ||
381 | P := Parent (N); | |
382 | loop | |
1d571f3b | 383 | -- Case of not in exception handler, replace by null string |
70482933 RK |
384 | |
385 | if No (P) then | |
70482933 RK |
386 | Rewrite (N, |
387 | Make_String_Literal (Loc, | |
1d571f3b | 388 | Strval => "")); |
70482933 RK |
389 | exit; |
390 | ||
391 | -- Case of in exception handler | |
392 | ||
393 | elsif Nkind (P) = N_Exception_Handler then | |
70482933 | 394 | |
62548837 RD |
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); | |
70482933 | 400 | |
62548837 RD |
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 | |
092ef350 | 406 | E := Make_Temporary (Loc, 'E'); |
70482933 RK |
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); | |
092ef350 | 443 | Dum : constant Entity_Id := Make_Temporary (Loc, 'D'); |
70482933 RK |
444 | |
445 | begin | |
70482933 RK |
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, | |
c8b92217 JM |
468 | Prefix => Make_Identifier (Loc, Chars (Dum)), |
469 | Attribute_Name => Name_Address))); | |
70482933 RK |
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 | |
75a64833 AC |
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 | ||
7324bf49 | 489 | -- If the intrinsic subprogram is generic, gets its original name |
70482933 RK |
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 | ||
d239991f GD |
514 | elsif Nam = Name_Generic_Dispatching_Constructor then |
515 | Expand_Dispatching_Constructor_Call (N); | |
516 | ||
70482933 RK |
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 | |
07fc65c4 | 547 | Expand_Unc_Deallocation (N); |
70482933 | 548 | |
fbf5a39b AC |
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 | ||
70482933 RK |
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 | |
07fc65c4 | 560 | Expand_Source_Info (N, Nam); |
70482933 | 561 | |
98f01d53 AC |
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. | |
70482933 | 565 | |
98f01d53 | 566 | elsif Present (Alias (E)) then |
70482933 | 567 | Expand_Intrinsic_Call (N, Alias (E)); |
98f01d53 | 568 | |
955871d3 AC |
569 | elsif Nkind (N) in N_Binary_Op then |
570 | Expand_Binary_Operator_Call (N); | |
571 | ||
98f01d53 AC |
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; | |
70482933 | 580 | end if; |
70482933 RK |
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, | |
fbf5a39b | 617 | Left_Opnd => Duplicate_Subexpr_No_Checks (Opnd), |
70482933 RK |
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 => | |
fbf5a39b AC |
624 | Unchecked_Convert_To |
625 | (RTE (RE_Float_Unsigned), | |
626 | Convert_To | |
627 | (Standard_Float, | |
628 | Duplicate_Subexpr_No_Checks (Opnd))), | |
70482933 RK |
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); | |
70482933 RK |
681 | end Expand_Shift; |
682 | ||
683 | ------------------------ | |
684 | -- Expand_Source_Info -- | |
685 | ------------------------ | |
686 | ||
07fc65c4 | 687 | procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is |
70482933 RK |
688 | Loc : constant Source_Ptr := Sloc (N); |
689 | Ent : Entity_Id; | |
690 | ||
435d8e6b ES |
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 | ||
70482933 RK |
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 | |
21d27997 RD |
758 | Name_Len := 0; |
759 | ||
70482933 RK |
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 => | |
70482933 | 769 | |
435d8e6b | 770 | -- Skip enclosing blocks to reach enclosing unit |
70482933 | 771 | |
21d27997 | 772 | Ent := Current_Scope; |
70482933 RK |
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 | ||
435d8e6b | 781 | Write_Entity_Name (Ent); |
70482933 RK |
782 | |
783 | when others => | |
784 | raise Program_Error; | |
785 | end case; | |
786 | ||
787 | Rewrite (N, | |
21d27997 RD |
788 | Make_String_Literal (Loc, |
789 | Strval => String_From_Name_Buffer)); | |
70482933 RK |
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; | |
b7cdaf8d | 804 | Ttyp : Entity_Id; |
70482933 RK |
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 | ||
b7cdaf8d ES |
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 | ||
70482933 RK |
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 | ||
b7cdaf8d ES |
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); | |
70482933 RK |
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 | |
fbf5a39b AC |
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. | |
70482933 | 877 | |
07fc65c4 | 878 | procedure Expand_Unc_Deallocation (N : Node_Id) is |
36b8f95f AC |
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 | ||
f9ad6b62 AC |
890 | Blk : Node_Id := Empty; |
891 | Deref : Node_Id; | |
f9ad6b62 AC |
892 | Final_Code : List_Id; |
893 | Free_Arg : Node_Id; | |
894 | Free_Node : Node_Id; | |
895 | Gen_Code : Node_Id; | |
70482933 | 896 | |
dad9a816 RD |
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 | ||
70482933 | 903 | begin |
dad9a816 RD |
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 | ||
36b8f95f | 912 | if Needs_Fin then |
fbf5a39b AC |
913 | Deref := |
914 | Make_Explicit_Dereference (Loc, | |
915 | Prefix => Duplicate_Subexpr_No_Checks (Arg)); | |
70482933 RK |
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 | |
4a2ddf66 | 919 | -- actual type of the object. |
70482933 RK |
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); | |
4a2ddf66 ES |
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); | |
70482933 RK |
934 | end if; |
935 | ||
df3e68b1 HK |
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: | |
f9ad6b62 AC |
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; | |
df3e68b1 HK |
952 | -- |
953 | -- begin | |
954 | -- [Deep_]Finalize (Obj); | |
955 | -- exception | |
956 | -- when others => | |
957 | -- Raised := True; | |
f9ad6b62 | 958 | -- Save_Occurrence (E, Get_Current_Excep.all.all); |
df3e68b1 HK |
959 | -- end; |
960 | ||
36b8f95f | 961 | Build_Object_Declarations (Finalizer_Data, Stmts, Loc); |
df3e68b1 HK |
962 | |
963 | Final_Code := New_List ( | |
964 | Make_Block_Statement (Loc, | |
965 | Handled_Statement_Sequence => | |
966 | Make_Handled_Sequence_Of_Statements (Loc, | |
e0c32166 AC |
967 | Statements => New_List ( |
968 | Make_Final_Call (Obj_Ref => Deref, Typ => Desig_T)), | |
df3e68b1 | 969 | Exception_Handlers => New_List ( |
36b8f95f | 970 | Build_Exception_Handler (Finalizer_Data))))); |
df3e68b1 | 971 | |
deb8dacc HK |
972 | -- For .NET/JVM, detach the object from the containing finalization |
973 | -- collection before finalizing it. | |
974 | ||
e0c32166 | 975 | if VM_Target /= No_VM and then Is_Controlled (Desig_T) then |
deb8dacc HK |
976 | Prepend_To (Final_Code, |
977 | Make_Detach_Call (New_Copy_Tree (Arg))); | |
978 | end if; | |
979 | ||
df3e68b1 HK |
980 | -- If aborts are allowed, then the finalization code must be |
981 | -- protected by an abort defer/undefer pair. | |
70482933 RK |
982 | |
983 | if Abort_Allowed then | |
df3e68b1 | 984 | Prepend_To (Final_Code, |
70482933 RK |
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, | |
df3e68b1 | 990 | Statements => Final_Code, |
70482933 RK |
991 | At_End_Proc => |
992 | New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc))); | |
993 | ||
70482933 | 994 | Append (Blk, Stmts); |
70482933 | 995 | else |
df3e68b1 | 996 | Append_List_To (Stmts, Final_Code); |
70482933 RK |
997 | end if; |
998 | end if; | |
999 | ||
fbf5a39b | 1000 | -- For a task type, call Free_Task before freeing the ATCB |
70482933 RK |
1001 | |
1002 | if Is_Task_Type (Desig_T) then | |
70482933 RK |
1003 | declare |
1004 | Stat : Node_Id := Prev (N); | |
1005 | Nam1 : Node_Id; | |
1006 | Nam2 : Node_Id; | |
1007 | ||
1008 | begin | |
13a0b1e8 AC |
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. | |
70482933 RK |
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 | |
84f8ad69 | 1030 | Error_Msg_N ("abort may take time to complete?", N); |
70482933 RK |
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 | ||
fbf5a39b AC |
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; | |
70482933 RK |
1050 | end if; |
1051 | ||
fbf5a39b AC |
1052 | -- Same for simple protected types. Eventually call Finalize_Protection |
1053 | -- before freeing the PO for each protected component. | |
70482933 | 1054 | |
fbf5a39b | 1055 | if Is_Simple_Protected_Type (Desig_T) then |
70482933 | 1056 | Append_To (Stmts, |
fbf5a39b AC |
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; | |
70482933 RK |
1065 | end if; |
1066 | ||
1067 | -- Normal processing for non-controlled types | |
1068 | ||
fbf5a39b | 1069 | Free_Arg := Duplicate_Subexpr_No_Checks (Arg); |
70482933 RK |
1070 | Free_Node := Make_Free_Statement (Loc, Empty); |
1071 | Append_To (Stmts, Free_Node); | |
1072 | Set_Storage_Pool (Free_Node, Pool); | |
1073 | ||
e4982b64 | 1074 | -- Attach to tree before analysis of generated subtypes below |
a7c764a9 AC |
1075 | |
1076 | Set_Parent (Stmts, Parent (N)); | |
1077 | ||
191cab8d TQ |
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 | ||
a8551b5f AC |
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)) | |
1095 | then | |
1096 | declare | |
1097 | Dealloc_Op : Entity_Id := Get_Name_Entity_Id (Name_Deallocate); | |
1098 | Pool_Type : constant Entity_Id := Base_Type (Etype (Pool)); | |
1099 | ||
1100 | begin | |
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 | ||
1108 | exit; | |
1109 | end if; | |
1110 | ||
1111 | Dealloc_Op := Homonym (Dealloc_Op); | |
1112 | end loop; | |
1113 | end; | |
1114 | ||
e4982b64 AC |
1115 | -- Case of a class-wide pool type: make a dispatching call to |
1116 | -- Deallocate through the class-wide Deallocate_Any. | |
191cab8d | 1117 | |
e4982b64 AC |
1118 | elsif Is_Class_Wide_Type (Etype (Pool)) then |
1119 | Set_Procedure_To_Call (Free_Node, RTE (RE_Deallocate_Any)); | |
191cab8d | 1120 | |
e4982b64 | 1121 | -- Case of a specific pool type: make a statically bound call |
191cab8d TQ |
1122 | |
1123 | else | |
191cab8d TQ |
1124 | Set_Procedure_To_Call (Free_Node, |
1125 | Find_Prim_Op (Etype (Pool), Name_Deallocate)); | |
1126 | end if; | |
1127 | end if; | |
1128 | ||
1129 | if Present (Procedure_To_Call (Free_Node)) then | |
1130 | ||
13a0b1e8 AC |
1131 | -- For all cases of a Deallocate call, the back-end needs to be able |
1132 | -- to compute the size of the object being freed. This may require | |
1133 | -- some adjustments for objects of dynamic size. | |
191cab8d TQ |
1134 | -- |
1135 | -- If the type is class wide, we generate an implicit type with the | |
1136 | -- right dynamic size, so that the deallocate call gets the right | |
1137 | -- size parameter computed by GIGI. Same for an access to | |
1138 | -- unconstrained packed array. | |
1139 | ||
1140 | if Is_Class_Wide_Type (Desig_T) | |
1141 | or else | |
1142 | (Is_Array_Type (Desig_T) | |
1143 | and then not Is_Constrained (Desig_T) | |
1144 | and then Is_Packed (Desig_T)) | |
1145 | then | |
1146 | declare | |
1147 | Deref : constant Node_Id := | |
1148 | Make_Explicit_Dereference (Loc, | |
1149 | Duplicate_Subexpr_No_Checks (Arg)); | |
1150 | D_Subtyp : Node_Id; | |
1151 | D_Type : Entity_Id; | |
1152 | ||
1153 | begin | |
b38c20a6 AC |
1154 | -- Perform minor decoration as it is needed by the side effect |
1155 | -- removal mechanism. | |
1156 | ||
1157 | Set_Etype (Deref, Desig_T); | |
191cab8d TQ |
1158 | Set_Parent (Deref, Free_Node); |
1159 | D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T); | |
1160 | ||
1161 | if Nkind (D_Subtyp) in N_Has_Entity then | |
1162 | D_Type := Entity (D_Subtyp); | |
1163 | ||
1164 | else | |
092ef350 | 1165 | D_Type := Make_Temporary (Loc, 'A'); |
cbae498b | 1166 | Insert_Action (Deref, |
191cab8d TQ |
1167 | Make_Subtype_Declaration (Loc, |
1168 | Defining_Identifier => D_Type, | |
1169 | Subtype_Indication => D_Subtyp)); | |
191cab8d TQ |
1170 | end if; |
1171 | ||
cbae498b EB |
1172 | -- Force freezing at the point of the dereference. For the |
1173 | -- class wide case, this avoids having the subtype frozen | |
1174 | -- before the equivalent type. | |
1175 | ||
1176 | Freeze_Itype (D_Type, Deref); | |
1177 | ||
191cab8d TQ |
1178 | Set_Actual_Designated_Subtype (Free_Node, D_Type); |
1179 | end; | |
1180 | ||
1181 | end if; | |
1182 | end if; | |
1183 | ||
b545a0f6 JM |
1184 | -- Ada 2005 (AI-251): In case of abstract interface type we must |
1185 | -- displace the pointer to reference the base of the object to | |
c8b92217 JM |
1186 | -- deallocate its memory, unless we're targetting a VM, in which case |
1187 | -- no special processing is required. | |
b545a0f6 JM |
1188 | |
1189 | -- Generate: | |
1190 | -- free (Base_Address (Obj_Ptr)) | |
1191 | ||
c8b92217 | 1192 | if Is_Interface (Directly_Designated_Type (Typ)) |
1f110335 | 1193 | and then Tagged_Type_Expansion |
c8b92217 | 1194 | then |
b545a0f6 JM |
1195 | Set_Expression (Free_Node, |
1196 | Unchecked_Convert_To (Typ, | |
1197 | Make_Function_Call (Loc, | |
1198 | Name => New_Reference_To (RTE (RE_Base_Address), Loc), | |
1199 | Parameter_Associations => New_List ( | |
1200 | Unchecked_Convert_To (RTE (RE_Address), Free_Arg))))); | |
1201 | ||
1202 | -- Generate: | |
1203 | -- free (Obj_Ptr) | |
1204 | ||
1205 | else | |
1206 | Set_Expression (Free_Node, Free_Arg); | |
1207 | end if; | |
191cab8d | 1208 | |
13a0b1e8 AC |
1209 | -- Only remaining step is to set result to null, or generate a raise of |
1210 | -- Constraint_Error if the target object is "not null". | |
70482933 | 1211 | |
191cab8d TQ |
1212 | if Can_Never_Be_Null (Etype (Arg)) then |
1213 | Append_To (Stmts, | |
1214 | Make_Raise_Constraint_Error (Loc, | |
1215 | Reason => CE_Access_Check_Failed)); | |
70482933 | 1216 | |
191cab8d TQ |
1217 | else |
1218 | declare | |
1219 | Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg); | |
1220 | begin | |
1221 | Set_Assignment_OK (Lhs); | |
1222 | Append_To (Stmts, | |
1223 | Make_Assignment_Statement (Loc, | |
1224 | Name => Lhs, | |
1225 | Expression => Make_Null (Loc))); | |
1226 | end; | |
70482933 RK |
1227 | end if; |
1228 | ||
df3e68b1 HK |
1229 | -- Generate a test of whether any earlier finalization raised an |
1230 | -- exception, and in that case raise Program_Error with the previous | |
1231 | -- exception occurrence. | |
ee2e3f6b | 1232 | |
df3e68b1 | 1233 | -- Generate: |
ee2e3f6b | 1234 | -- if Raised and then not Abort then |
ddf67a1d | 1235 | -- raise Program_Error; -- for .NET and |
ee2e3f6b | 1236 | -- -- restricted RTS |
df3e68b1 | 1237 | -- <or> |
ee2e3f6b | 1238 | -- Raise_From_Controlled_Operation (E); -- all other cases |
df3e68b1 HK |
1239 | -- end if; |
1240 | ||
36b8f95f AC |
1241 | if Needs_Fin then |
1242 | Append_To (Stmts, Build_Raise_Statement (Finalizer_Data)); | |
df3e68b1 HK |
1243 | end if; |
1244 | ||
dad9a816 RD |
1245 | -- If we know the argument is non-null, then make a block statement |
1246 | -- that contains the required statements, no need for a test. | |
1247 | ||
1248 | if Arg_Known_Non_Null then | |
1249 | Gen_Code := | |
1250 | Make_Block_Statement (Loc, | |
1251 | Handled_Statement_Sequence => | |
1252 | Make_Handled_Sequence_Of_Statements (Loc, | |
1253 | Statements => Stmts)); | |
1254 | ||
1255 | -- If the argument may be null, wrap the statements inside an IF that | |
1256 | -- does an explicit test to exclude the null case. | |
1257 | ||
1258 | else | |
1259 | Gen_Code := | |
1260 | Make_Implicit_If_Statement (N, | |
1261 | Condition => | |
1262 | Make_Op_Ne (Loc, | |
1263 | Left_Opnd => Duplicate_Subexpr (Arg), | |
1264 | Right_Opnd => Make_Null (Loc)), | |
1265 | Then_Statements => Stmts); | |
1266 | end if; | |
1267 | ||
191cab8d | 1268 | -- Rewrite the call |
70482933 RK |
1269 | |
1270 | Rewrite (N, Gen_Code); | |
1271 | Analyze (N); | |
f553e7bc AC |
1272 | |
1273 | -- If we generated a block with an At_End_Proc, expand the exception | |
1274 | -- handler. We need to wait until after everything else is analyzed. | |
1275 | ||
1276 | if Present (Blk) then | |
1277 | Expand_At_End_Handler | |
1278 | (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); | |
1279 | end if; | |
70482933 RK |
1280 | end Expand_Unc_Deallocation; |
1281 | ||
fbf5a39b AC |
1282 | ----------------------- |
1283 | -- Expand_To_Address -- | |
1284 | ----------------------- | |
1285 | ||
1286 | procedure Expand_To_Address (N : Node_Id) is | |
1287 | Loc : constant Source_Ptr := Sloc (N); | |
1288 | Arg : constant Node_Id := First_Actual (N); | |
1289 | Obj : Node_Id; | |
1290 | ||
1291 | begin | |
1292 | Remove_Side_Effects (Arg); | |
1293 | ||
1294 | Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg)); | |
1295 | ||
1296 | Rewrite (N, | |
1297 | Make_Conditional_Expression (Loc, | |
1298 | Expressions => New_List ( | |
1299 | Make_Op_Eq (Loc, | |
1300 | Left_Opnd => New_Copy_Tree (Arg), | |
1301 | Right_Opnd => Make_Null (Loc)), | |
1302 | New_Occurrence_Of (RTE (RE_Null_Address), Loc), | |
1303 | Make_Attribute_Reference (Loc, | |
c8b92217 JM |
1304 | Prefix => Obj, |
1305 | Attribute_Name => Name_Address)))); | |
fbf5a39b AC |
1306 | |
1307 | Analyze_And_Resolve (N, RTE (RE_Address)); | |
1308 | end Expand_To_Address; | |
1309 | ||
1310 | ----------------------- | |
1311 | -- Expand_To_Pointer -- | |
1312 | ----------------------- | |
1313 | ||
1314 | procedure Expand_To_Pointer (N : Node_Id) is | |
1315 | Arg : constant Node_Id := First_Actual (N); | |
1316 | ||
1317 | begin | |
1318 | Rewrite (N, Unchecked_Convert_To (Etype (N), Arg)); | |
1319 | Analyze (N); | |
1320 | end Expand_To_Pointer; | |
1321 | ||
70482933 | 1322 | end Exp_Intr; |