1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 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 Elists; use Elists;
31 with Namet; use Namet;
32 with Nlists; use Nlists;
33 with Nmake; use Nmake;
34 with Restrict; use Restrict;
35 with Rident; use Rident;
36 with Sinfo; use Sinfo;
37 with Snames; use Snames;
38 with Stand; use Stand;
39 with Stringt; use Stringt;
40 with Uintp; use Uintp;
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 procedure Add_Unique_Serial_Number is
57 Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
60 Add_Nat_To_Name_Buffer (Increment_Serial_Number);
62 -- Add either b or s, depending on whether current unit is a spec
63 -- or a body. This is needed because we may generate the same name
64 -- in a spec and a body otherwise.
66 Name_Len := Name_Len + 1;
68 if Nkind (Unit_Node) = N_Package_Declaration
69 or else Nkind (Unit_Node) = N_Subprogram_Declaration
70 or else Nkind (Unit_Node) in N_Generic_Declaration
72 Name_Buffer (Name_Len) := 's';
74 Name_Buffer (Name_Len) := 'b';
76 end Add_Unique_Serial_Number;
82 function Checks_Off (N : Node_Id) return Node_Id is
85 Make_Unchecked_Expression (Sloc (N),
93 function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
97 if Present (Etype (Expr))
98 and then (Etype (Expr)) = Typ
100 return Relocate_Node (Expr);
103 Make_Type_Conversion (Sloc (Expr),
104 Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
105 Expression => Relocate_Node (Expr));
107 Set_Etype (Result, Typ);
116 procedure Discard_List (L : List_Id) is
117 pragma Warnings (Off, L);
126 procedure Discard_Node (N : Node_Or_Entity_Id) is
127 pragma Warnings (Off, N);
132 -------------------------------------------
133 -- Make_Byte_Aligned_Attribute_Reference --
134 -------------------------------------------
136 function Make_Byte_Aligned_Attribute_Reference
139 Attribute_Name : Name_Id)
142 N : constant Node_Id :=
143 Make_Attribute_Reference (Sloc,
145 Attribute_Name => Attribute_Name);
148 pragma Assert (Attribute_Name = Name_Address
150 Attribute_Name = Name_Unrestricted_Access);
151 Set_Must_Be_Byte_Aligned (N, True);
153 end Make_Byte_Aligned_Attribute_Reference;
159 function Make_DT_Access
162 Typ : Entity_Id) return Node_Id
164 Full_Type : Entity_Id := Typ;
167 if Is_Private_Type (Typ) then
168 Full_Type := Underlying_Type (Typ);
172 Unchecked_Convert_To (
174 (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),
175 Make_Selected_Component (Loc,
176 Prefix => New_Copy (Rec),
178 New_Reference_To (First_Tag_Component (Full_Type), Loc)));
181 --------------------------------
182 -- Make_Implicit_If_Statement --
183 --------------------------------
185 function Make_Implicit_If_Statement
188 Then_Statements : List_Id;
189 Elsif_Parts : List_Id := No_List;
190 Else_Statements : List_Id := No_List) return Node_Id
193 Check_Restriction (No_Implicit_Conditionals, Node);
195 return Make_If_Statement (Sloc (Node),
200 end Make_Implicit_If_Statement;
202 -------------------------------------
203 -- Make_Implicit_Label_Declaration --
204 -------------------------------------
206 function Make_Implicit_Label_Declaration
208 Defining_Identifier : Node_Id;
209 Label_Construct : Node_Id) return Node_Id
211 N : constant Node_Id :=
212 Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
214 Set_Label_Construct (N, Label_Construct);
216 end Make_Implicit_Label_Declaration;
218 ----------------------------------
219 -- Make_Implicit_Loop_Statement --
220 ----------------------------------
222 function Make_Implicit_Loop_Statement
224 Statements : List_Id;
225 Identifier : Node_Id := Empty;
226 Iteration_Scheme : Node_Id := Empty;
227 Has_Created_Identifier : Boolean := False;
228 End_Label : Node_Id := Empty) return Node_Id
231 Check_Restriction (No_Implicit_Loops, Node);
233 if Present (Iteration_Scheme)
234 and then Present (Condition (Iteration_Scheme))
236 Check_Restriction (No_Implicit_Conditionals, Node);
239 return Make_Loop_Statement (Sloc (Node),
240 Identifier => Identifier,
241 Iteration_Scheme => Iteration_Scheme,
242 Statements => Statements,
243 Has_Created_Identifier => Has_Created_Identifier,
244 End_Label => End_Label);
245 end Make_Implicit_Loop_Statement;
247 --------------------------
248 -- Make_Integer_Literal --
249 ---------------------------
251 function Make_Integer_Literal
253 Intval : Int) return Node_Id
256 return Make_Integer_Literal (Loc, UI_From_Int (Intval));
257 end Make_Integer_Literal;
259 ---------------------------------
260 -- Make_Raise_Constraint_Error --
261 ---------------------------------
263 function Make_Raise_Constraint_Error
265 Condition : Node_Id := Empty;
266 Reason : RT_Exception_Code) return Node_Id
269 pragma Assert (Reason in RT_CE_Exceptions);
271 Make_Raise_Constraint_Error (Sloc,
272 Condition => Condition,
274 UI_From_Int (RT_Exception_Code'Pos (Reason)));
275 end Make_Raise_Constraint_Error;
277 ------------------------------
278 -- Make_Raise_Program_Error --
279 ------------------------------
281 function Make_Raise_Program_Error
283 Condition : Node_Id := Empty;
284 Reason : RT_Exception_Code) return Node_Id
287 pragma Assert (Reason in RT_PE_Exceptions);
289 Make_Raise_Program_Error (Sloc,
290 Condition => Condition,
292 UI_From_Int (RT_Exception_Code'Pos (Reason)));
293 end Make_Raise_Program_Error;
295 ------------------------------
296 -- Make_Raise_Storage_Error --
297 ------------------------------
299 function Make_Raise_Storage_Error
301 Condition : Node_Id := Empty;
302 Reason : RT_Exception_Code) return Node_Id
305 pragma Assert (Reason in RT_SE_Exceptions);
307 Make_Raise_Storage_Error (Sloc,
308 Condition => Condition,
310 UI_From_Int (RT_Exception_Code'Pos (Reason)));
311 end Make_Raise_Storage_Error;
313 -------------------------
314 -- Make_String_Literal --
315 -------------------------
317 function Make_String_Literal
319 Strval : String) return Node_Id
323 Store_String_Chars (Strval);
325 Make_String_Literal (Sloc,
326 Strval => End_String);
327 end Make_String_Literal;
329 ---------------------------
330 -- Make_Unsuppress_Block --
331 ---------------------------
333 -- Generates the following expansion:
336 -- pragma Suppress (<check>);
341 function Make_Unsuppress_Block
344 Stmts : List_Id) return Node_Id
348 Make_Block_Statement (Loc,
349 Declarations => New_List (
351 Chars => Name_Suppress,
352 Pragma_Argument_Associations => New_List (
353 Make_Pragma_Argument_Association (Loc,
354 Expression => Make_Identifier (Loc, Check))))),
356 Handled_Statement_Sequence =>
357 Make_Handled_Sequence_Of_Statements (Loc,
358 Statements => Stmts));
359 end Make_Unsuppress_Block;
361 --------------------------
362 -- New_Constraint_Error --
363 --------------------------
365 function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
366 Ident_Node : Node_Id;
367 Raise_Node : Node_Id;
370 Ident_Node := New_Node (N_Identifier, Loc);
371 Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
372 Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
373 Raise_Node := New_Node (N_Raise_Statement, Loc);
374 Set_Name (Raise_Node, Ident_Node);
376 end New_Constraint_Error;
378 -----------------------
379 -- New_External_Name --
380 -----------------------
382 function New_External_Name
383 (Related_Id : Name_Id;
384 Suffix : Character := ' ';
385 Suffix_Index : Int := 0;
386 Prefix : Character := ' ') return Name_Id
389 Get_Name_String (Related_Id);
391 if Prefix /= ' ' then
392 pragma Assert (Is_OK_Internal_Letter (Prefix));
394 for J in reverse 1 .. Name_Len loop
395 Name_Buffer (J + 1) := Name_Buffer (J);
398 Name_Len := Name_Len + 1;
399 Name_Buffer (1) := Prefix;
402 if Suffix /= ' ' then
403 pragma Assert (Is_OK_Internal_Letter (Suffix));
404 Name_Len := Name_Len + 1;
405 Name_Buffer (Name_Len) := Suffix;
408 if Suffix_Index /= 0 then
409 if Suffix_Index < 0 then
410 Add_Unique_Serial_Number;
412 Add_Nat_To_Name_Buffer (Suffix_Index);
417 end New_External_Name;
419 function New_External_Name
420 (Related_Id : Name_Id;
422 Suffix_Index : Int := 0;
423 Prefix : Character := ' ') return Name_Id
426 Get_Name_String (Related_Id);
428 if Prefix /= ' ' then
429 pragma Assert (Is_OK_Internal_Letter (Prefix));
431 for J in reverse 1 .. Name_Len loop
432 Name_Buffer (J + 1) := Name_Buffer (J);
435 Name_Len := Name_Len + 1;
436 Name_Buffer (1) := Prefix;
440 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
441 Name_Len := Name_Len + Suffix'Length;
444 if Suffix_Index /= 0 then
445 if Suffix_Index < 0 then
446 Add_Unique_Serial_Number;
448 Add_Nat_To_Name_Buffer (Suffix_Index);
453 end New_External_Name;
455 function New_External_Name
457 Suffix_Index : Nat) return Name_Id
460 Name_Buffer (1) := Suffix;
462 Add_Nat_To_Name_Buffer (Suffix_Index);
464 end New_External_Name;
466 -----------------------
467 -- New_Internal_Name --
468 -----------------------
470 function New_Internal_Name (Id_Char : Character) return Name_Id is
472 pragma Assert (Is_OK_Internal_Letter (Id_Char));
473 Name_Buffer (1) := Id_Char;
475 Add_Unique_Serial_Number;
477 end New_Internal_Name;
479 -----------------------
480 -- New_Occurrence_Of --
481 -----------------------
483 function New_Occurrence_Of
485 Loc : Source_Ptr) return Node_Id
487 Occurrence : Node_Id;
490 Occurrence := New_Node (N_Identifier, Loc);
491 Set_Chars (Occurrence, Chars (Def_Id));
492 Set_Entity (Occurrence, Def_Id);
494 if Is_Type (Def_Id) then
495 Set_Etype (Occurrence, Def_Id);
497 Set_Etype (Occurrence, Etype (Def_Id));
501 end New_Occurrence_Of;
503 ----------------------
504 -- New_Reference_To --
505 ----------------------
507 function New_Reference_To
509 Loc : Source_Ptr) return Node_Id
511 Occurrence : Node_Id;
514 Occurrence := New_Node (N_Identifier, Loc);
515 Set_Chars (Occurrence, Chars (Def_Id));
516 Set_Entity (Occurrence, Def_Id);
518 end New_Reference_To;
520 -----------------------
521 -- New_Suffixed_Name --
522 -----------------------
524 function New_Suffixed_Name
525 (Related_Id : Name_Id;
526 Suffix : String) return Name_Id
529 Get_Name_String (Related_Id);
530 Name_Len := Name_Len + 1;
531 Name_Buffer (Name_Len) := '_';
532 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
533 Name_Len := Name_Len + Suffix'Length;
535 end New_Suffixed_Name;
541 function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
545 Make_Type_Conversion (Sloc (Expr),
546 Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
547 Expression => Relocate_Node (Expr));
548 Set_Conversion_OK (Result, True);
549 Set_Etype (Result, Typ);
553 --------------------------
554 -- Unchecked_Convert_To --
555 --------------------------
557 function Unchecked_Convert_To
559 Expr : Node_Id) return Node_Id
561 Loc : constant Source_Ptr := Sloc (Expr);
565 -- If the expression is already of the correct type, then nothing
566 -- to do, except for relocating the node in case this is required.
568 if Present (Etype (Expr))
569 and then (Base_Type (Etype (Expr)) = Typ
570 or else Etype (Expr) = Typ)
572 return Relocate_Node (Expr);
574 -- Cases where the inner expression is itself an unchecked conversion
575 -- to the same type, and we can thus eliminate the outer conversion.
577 elsif Nkind (Expr) = N_Unchecked_Type_Conversion
578 and then Entity (Subtype_Mark (Expr)) = Typ
580 Result := Relocate_Node (Expr);
582 elsif Nkind (Expr) = N_Null
583 and then Is_Access_Type (Typ)
585 -- No need for a conversion
587 Result := Relocate_Node (Expr);
593 Make_Unchecked_Type_Conversion (Loc,
594 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
595 Expression => Relocate_Node (Expr));
598 Set_Etype (Result, Typ);
600 end Unchecked_Convert_To;