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