1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Einfo
; use Einfo
;
29 with Errout
; use Errout
;
30 with Exp_Ch4
; use Exp_Ch4
;
31 with Exp_Ch7
; use Exp_Ch7
;
32 with Exp_Ch11
; use Exp_Ch11
;
33 with Exp_Code
; use Exp_Code
;
34 with Exp_Fixd
; use Exp_Fixd
;
35 with Exp_Util
; use Exp_Util
;
36 with Itypes
; use Itypes
;
37 with Namet
; use Namet
;
38 with Nmake
; use Nmake
;
39 with Nlists
; use Nlists
;
40 with Restrict
; use Restrict
;
41 with Rtsfind
; use Rtsfind
;
43 with Sem_Eval
; use Sem_Eval
;
44 with Sem_Res
; use Sem_Res
;
45 with Sem_Util
; use Sem_Util
;
46 with Sinfo
; use Sinfo
;
47 with Sinput
; use Sinput
;
48 with Snames
; use Snames
;
49 with Stand
; use Stand
;
50 with Stringt
; use Stringt
;
51 with Tbuild
; use Tbuild
;
52 with Uintp
; use Uintp
;
53 with Urealp
; use Urealp
;
55 package body Exp_Intr
is
57 -----------------------
58 -- Local Subprograms --
59 -----------------------
61 procedure Expand_Is_Negative
(N
: Node_Id
);
62 -- Expand a call to the intrinsic Is_Negative function
64 procedure Expand_Exception_Call
(N
: Node_Id
; Ent
: RE_Id
);
65 -- Expand a call to Exception_Information/Message/Name. The first
66 -- parameter, N, is the node for the function call, and Ent is the
67 -- entity for the corresponding routine in the Ada.Exceptions package.
69 procedure Expand_Import_Call
(N
: Node_Id
);
70 -- Expand a call to Import_Address/Longest_Integer/Value. The parameter
71 -- N is the node for the function call.
73 procedure Expand_Shift
(N
: Node_Id
; E
: Entity_Id
; K
: Node_Kind
);
74 -- Expand an intrinsic shift operation, N and E are from the call to
75 -- Expand_Intrinsic_Call (call node and subprogram spec entity) and
76 -- K is the kind for the shift node
78 procedure Expand_Unc_Conversion
(N
: Node_Id
; E
: Entity_Id
);
79 -- Expand a call to an instantiation of Unchecked_Convertion into a node
80 -- N_Unchecked_Type_Conversion.
82 procedure Expand_Unc_Deallocation
(N
: Node_Id
);
83 -- Expand a call to an instantiation of Unchecked_Deallocation into a node
84 -- N_Free_Statement and appropriate context.
86 procedure Expand_To_Address
(N
: Node_Id
);
87 procedure Expand_To_Pointer
(N
: Node_Id
);
88 -- Expand a call to corresponding function, declared in an instance of
89 -- System.Addess_To_Access_Conversions.
91 procedure Expand_Source_Info
(N
: Node_Id
; Nam
: Name_Id
);
92 -- Rewrite the node by the appropriate string or positive constant.
93 -- Nam can be one of the following:
94 -- Name_File - expand string that is the name of source file
95 -- Name_Line - expand integer line number
96 -- Name_Source_Location - expand string of form file:line
97 -- Name_Enclosing_Entity - expand string with name of enclosing entity
99 ---------------------------
100 -- Expand_Exception_Call --
101 ---------------------------
103 -- If the function call is not within an exception handler, then the
104 -- call is replaced by a null string. Otherwise the appropriate routine
105 -- in Ada.Exceptions is called passing the choice parameter specification
106 -- from the enclosing handler. If the enclosing handler lacks a choice
107 -- parameter, then one is supplied.
109 procedure Expand_Exception_Call
(N
: Node_Id
; Ent
: RE_Id
) is
110 Loc
: constant Source_Ptr
:= Sloc
(N
);
115 -- Climb up parents to see if we are in exception handler
119 -- Case of not in exception handler, replace by null string
123 Make_String_Literal
(Loc
,
127 -- Case of in exception handler
129 elsif Nkind
(P
) = N_Exception_Handler
then
130 if No
(Choice_Parameter
(P
)) then
132 -- If no choice parameter present, then put one there. Note
133 -- that we do not need to put it on the entity chain, since
134 -- no one will be referencing it by normal visibility methods.
136 E
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
137 Set_Choice_Parameter
(P
, E
);
138 Set_Ekind
(E
, E_Variable
);
139 Set_Etype
(E
, RTE
(RE_Exception_Occurrence
));
140 Set_Scope
(E
, Current_Scope
);
144 Make_Function_Call
(Loc
,
145 Name
=> New_Occurrence_Of
(RTE
(Ent
), Loc
),
146 Parameter_Associations
=> New_List
(
147 New_Occurrence_Of
(Choice_Parameter
(P
), Loc
))));
157 Analyze_And_Resolve
(N
, Standard_String
);
158 end Expand_Exception_Call
;
160 ------------------------
161 -- Expand_Import_Call --
162 ------------------------
164 -- The function call must have a static string as its argument. We create
165 -- a dummy variable which uses this string as the external name in an
166 -- Import pragma. The result is then obtained as the address of this
167 -- dummy variable, converted to the appropriate target type.
169 procedure Expand_Import_Call
(N
: Node_Id
) is
170 Loc
: constant Source_Ptr
:= Sloc
(N
);
171 Ent
: constant Entity_Id
:= Entity
(Name
(N
));
172 Str
: constant Node_Id
:= First_Actual
(N
);
176 Dum
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('D'));
178 Insert_Actions
(N
, New_List
(
179 Make_Object_Declaration
(Loc
,
180 Defining_Identifier
=> Dum
,
182 New_Occurrence_Of
(Standard_Character
, Loc
)),
185 Chars
=> Name_Import
,
186 Pragma_Argument_Associations
=> New_List
(
187 Make_Pragma_Argument_Association
(Loc
,
188 Expression
=> Make_Identifier
(Loc
, Name_Ada
)),
190 Make_Pragma_Argument_Association
(Loc
,
191 Expression
=> Make_Identifier
(Loc
, Chars
(Dum
))),
193 Make_Pragma_Argument_Association
(Loc
,
194 Chars
=> Name_Link_Name
,
195 Expression
=> Relocate_Node
(Str
))))));
198 Unchecked_Convert_To
(Etype
(Ent
),
199 Make_Attribute_Reference
(Loc
,
200 Attribute_Name
=> Name_Address
,
201 Prefix
=> Make_Identifier
(Loc
, Chars
(Dum
)))));
203 Analyze_And_Resolve
(N
, Etype
(Ent
));
204 end Expand_Import_Call
;
206 ---------------------------
207 -- Expand_Intrinsic_Call --
208 ---------------------------
210 procedure Expand_Intrinsic_Call
(N
: Node_Id
; E
: Entity_Id
) is
214 -- If the intrinsic subprogram is generic, gets its original name
216 if Present
(Parent
(E
))
217 and then Present
(Generic_Parent
(Parent
(E
)))
219 Nam
:= Chars
(Generic_Parent
(Parent
(E
)));
224 if Nam
= Name_Asm
then
227 elsif Nam
= Name_Divide
then
228 Expand_Decimal_Divide_Call
(N
);
230 elsif Nam
= Name_Exception_Information
then
231 Expand_Exception_Call
(N
, RE_Exception_Information
);
233 elsif Nam
= Name_Exception_Message
then
234 Expand_Exception_Call
(N
, RE_Exception_Message
);
236 elsif Nam
= Name_Exception_Name
then
237 Expand_Exception_Call
(N
, RE_Exception_Name_Simple
);
239 elsif Nam
= Name_Import_Address
241 Nam
= Name_Import_Largest_Value
243 Nam
= Name_Import_Value
245 Expand_Import_Call
(N
);
247 elsif Nam
= Name_Is_Negative
then
248 Expand_Is_Negative
(N
);
250 elsif Nam
= Name_Rotate_Left
then
251 Expand_Shift
(N
, E
, N_Op_Rotate_Left
);
253 elsif Nam
= Name_Rotate_Right
then
254 Expand_Shift
(N
, E
, N_Op_Rotate_Right
);
256 elsif Nam
= Name_Shift_Left
then
257 Expand_Shift
(N
, E
, N_Op_Shift_Left
);
259 elsif Nam
= Name_Shift_Right
then
260 Expand_Shift
(N
, E
, N_Op_Shift_Right
);
262 elsif Nam
= Name_Shift_Right_Arithmetic
then
263 Expand_Shift
(N
, E
, N_Op_Shift_Right_Arithmetic
);
265 elsif Nam
= Name_Unchecked_Conversion
then
266 Expand_Unc_Conversion
(N
, E
);
268 elsif Nam
= Name_Unchecked_Deallocation
then
269 Expand_Unc_Deallocation
(N
);
271 elsif Nam
= Name_To_Address
then
272 Expand_To_Address
(N
);
274 elsif Nam
= Name_To_Pointer
then
275 Expand_To_Pointer
(N
);
277 elsif Nam
= Name_File
278 or else Nam
= Name_Line
279 or else Nam
= Name_Source_Location
280 or else Nam
= Name_Enclosing_Entity
282 Expand_Source_Info
(N
, Nam
);
284 -- If we have a renaming, expand the call to the original operation,
285 -- which must itself be intrinsic, since renaming requires matching
286 -- conventions and this has already been checked.
288 elsif Present
(Alias
(E
)) then
289 Expand_Intrinsic_Call
(N
, Alias
(E
));
291 -- The only other case is where an external name was specified,
292 -- since this is the only way that an otherwise unrecognized
293 -- name could escape the checking in Sem_Prag. Nothing needs
294 -- to be done in such a case, since we pass such a call to the
295 -- back end unchanged.
300 end Expand_Intrinsic_Call
;
302 ------------------------
303 -- Expand_Is_Negative --
304 ------------------------
306 procedure Expand_Is_Negative
(N
: Node_Id
) is
307 Loc
: constant Source_Ptr
:= Sloc
(N
);
308 Opnd
: constant Node_Id
:= Relocate_Node
(First_Actual
(N
));
312 -- We replace the function call by the following expression
314 -- if Opnd < 0.0 then
317 -- if Opnd > 0.0 then
320 -- Float_Unsigned!(Float (Opnd)) /= 0
325 Make_Conditional_Expression
(Loc
,
326 Expressions
=> New_List
(
328 Left_Opnd
=> Duplicate_Subexpr
(Opnd
),
329 Right_Opnd
=> Make_Real_Literal
(Loc
, Ureal_0
)),
331 New_Occurrence_Of
(Standard_True
, Loc
),
333 Make_Conditional_Expression
(Loc
,
334 Expressions
=> New_List
(
336 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Opnd
),
337 Right_Opnd
=> Make_Real_Literal
(Loc
, Ureal_0
)),
339 New_Occurrence_Of
(Standard_False
, Loc
),
344 (RTE
(RE_Float_Unsigned
),
347 Duplicate_Subexpr_No_Checks
(Opnd
))),
349 Make_Integer_Literal
(Loc
, 0)))))));
351 Analyze_And_Resolve
(N
, Standard_Boolean
);
352 end Expand_Is_Negative
;
358 -- This procedure is used to convert a call to a shift function to the
359 -- corresponding operator node. This conversion is not done by the usual
360 -- circuit for converting calls to operator functions (e.g. "+"(1,2)) to
361 -- operator nodes, because shifts are not predefined operators.
363 -- As a result, whenever a shift is used in the source program, it will
364 -- remain as a call until converted by this routine to the operator node
365 -- form which Gigi is expecting to see.
367 -- Note: it is possible for the expander to generate shift operator nodes
368 -- directly, which will be analyzed in the normal manner by calling Analyze
369 -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift.
371 procedure Expand_Shift
(N
: Node_Id
; E
: Entity_Id
; K
: Node_Kind
) is
372 Loc
: constant Source_Ptr
:= Sloc
(N
);
373 Typ
: constant Entity_Id
:= Etype
(N
);
374 Left
: constant Node_Id
:= First_Actual
(N
);
375 Right
: constant Node_Id
:= Next_Actual
(Left
);
376 Ltyp
: constant Node_Id
:= Etype
(Left
);
377 Rtyp
: constant Node_Id
:= Etype
(Right
);
381 Snode
:= New_Node
(K
, Loc
);
382 Set_Left_Opnd
(Snode
, Relocate_Node
(Left
));
383 Set_Right_Opnd
(Snode
, Relocate_Node
(Right
));
384 Set_Chars
(Snode
, Chars
(E
));
385 Set_Etype
(Snode
, Base_Type
(Typ
));
386 Set_Entity
(Snode
, E
);
388 if Compile_Time_Known_Value
(Type_High_Bound
(Rtyp
))
389 and then Expr_Value
(Type_High_Bound
(Rtyp
)) < Esize
(Ltyp
)
391 Set_Shift_Count_OK
(Snode
, True);
394 -- Do the rewrite. Note that we don't call Analyze and Resolve on
395 -- this node, because it already got analyzed and resolved when
396 -- it was a function call!
402 ------------------------
403 -- Expand_Source_Info --
404 ------------------------
406 procedure Expand_Source_Info
(N
: Node_Id
; Nam
: Name_Id
) is
407 Loc
: constant Source_Ptr
:= Sloc
(N
);
413 if Nam
= Name_Line
then
415 Make_Integer_Literal
(Loc
,
416 Intval
=> UI_From_Int
(Int
(Get_Logical_Line_Number
(Loc
)))));
417 Analyze_And_Resolve
(N
, Standard_Positive
);
424 Get_Decoded_Name_String
425 (Reference_Name
(Get_Source_File_Index
(Loc
)));
427 when Name_Source_Location
=>
428 Build_Location_String
(Loc
);
430 when Name_Enclosing_Entity
=>
433 Ent
:= Current_Scope
;
435 -- Skip enclosing blocks to reach enclosing unit.
437 while Present
(Ent
) loop
438 exit when Ekind
(Ent
) /= E_Block
439 and then Ekind
(Ent
) /= E_Loop
;
443 -- Ent now points to the relevant defining entity
446 SDef
: Source_Ptr
:= Sloc
(Ent
);
447 TDef
: Source_Buffer_Ptr
;
450 TDef
:= Source_Text
(Get_Source_File_Index
(SDef
));
453 while TDef
(SDef
) in '0' .. '9'
454 or else TDef
(SDef
) >= 'A'
455 or else TDef
(SDef
) = ASCII
.ESC
457 Add_Char_To_Name_Buffer
(TDef
(SDef
));
467 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
));
468 Analyze_And_Resolve
(N
, Standard_String
);
471 Set_Is_Static_Expression
(N
);
472 end Expand_Source_Info
;
474 ---------------------------
475 -- Expand_Unc_Conversion --
476 ---------------------------
478 procedure Expand_Unc_Conversion
(N
: Node_Id
; E
: Entity_Id
) is
479 Func
: constant Entity_Id
:= Entity
(Name
(N
));
484 -- Rewrite as unchecked conversion node. Note that we must convert
485 -- the operand to the formal type of the input parameter of the
486 -- function, so that the resulting N_Unchecked_Type_Conversion
487 -- call indicates the correct types for Gigi.
489 -- Right now, we only do this if a scalar type is involved. It is
490 -- not clear if it is needed in other cases. If we do attempt to
491 -- do the conversion unconditionally, it crashes 3411-018. To be
492 -- investigated further ???
494 Conv
:= Relocate_Node
(First_Actual
(N
));
495 Ftyp
:= Etype
(First_Formal
(Func
));
497 if Is_Scalar_Type
(Ftyp
) then
498 Conv
:= Convert_To
(Ftyp
, Conv
);
499 Set_Parent
(Conv
, N
);
500 Analyze_And_Resolve
(Conv
);
503 -- We do the analysis here, because we do not want the compiler
504 -- to try to optimize or otherwise reorganize the unchecked
507 Rewrite
(N
, Unchecked_Convert_To
(Etype
(E
), Conv
));
508 Set_Etype
(N
, Etype
(E
));
511 if Nkind
(N
) = N_Unchecked_Type_Conversion
then
512 Expand_N_Unchecked_Type_Conversion
(N
);
514 end Expand_Unc_Conversion
;
516 -----------------------------
517 -- Expand_Unc_Deallocation --
518 -----------------------------
520 -- Generate the following Code :
522 -- if Arg /= null then
523 -- <Finalize_Call> (.., T'Class(Arg.all), ..); -- for controlled types
528 -- For a task, we also generate a call to Free_Task to ensure that the
529 -- task itself is freed if it is terminated, ditto for a simple protected
530 -- object, with a call to Finalize_Protection. For composite types that
531 -- have tasks or simple protected objects as components, we traverse the
532 -- structures to find and terminate those components.
534 procedure Expand_Unc_Deallocation
(N
: Node_Id
) is
535 Loc
: constant Source_Ptr
:= Sloc
(N
);
536 Arg
: constant Node_Id
:= First_Actual
(N
);
537 Typ
: constant Entity_Id
:= Etype
(Arg
);
538 Stmts
: constant List_Id
:= New_List
;
539 Rtyp
: constant Entity_Id
:= Underlying_Type
(Root_Type
(Typ
));
540 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Rtyp
);
542 Desig_T
: constant Entity_Id
:= Designated_Type
(Typ
);
551 if No_Pool_Assigned
(Rtyp
) then
552 Error_Msg_N
("?deallocation from empty storage pool", N
);
555 if Controlled_Type
(Desig_T
) then
557 Make_Explicit_Dereference
(Loc
,
558 Prefix
=> Duplicate_Subexpr_No_Checks
(Arg
));
560 -- If the type is tagged, then we must force dispatching on the
561 -- finalization call because the designated type may not be the
562 -- actual type of the object
564 if Is_Tagged_Type
(Desig_T
)
565 and then not Is_Class_Wide_Type
(Desig_T
)
567 Deref
:= Unchecked_Convert_To
(Class_Wide_Type
(Desig_T
), Deref
);
574 With_Detach
=> New_Reference_To
(Standard_True
, Loc
));
576 if Abort_Allowed
then
577 Prepend_To
(Free_Cod
,
578 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
581 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=>
582 Make_Handled_Sequence_Of_Statements
(Loc
,
583 Statements
=> Free_Cod
,
585 New_Occurrence_Of
(RTE
(RE_Abort_Undefer_Direct
), Loc
)));
587 -- We now expand the exception (at end) handler. We set a
588 -- temporary parent pointer since we have not attached Blk
593 Expand_At_End_Handler
594 (Handled_Statement_Sequence
(Blk
), Entity
(Identifier
(Blk
)));
598 Append_List_To
(Stmts
, Free_Cod
);
602 -- For a task type, call Free_Task before freeing the ATCB
604 if Is_Task_Type
(Desig_T
) then
606 Stat
: Node_Id
:= Prev
(N
);
611 -- An Abort followed by a Free will not do what the user
612 -- expects, because the abort is not immediate. This is
613 -- worth a friendly warning.
616 and then not Comes_From_Source
(Original_Node
(Stat
))
622 and then Nkind
(Original_Node
(Stat
)) = N_Abort_Statement
624 Stat
:= Original_Node
(Stat
);
625 Nam1
:= First
(Names
(Stat
));
626 Nam2
:= Original_Node
(First
(Parameter_Associations
(N
)));
628 if Nkind
(Nam1
) = N_Explicit_Dereference
629 and then Is_Entity_Name
(Prefix
(Nam1
))
630 and then Is_Entity_Name
(Nam2
)
631 and then Entity
(Prefix
(Nam1
)) = Entity
(Nam2
)
633 Error_Msg_N
("Abort may take time to complete?", N
);
634 Error_Msg_N
("\deallocation might have no effect?", N
);
635 Error_Msg_N
("\safer to wait for termination.?", N
);
641 (Stmts
, Cleanup_Task
(N
, Duplicate_Subexpr_No_Checks
(Arg
)));
643 -- For composite types that contain tasks, recurse over the structure
644 -- to build the selectors for the task subcomponents.
646 elsif Has_Task
(Desig_T
) then
647 if Is_Record_Type
(Desig_T
) then
648 Append_List_To
(Stmts
, Cleanup_Record
(N
, Arg
, Desig_T
));
650 elsif Is_Array_Type
(Desig_T
) then
651 Append_List_To
(Stmts
, Cleanup_Array
(N
, Arg
, Desig_T
));
655 -- Same for simple protected types. Eventually call Finalize_Protection
656 -- before freeing the PO for each protected component.
658 if Is_Simple_Protected_Type
(Desig_T
) then
660 Cleanup_Protected_Object
(N
, Duplicate_Subexpr_No_Checks
(Arg
)));
662 elsif Has_Simple_Protected_Object
(Desig_T
) then
663 if Is_Record_Type
(Desig_T
) then
664 Append_List_To
(Stmts
, Cleanup_Record
(N
, Arg
, Desig_T
));
665 elsif Is_Array_Type
(Desig_T
) then
666 Append_List_To
(Stmts
, Cleanup_Array
(N
, Arg
, Desig_T
));
670 -- Normal processing for non-controlled types
672 Free_Arg
:= Duplicate_Subexpr_No_Checks
(Arg
);
673 Free_Node
:= Make_Free_Statement
(Loc
, Empty
);
674 Append_To
(Stmts
, Free_Node
);
675 Set_Storage_Pool
(Free_Node
, Pool
);
677 -- Make implicit if statement. We omit this if we are the then part
678 -- of a test of the form:
680 -- if not (Arg = null) then
682 -- i.e. if the test is explicit in the source. Arg must be a simple
683 -- identifier for the purposes of this special test. Note that the
684 -- use of /= in the source is always transformed into the above form.
687 Test_Needed
: Boolean := True;
688 P
: constant Node_Id
:= Parent
(N
);
692 if Nkind
(Arg
) = N_Identifier
693 and then Nkind
(P
) = N_If_Statement
694 and then First
(Then_Statements
(P
)) = N
696 if Nkind
(Condition
(P
)) = N_Op_Not
then
697 C
:= Right_Opnd
(Condition
(P
));
699 if Nkind
(C
) = N_Op_Eq
700 and then Nkind
(Left_Opnd
(C
)) = N_Identifier
701 and then Chars
(Arg
) = Chars
(Left_Opnd
(C
))
702 and then Nkind
(Right_Opnd
(C
)) = N_Null
704 Test_Needed
:= False;
709 -- Generate If_Statement if needed
713 Make_Implicit_If_Statement
(N
,
716 Left_Opnd
=> Duplicate_Subexpr
(Arg
),
717 Right_Opnd
=> Make_Null
(Loc
)),
718 Then_Statements
=> Stmts
);
722 Make_Block_Statement
(Loc
,
723 Handled_Statement_Sequence
=>
724 Make_Handled_Sequence_Of_Statements
(Loc
,
725 Statements
=> Stmts
));
729 -- Deal with storage pool
731 if Present
(Pool
) then
733 -- Freeing the secondary stack is meaningless
735 if Is_RTE
(Pool
, RE_SS_Pool
) then
738 elsif Is_Class_Wide_Type
(Etype
(Pool
)) then
739 Set_Procedure_To_Call
(Free_Node
,
740 RTE
(RE_Deallocate_Any
));
742 Set_Procedure_To_Call
(Free_Node
,
743 Find_Prim_Op
(Etype
(Pool
), Name_Deallocate
));
745 -- If the type is class wide, we generate an implicit type
746 -- with the right dynamic size, so that the deallocate call
747 -- gets the right size parameter computed by gigi
749 if Is_Class_Wide_Type
(Desig_T
) then
751 Acc_Type
: constant Entity_Id
:=
752 Create_Itype
(E_Access_Type
, N
);
753 Deref
: constant Node_Id
:=
754 Make_Explicit_Dereference
(Loc
,
755 Duplicate_Subexpr_No_Checks
(Arg
));
758 Set_Etype
(Deref
, Typ
);
759 Set_Parent
(Deref
, Free_Node
);
761 Set_Etype
(Acc_Type
, Acc_Type
);
762 Set_Size_Info
(Acc_Type
, Typ
);
763 Set_Directly_Designated_Type
764 (Acc_Type
, Entity
(Make_Subtype_From_Expr
767 Free_Arg
:= Unchecked_Convert_To
(Acc_Type
, Free_Arg
);
773 Set_Expression
(Free_Node
, Free_Arg
);
776 Lhs
: constant Node_Id
:= Duplicate_Subexpr_No_Checks
(Arg
);
779 Set_Assignment_OK
(Lhs
);
781 Make_Assignment_Statement
(Loc
,
783 Expression
=> Make_Null
(Loc
)));
786 Rewrite
(N
, Gen_Code
);
788 end Expand_Unc_Deallocation
;
790 -----------------------
791 -- Expand_To_Address --
792 -----------------------
794 procedure Expand_To_Address
(N
: Node_Id
) is
795 Loc
: constant Source_Ptr
:= Sloc
(N
);
796 Arg
: constant Node_Id
:= First_Actual
(N
);
800 Remove_Side_Effects
(Arg
);
802 Obj
:= Make_Explicit_Dereference
(Loc
, Relocate_Node
(Arg
));
805 Make_Conditional_Expression
(Loc
,
806 Expressions
=> New_List
(
808 Left_Opnd
=> New_Copy_Tree
(Arg
),
809 Right_Opnd
=> Make_Null
(Loc
)),
810 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
811 Make_Attribute_Reference
(Loc
,
812 Attribute_Name
=> Name_Address
,
815 Analyze_And_Resolve
(N
, RTE
(RE_Address
));
816 end Expand_To_Address
;
818 -----------------------
819 -- Expand_To_Pointer --
820 -----------------------
822 procedure Expand_To_Pointer
(N
: Node_Id
) is
823 Arg
: constant Node_Id
:= First_Actual
(N
);
826 Rewrite
(N
, Unchecked_Convert_To
(Etype
(N
), Arg
));
828 end Expand_To_Pointer
;