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-2018, 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
26with Atree;    use Atree;
27with Aspects;  use Aspects;
28with Csets;    use Csets;
29with Einfo;    use Einfo;
30with Elists;   use Elists;
31with Lib;      use Lib;
32with Nlists;   use Nlists;
33with Nmake;    use Nmake;
34with Opt;      use Opt;
35with Restrict; use Restrict;
36with Rident;   use Rident;
37with Sem_Aux;  use Sem_Aux;
38with Snames;   use Snames;
39with Stand;    use Stand;
40with Stringt;  use Stringt;
41with Urealp;   use Urealp;
42
43package 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
892end Tbuild;
893