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