2014-10-31 Hristian Kirtchev <kirtchev@adacore.com>
[official-gcc.git] / gcc / ada / tbuild.adb
blobcd535cf9ab55170c6b85d75b50b4a04fd629756c
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- T B U I L D --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2014, 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 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Csets; use Csets;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Lib; use Lib;
31 with Nlists; use Nlists;
32 with Nmake; use Nmake;
33 with Opt; use Opt;
34 with Restrict; use Restrict;
35 with Rident; use Rident;
36 with Sem_Aux; use Sem_Aux;
37 with Snames; use Snames;
38 with Stand; use Stand;
39 with Stringt; use Stringt;
40 with Urealp; use Urealp;
42 package body Tbuild is
44 -----------------------
45 -- Local Subprograms --
46 -----------------------
48 procedure Add_Unique_Serial_Number;
49 -- Add a unique serialization to the string in the Name_Buffer. This
50 -- consists of a unit specific serial number, and b/s for body/spec.
52 ------------------------------
53 -- Add_Unique_Serial_Number --
54 ------------------------------
56 Config_Serial_Number : Nat := 0;
57 -- Counter for use in config pragmas, see comment below
59 procedure Add_Unique_Serial_Number is
60 begin
61 -- If we are analyzing configuration pragmas, Cunit (Main_Unit) will
62 -- not be set yet. This happens for example when analyzing static
63 -- string expressions in configuration pragmas. For this case, we
64 -- just maintain a local counter, defined above and we do not need
65 -- to add a b or s indication in this case.
67 if No (Cunit (Current_Sem_Unit)) then
68 Config_Serial_Number := Config_Serial_Number + 1;
69 Add_Nat_To_Name_Buffer (Config_Serial_Number);
70 return;
72 -- Normal case, within a unit
74 else
75 declare
76 Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
78 begin
79 Add_Nat_To_Name_Buffer (Increment_Serial_Number);
81 -- Add either b or s, depending on whether current unit is a spec
82 -- or a body. This is needed because we may generate the same name
83 -- in a spec and a body otherwise.
85 Name_Len := Name_Len + 1;
87 if Nkind (Unit_Node) = N_Package_Declaration
88 or else Nkind (Unit_Node) = N_Subprogram_Declaration
89 or else Nkind (Unit_Node) in N_Generic_Declaration
90 then
91 Name_Buffer (Name_Len) := 's';
92 else
93 Name_Buffer (Name_Len) := 'b';
94 end if;
95 end;
96 end if;
97 end Add_Unique_Serial_Number;
99 ----------------
100 -- Checks_Off --
101 ----------------
103 function Checks_Off (N : Node_Id) return Node_Id is
104 begin
105 return
106 Make_Unchecked_Expression (Sloc (N),
107 Expression => N);
108 end Checks_Off;
110 ----------------
111 -- Convert_To --
112 ----------------
114 function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
115 Result : Node_Id;
117 begin
118 if Present (Etype (Expr))
119 and then (Etype (Expr)) = Typ
120 then
121 return Relocate_Node (Expr);
122 else
123 Result :=
124 Make_Type_Conversion (Sloc (Expr),
125 Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
126 Expression => Relocate_Node (Expr));
128 Set_Etype (Result, Typ);
129 return Result;
130 end if;
131 end Convert_To;
133 ----------------------------
134 -- Convert_To_And_Rewrite --
135 ----------------------------
137 procedure Convert_To_And_Rewrite (Typ : Entity_Id; Expr : Node_Id) is
138 begin
139 Rewrite (Expr, Convert_To (Typ, Expr));
140 end Convert_To_And_Rewrite;
142 ------------------
143 -- Discard_List --
144 ------------------
146 procedure Discard_List (L : List_Id) is
147 pragma Warnings (Off, L);
148 begin
149 null;
150 end Discard_List;
152 ------------------
153 -- Discard_Node --
154 ------------------
156 procedure Discard_Node (N : Node_Or_Entity_Id) is
157 pragma Warnings (Off, N);
158 begin
159 null;
160 end Discard_Node;
162 -------------------------------------------
163 -- Make_Byte_Aligned_Attribute_Reference --
164 -------------------------------------------
166 function Make_Byte_Aligned_Attribute_Reference
167 (Sloc : Source_Ptr;
168 Prefix : Node_Id;
169 Attribute_Name : Name_Id)
170 return Node_Id
172 N : constant Node_Id :=
173 Make_Attribute_Reference (Sloc,
174 Prefix => Prefix,
175 Attribute_Name => Attribute_Name);
177 begin
178 pragma Assert (Nam_In (Attribute_Name, Name_Address,
179 Name_Unrestricted_Access));
180 Set_Must_Be_Byte_Aligned (N, True);
181 return N;
182 end Make_Byte_Aligned_Attribute_Reference;
184 --------------------
185 -- Make_DT_Access --
186 --------------------
188 function Make_DT_Access
189 (Loc : Source_Ptr;
190 Rec : Node_Id;
191 Typ : Entity_Id) return Node_Id
193 Full_Type : Entity_Id := Typ;
195 begin
196 if Is_Private_Type (Typ) then
197 Full_Type := Underlying_Type (Typ);
198 end if;
200 return
201 Unchecked_Convert_To (
202 New_Occurrence_Of
203 (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),
204 Make_Selected_Component (Loc,
205 Prefix => New_Copy (Rec),
206 Selector_Name =>
207 New_Occurrence_Of (First_Tag_Component (Full_Type), Loc)));
208 end Make_DT_Access;
210 ------------------------
211 -- Make_Float_Literal --
212 ------------------------
214 function Make_Float_Literal
215 (Loc : Source_Ptr;
216 Radix : Uint;
217 Significand : Uint;
218 Exponent : Uint) return Node_Id
220 begin
221 if Radix = 2 and then abs Significand /= 1 then
222 return
223 Make_Float_Literal
224 (Loc, Uint_16,
225 Significand * Radix**(Exponent mod 4),
226 Exponent / 4);
228 else
229 declare
230 N : constant Node_Id := New_Node (N_Real_Literal, Loc);
232 begin
233 Set_Realval (N,
234 UR_From_Components
235 (Num => abs Significand,
236 Den => -Exponent,
237 Rbase => UI_To_Int (Radix),
238 Negative => Significand < 0));
239 return N;
240 end;
241 end if;
242 end Make_Float_Literal;
244 -------------
245 -- Make_Id --
246 -------------
248 function Make_Id (Str : Text_Buffer) return Node_Id is
249 begin
250 Name_Len := 0;
252 for J in Str'Range loop
253 Name_Len := Name_Len + 1;
254 Name_Buffer (Name_Len) := Fold_Lower (Str (J));
255 end loop;
257 return
258 Make_Identifier (System_Location,
259 Chars => Name_Find);
260 end Make_Id;
262 -------------------------------------
263 -- Make_Implicit_Exception_Handler --
264 -------------------------------------
266 function Make_Implicit_Exception_Handler
267 (Sloc : Source_Ptr;
268 Choice_Parameter : Node_Id := Empty;
269 Exception_Choices : List_Id;
270 Statements : List_Id) return Node_Id
272 Handler : Node_Id;
273 Loc : Source_Ptr;
275 begin
276 -- Set the source location only when debugging the expanded code
278 -- When debugging the source code directly, we do not want the compiler
279 -- to associate this implicit exception handler with any specific source
280 -- line, because it can potentially confuse the debugger. The most
281 -- damaging situation would arise when the debugger tries to insert a
282 -- breakpoint at a certain line. If the code of the associated implicit
283 -- exception handler is generated before the code of that line, then the
284 -- debugger will end up inserting the breakpoint inside the exception
285 -- handler, rather than the code the user intended to break on. As a
286 -- result, it is likely that the program will not hit the breakpoint
287 -- as expected.
289 if Debug_Generated_Code then
290 Loc := Sloc;
291 else
292 Loc := No_Location;
293 end if;
295 Handler :=
296 Make_Exception_Handler
297 (Loc, Choice_Parameter, Exception_Choices, Statements);
298 Set_Local_Raise_Statements (Handler, No_Elist);
299 return Handler;
300 end Make_Implicit_Exception_Handler;
302 --------------------------------
303 -- Make_Implicit_If_Statement --
304 --------------------------------
306 function Make_Implicit_If_Statement
307 (Node : Node_Id;
308 Condition : Node_Id;
309 Then_Statements : List_Id;
310 Elsif_Parts : List_Id := No_List;
311 Else_Statements : List_Id := No_List) return Node_Id
313 begin
314 Check_Restriction (No_Implicit_Conditionals, Node);
316 return Make_If_Statement (Sloc (Node),
317 Condition,
318 Then_Statements,
319 Elsif_Parts,
320 Else_Statements);
321 end Make_Implicit_If_Statement;
323 -------------------------------------
324 -- Make_Implicit_Label_Declaration --
325 -------------------------------------
327 function Make_Implicit_Label_Declaration
328 (Loc : Source_Ptr;
329 Defining_Identifier : Node_Id;
330 Label_Construct : Node_Id) return Node_Id
332 N : constant Node_Id :=
333 Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
334 begin
335 Set_Label_Construct (N, Label_Construct);
336 return N;
337 end Make_Implicit_Label_Declaration;
339 ----------------------------------
340 -- Make_Implicit_Loop_Statement --
341 ----------------------------------
343 function Make_Implicit_Loop_Statement
344 (Node : Node_Id;
345 Statements : List_Id;
346 Identifier : Node_Id := Empty;
347 Iteration_Scheme : Node_Id := Empty;
348 Has_Created_Identifier : Boolean := False;
349 End_Label : Node_Id := Empty) return Node_Id
351 begin
352 Check_Restriction (No_Implicit_Loops, Node);
354 if Present (Iteration_Scheme)
355 and then Present (Condition (Iteration_Scheme))
356 then
357 Check_Restriction (No_Implicit_Conditionals, Node);
358 end if;
360 return Make_Loop_Statement (Sloc (Node),
361 Identifier => Identifier,
362 Iteration_Scheme => Iteration_Scheme,
363 Statements => Statements,
364 Has_Created_Identifier => Has_Created_Identifier,
365 End_Label => End_Label);
366 end Make_Implicit_Loop_Statement;
368 --------------------------
369 -- Make_Integer_Literal --
370 ---------------------------
372 function Make_Integer_Literal
373 (Loc : Source_Ptr;
374 Intval : Int) return Node_Id
376 begin
377 return Make_Integer_Literal (Loc, UI_From_Int (Intval));
378 end Make_Integer_Literal;
380 --------------------------------
381 -- Make_Linker_Section_Pragma --
382 --------------------------------
384 function Make_Linker_Section_Pragma
385 (Ent : Entity_Id;
386 Loc : Source_Ptr;
387 Sec : String) return Node_Id
389 LS : Node_Id;
391 begin
392 LS :=
393 Make_Pragma
394 (Loc,
395 Name_Linker_Section,
396 New_List
397 (Make_Pragma_Argument_Association
398 (Sloc => Loc,
399 Expression => New_Occurrence_Of (Ent, Loc)),
400 Make_Pragma_Argument_Association
401 (Sloc => Loc,
402 Expression =>
403 Make_String_Literal
404 (Sloc => Loc,
405 Strval => Sec))));
407 Set_Has_Gigi_Rep_Item (Ent);
408 return LS;
409 end Make_Linker_Section_Pragma;
411 -----------------
412 -- Make_Pragma --
413 -----------------
415 function Make_Pragma
416 (Sloc : Source_Ptr;
417 Chars : Name_Id;
418 Pragma_Argument_Associations : List_Id := No_List) return Node_Id
420 begin
421 return
422 Make_Pragma (Sloc,
423 Pragma_Argument_Associations => Pragma_Argument_Associations,
424 Pragma_Identifier => Make_Identifier (Sloc, Chars));
425 end Make_Pragma;
427 ---------------------------------
428 -- Make_Raise_Constraint_Error --
429 ---------------------------------
431 function Make_Raise_Constraint_Error
432 (Sloc : Source_Ptr;
433 Condition : Node_Id := Empty;
434 Reason : RT_Exception_Code) return Node_Id
436 begin
437 pragma Assert (Rkind (Reason) = CE_Reason);
438 return
439 Make_Raise_Constraint_Error (Sloc,
440 Condition => Condition,
441 Reason => UI_From_Int (RT_Exception_Code'Pos (Reason)));
442 end Make_Raise_Constraint_Error;
444 ------------------------------
445 -- Make_Raise_Program_Error --
446 ------------------------------
448 function Make_Raise_Program_Error
449 (Sloc : Source_Ptr;
450 Condition : Node_Id := Empty;
451 Reason : RT_Exception_Code) return Node_Id
453 begin
454 pragma Assert (Rkind (Reason) = PE_Reason);
455 return
456 Make_Raise_Program_Error (Sloc,
457 Condition => Condition,
458 Reason => UI_From_Int (RT_Exception_Code'Pos (Reason)));
459 end Make_Raise_Program_Error;
461 ------------------------------
462 -- Make_Raise_Storage_Error --
463 ------------------------------
465 function Make_Raise_Storage_Error
466 (Sloc : Source_Ptr;
467 Condition : Node_Id := Empty;
468 Reason : RT_Exception_Code) return Node_Id
470 begin
471 pragma Assert (Rkind (Reason) = SE_Reason);
472 return
473 Make_Raise_Storage_Error (Sloc,
474 Condition => Condition,
475 Reason => UI_From_Int (RT_Exception_Code'Pos (Reason)));
476 end Make_Raise_Storage_Error;
478 -------------
479 -- Make_SC --
480 -------------
482 function Make_SC (Pre, Sel : Node_Id) return Node_Id is
483 begin
484 return
485 Make_Selected_Component (System_Location,
486 Prefix => Pre,
487 Selector_Name => Sel);
488 end Make_SC;
490 -------------------------
491 -- Make_String_Literal --
492 -------------------------
494 function Make_String_Literal
495 (Sloc : Source_Ptr;
496 Strval : String) return Node_Id
498 begin
499 Start_String;
500 Store_String_Chars (Strval);
501 return Make_String_Literal (Sloc, Strval => End_String);
502 end Make_String_Literal;
504 --------------------
505 -- Make_Temporary --
506 --------------------
508 function Make_Temporary
509 (Loc : Source_Ptr;
510 Id : Character;
511 Related_Node : Node_Id := Empty) return Entity_Id
513 Temp : constant Entity_Id :=
514 Make_Defining_Identifier (Loc, Chars => New_Internal_Name (Id));
515 begin
516 Set_Related_Expression (Temp, Related_Node);
517 return Temp;
518 end Make_Temporary;
520 ---------------------------
521 -- Make_Unsuppress_Block --
522 ---------------------------
524 -- Generates the following expansion:
526 -- declare
527 -- pragma Suppress (<check>);
528 -- begin
529 -- <stmts>
530 -- end;
532 function Make_Unsuppress_Block
533 (Loc : Source_Ptr;
534 Check : Name_Id;
535 Stmts : List_Id) return Node_Id
537 begin
538 return
539 Make_Block_Statement (Loc,
540 Declarations => New_List (
541 Make_Pragma (Loc,
542 Chars => Name_Suppress,
543 Pragma_Argument_Associations => New_List (
544 Make_Pragma_Argument_Association (Loc,
545 Expression => Make_Identifier (Loc, Check))))),
547 Handled_Statement_Sequence =>
548 Make_Handled_Sequence_Of_Statements (Loc,
549 Statements => Stmts));
550 end Make_Unsuppress_Block;
552 --------------------------
553 -- New_Constraint_Error --
554 --------------------------
556 function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
557 Ident_Node : Node_Id;
558 Raise_Node : Node_Id;
560 begin
561 Ident_Node := New_Node (N_Identifier, Loc);
562 Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
563 Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
564 Raise_Node := New_Node (N_Raise_Statement, Loc);
565 Set_Name (Raise_Node, Ident_Node);
566 return Raise_Node;
567 end New_Constraint_Error;
569 -----------------------
570 -- New_External_Name --
571 -----------------------
573 function New_External_Name
574 (Related_Id : Name_Id;
575 Suffix : Character := ' ';
576 Suffix_Index : Int := 0;
577 Prefix : Character := ' ') return Name_Id
579 begin
580 Get_Name_String (Related_Id);
582 if Prefix /= ' ' then
583 pragma Assert (Is_OK_Internal_Letter (Prefix) or else Prefix = '_');
585 for J in reverse 1 .. Name_Len loop
586 Name_Buffer (J + 1) := Name_Buffer (J);
587 end loop;
589 Name_Len := Name_Len + 1;
590 Name_Buffer (1) := Prefix;
591 end if;
593 if Suffix /= ' ' then
594 pragma Assert (Is_OK_Internal_Letter (Suffix));
595 Add_Char_To_Name_Buffer (Suffix);
596 end if;
598 if Suffix_Index /= 0 then
599 if Suffix_Index < 0 then
600 Add_Unique_Serial_Number;
601 else
602 Add_Nat_To_Name_Buffer (Suffix_Index);
603 end if;
604 end if;
606 return Name_Find;
607 end New_External_Name;
609 function New_External_Name
610 (Related_Id : Name_Id;
611 Suffix : String;
612 Suffix_Index : Int := 0;
613 Prefix : Character := ' ') return Name_Id
615 begin
616 Get_Name_String (Related_Id);
618 if Prefix /= ' ' then
619 pragma Assert (Is_OK_Internal_Letter (Prefix));
621 for J in reverse 1 .. Name_Len loop
622 Name_Buffer (J + 1) := Name_Buffer (J);
623 end loop;
625 Name_Len := Name_Len + 1;
626 Name_Buffer (1) := Prefix;
627 end if;
629 if Suffix /= "" then
630 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
631 Name_Len := Name_Len + Suffix'Length;
632 end if;
634 if Suffix_Index /= 0 then
635 if Suffix_Index < 0 then
636 Add_Unique_Serial_Number;
637 else
638 Add_Nat_To_Name_Buffer (Suffix_Index);
639 end if;
640 end if;
642 return Name_Find;
643 end New_External_Name;
645 function New_External_Name
646 (Suffix : Character;
647 Suffix_Index : Nat) return Name_Id
649 begin
650 Name_Buffer (1) := Suffix;
651 Name_Len := 1;
652 Add_Nat_To_Name_Buffer (Suffix_Index);
653 return Name_Find;
654 end New_External_Name;
656 -----------------------
657 -- New_Internal_Name --
658 -----------------------
660 function New_Internal_Name (Id_Char : Character) return Name_Id is
661 begin
662 pragma Assert (Is_OK_Internal_Letter (Id_Char));
663 Name_Buffer (1) := Id_Char;
664 Name_Len := 1;
665 Add_Unique_Serial_Number;
666 return Name_Enter;
667 end New_Internal_Name;
669 -----------------------
670 -- New_Occurrence_Of --
671 -----------------------
673 function New_Occurrence_Of
674 (Def_Id : Entity_Id;
675 Loc : Source_Ptr) return Node_Id
677 pragma Assert (Present (Def_Id) and then Nkind (Def_Id) in N_Entity);
678 Occurrence : Node_Id;
680 begin
681 Occurrence := New_Node (N_Identifier, Loc);
682 Set_Chars (Occurrence, Chars (Def_Id));
683 Set_Entity (Occurrence, Def_Id);
685 if Is_Type (Def_Id) then
686 Set_Etype (Occurrence, Def_Id);
687 else
688 Set_Etype (Occurrence, Etype (Def_Id));
689 end if;
691 if Ekind (Def_Id) = E_Enumeration_Literal then
692 Set_Is_Static_Expression (Occurrence, True);
693 end if;
695 return Occurrence;
696 end New_Occurrence_Of;
698 -----------------
699 -- New_Op_Node --
700 -----------------
702 function New_Op_Node
703 (New_Node_Kind : Node_Kind;
704 New_Sloc : Source_Ptr) return Node_Id
706 type Name_Of_Type is array (N_Op) of Name_Id;
707 Name_Of : constant Name_Of_Type := Name_Of_Type'(
708 N_Op_And => Name_Op_And,
709 N_Op_Or => Name_Op_Or,
710 N_Op_Xor => Name_Op_Xor,
711 N_Op_Eq => Name_Op_Eq,
712 N_Op_Ne => Name_Op_Ne,
713 N_Op_Lt => Name_Op_Lt,
714 N_Op_Le => Name_Op_Le,
715 N_Op_Gt => Name_Op_Gt,
716 N_Op_Ge => Name_Op_Ge,
717 N_Op_Add => Name_Op_Add,
718 N_Op_Subtract => Name_Op_Subtract,
719 N_Op_Concat => Name_Op_Concat,
720 N_Op_Multiply => Name_Op_Multiply,
721 N_Op_Divide => Name_Op_Divide,
722 N_Op_Mod => Name_Op_Mod,
723 N_Op_Rem => Name_Op_Rem,
724 N_Op_Expon => Name_Op_Expon,
725 N_Op_Plus => Name_Op_Add,
726 N_Op_Minus => Name_Op_Subtract,
727 N_Op_Abs => Name_Op_Abs,
728 N_Op_Not => Name_Op_Not,
730 -- We don't really need these shift operators, since they never
731 -- appear as operators in the source, but the path of least
732 -- resistance is to put them in (the aggregate must be complete).
734 N_Op_Rotate_Left => Name_Rotate_Left,
735 N_Op_Rotate_Right => Name_Rotate_Right,
736 N_Op_Shift_Left => Name_Shift_Left,
737 N_Op_Shift_Right => Name_Shift_Right,
738 N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic);
740 Nod : constant Node_Id := New_Node (New_Node_Kind, New_Sloc);
742 begin
743 if New_Node_Kind in Name_Of'Range then
744 Set_Chars (Nod, Name_Of (New_Node_Kind));
745 end if;
747 return Nod;
748 end New_Op_Node;
750 -----------------------
751 -- New_Suffixed_Name --
752 -----------------------
754 function New_Suffixed_Name
755 (Related_Id : Name_Id;
756 Suffix : String) return Name_Id
758 begin
759 Get_Name_String (Related_Id);
760 Add_Char_To_Name_Buffer ('_');
761 Add_Str_To_Name_Buffer (Suffix);
762 return Name_Find;
763 end New_Suffixed_Name;
765 -------------------
766 -- OK_Convert_To --
767 -------------------
769 function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
770 Result : Node_Id;
771 begin
772 Result :=
773 Make_Type_Conversion (Sloc (Expr),
774 Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
775 Expression => Relocate_Node (Expr));
776 Set_Conversion_OK (Result, True);
777 Set_Etype (Result, Typ);
778 return Result;
779 end OK_Convert_To;
781 -------------
782 -- Set_RND --
783 -------------
785 procedure Set_RND (Unit : Node_Id) is
786 begin
787 Set_Restriction_No_Dependence (Unit, Warn => False);
788 end Set_RND;
790 --------------------------
791 -- Unchecked_Convert_To --
792 --------------------------
794 function Unchecked_Convert_To
795 (Typ : Entity_Id;
796 Expr : Node_Id) return Node_Id
798 Loc : constant Source_Ptr := Sloc (Expr);
799 Result : Node_Id;
800 Expr_Parent : Node_Id;
802 begin
803 -- If the expression is already of the correct type, then nothing
804 -- to do, except for relocating the node in case this is required.
806 if Present (Etype (Expr))
807 and then (Base_Type (Etype (Expr)) = Typ
808 or else Etype (Expr) = Typ)
809 then
810 return Relocate_Node (Expr);
812 -- Cases where the inner expression is itself an unchecked conversion
813 -- to the same type, and we can thus eliminate the outer conversion.
815 elsif Nkind (Expr) = N_Unchecked_Type_Conversion
816 and then Entity (Subtype_Mark (Expr)) = Typ
817 then
818 Result := Relocate_Node (Expr);
820 elsif Nkind (Expr) = N_Null
821 and then Is_Access_Type (Typ)
822 then
823 -- No need for a conversion
825 Result := Relocate_Node (Expr);
827 -- All other cases
829 else
830 -- Capture the parent of the expression before relocating it and
831 -- creating the conversion, so the conversion's parent can be set
832 -- to the original parent below.
834 Expr_Parent := Parent (Expr);
836 Result :=
837 Make_Unchecked_Type_Conversion (Loc,
838 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
839 Expression => Relocate_Node (Expr));
841 Set_Parent (Result, Expr_Parent);
842 end if;
844 Set_Etype (Result, Typ);
845 return Result;
846 end Unchecked_Convert_To;
848 end Tbuild;