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