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;
30 with Namet; use Namet;
31 with Nlists; use Nlists;
32 with Nmake; use Nmake;
33 with Restrict; use Restrict;
34 with Rident; use Rident;
35 with Sinfo; use Sinfo;
36 with Snames; use Snames;
37 with Stand; use Stand;
38 with Uintp; use Uintp;
40 package body Tbuild is
42 -----------------------
43 -- Local Subprograms --
44 -----------------------
46 procedure Add_Unique_Serial_Number;
47 -- Add a unique serialization to the string in the Name_Buffer. This
48 -- consists of a unit specific serial number, and b/s for body/spec.
50 ------------------------------
51 -- Add_Unique_Serial_Number --
52 ------------------------------
54 procedure Add_Unique_Serial_Number is
55 Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
58 Add_Nat_To_Name_Buffer (Increment_Serial_Number);
60 -- Add either b or s, depending on whether current unit is a spec
61 -- or a body. This is needed because we may generate the same name
62 -- in a spec and a body otherwise.
64 Name_Len := Name_Len + 1;
66 if Nkind (Unit_Node) = N_Package_Declaration
67 or else Nkind (Unit_Node) = N_Subprogram_Declaration
68 or else Nkind (Unit_Node) in N_Generic_Declaration
70 Name_Buffer (Name_Len) := 's';
72 Name_Buffer (Name_Len) := 'b';
74 end Add_Unique_Serial_Number;
80 function Checks_Off (N : Node_Id) return Node_Id is
83 Make_Unchecked_Expression (Sloc (N),
91 function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
95 if Present (Etype (Expr))
96 and then (Etype (Expr)) = Typ
98 return Relocate_Node (Expr);
101 Make_Type_Conversion (Sloc (Expr),
102 Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
103 Expression => Relocate_Node (Expr));
105 Set_Etype (Result, Typ);
114 procedure Discard_List (L : List_Id) is
115 pragma Warnings (Off, L);
124 procedure Discard_Node (N : Node_Or_Entity_Id) is
125 pragma Warnings (Off, N);
130 -------------------------------------------
131 -- Make_Byte_Aligned_Attribute_Reference --
132 -------------------------------------------
134 function Make_Byte_Aligned_Attribute_Reference
137 Attribute_Name : Name_Id)
140 N : constant Node_Id :=
141 Make_Attribute_Reference (Sloc,
143 Attribute_Name => Attribute_Name);
146 pragma Assert (Attribute_Name = Name_Address
148 Attribute_Name = Name_Unrestricted_Access);
149 Set_Must_Be_Byte_Aligned (N, True);
151 end Make_Byte_Aligned_Attribute_Reference;
157 function Make_DT_Access
160 Typ : Entity_Id) return Node_Id
162 Full_Type : Entity_Id := Typ;
165 if Is_Private_Type (Typ) then
166 Full_Type := Underlying_Type (Typ);
170 Unchecked_Convert_To (
171 New_Occurrence_Of (Etype (Access_Disp_Table (Full_Type)), Loc),
172 Make_Selected_Component (Loc,
173 Prefix => New_Copy (Rec),
175 New_Reference_To (Tag_Component (Full_Type), Loc)));
178 -----------------------
179 -- Make_DT_Component --
180 -----------------------
182 function Make_DT_Component
185 I : Positive) return Node_Id
188 Full_Type : Entity_Id := Typ;
191 if Is_Private_Type (Typ) then
192 Full_Type := Underlying_Type (Typ);
195 X := First_Component (
196 Designated_Type (Etype (Access_Disp_Table (Full_Type))));
199 X := Next_Component (X);
202 return New_Reference_To (X, Loc);
203 end Make_DT_Component;
205 --------------------------------
206 -- Make_Implicit_If_Statement --
207 --------------------------------
209 function Make_Implicit_If_Statement
212 Then_Statements : List_Id;
213 Elsif_Parts : List_Id := No_List;
214 Else_Statements : List_Id := No_List) return Node_Id
217 Check_Restriction (No_Implicit_Conditionals, Node);
218 return Make_If_Statement (Sloc (Node),
223 end Make_Implicit_If_Statement;
225 -------------------------------------
226 -- Make_Implicit_Label_Declaration --
227 -------------------------------------
229 function Make_Implicit_Label_Declaration
231 Defining_Identifier : Node_Id;
232 Label_Construct : Node_Id) return Node_Id
234 N : constant Node_Id :=
235 Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
238 Set_Label_Construct (N, Label_Construct);
240 end Make_Implicit_Label_Declaration;
242 ----------------------------------
243 -- Make_Implicit_Loop_Statement --
244 ----------------------------------
246 function Make_Implicit_Loop_Statement
248 Statements : List_Id;
249 Identifier : Node_Id := Empty;
250 Iteration_Scheme : Node_Id := Empty;
251 Has_Created_Identifier : Boolean := False;
252 End_Label : Node_Id := Empty) return Node_Id
255 Check_Restriction (No_Implicit_Loops, Node);
257 if Present (Iteration_Scheme)
258 and then Present (Condition (Iteration_Scheme))
260 Check_Restriction (No_Implicit_Conditionals, Node);
263 return Make_Loop_Statement (Sloc (Node),
264 Identifier => Identifier,
265 Iteration_Scheme => Iteration_Scheme,
266 Statements => Statements,
267 Has_Created_Identifier => Has_Created_Identifier,
268 End_Label => End_Label);
269 end Make_Implicit_Loop_Statement;
271 --------------------------
272 -- Make_Integer_Literal --
273 ---------------------------
275 function Make_Integer_Literal
277 Intval : Int) return Node_Id
280 return Make_Integer_Literal (Loc, UI_From_Int (Intval));
281 end Make_Integer_Literal;
283 ---------------------------------
284 -- Make_Raise_Constraint_Error --
285 ---------------------------------
287 function Make_Raise_Constraint_Error
289 Condition : Node_Id := Empty;
290 Reason : RT_Exception_Code) return Node_Id
293 pragma Assert (Reason in RT_CE_Exceptions);
295 Make_Raise_Constraint_Error (Sloc,
296 Condition => Condition,
298 UI_From_Int (RT_Exception_Code'Pos (Reason)));
299 end Make_Raise_Constraint_Error;
301 ------------------------------
302 -- Make_Raise_Program_Error --
303 ------------------------------
305 function Make_Raise_Program_Error
307 Condition : Node_Id := Empty;
308 Reason : RT_Exception_Code) return Node_Id
311 pragma Assert (Reason in RT_PE_Exceptions);
313 Make_Raise_Program_Error (Sloc,
314 Condition => Condition,
316 UI_From_Int (RT_Exception_Code'Pos (Reason)));
317 end Make_Raise_Program_Error;
319 ------------------------------
320 -- Make_Raise_Storage_Error --
321 ------------------------------
323 function Make_Raise_Storage_Error
325 Condition : Node_Id := Empty;
326 Reason : RT_Exception_Code) return Node_Id
329 pragma Assert (Reason in RT_SE_Exceptions);
331 Make_Raise_Storage_Error (Sloc,
332 Condition => Condition,
334 UI_From_Int (RT_Exception_Code'Pos (Reason)));
335 end Make_Raise_Storage_Error;
337 ---------------------------
338 -- Make_Unsuppress_Block --
339 ---------------------------
341 -- Generates the following expansion:
344 -- pragma Suppress (<check>);
349 function Make_Unsuppress_Block
352 Stmts : List_Id) return Node_Id
356 Make_Block_Statement (Loc,
357 Declarations => New_List (
359 Chars => Name_Suppress,
360 Pragma_Argument_Associations => New_List (
361 Make_Pragma_Argument_Association (Loc,
362 Expression => Make_Identifier (Loc, Check))))),
364 Handled_Statement_Sequence =>
365 Make_Handled_Sequence_Of_Statements (Loc,
366 Statements => Stmts));
367 end Make_Unsuppress_Block;
369 --------------------------
370 -- New_Constraint_Error --
371 --------------------------
373 function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
374 Ident_Node : Node_Id;
375 Raise_Node : Node_Id;
378 Ident_Node := New_Node (N_Identifier, Loc);
379 Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
380 Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
381 Raise_Node := New_Node (N_Raise_Statement, Loc);
382 Set_Name (Raise_Node, Ident_Node);
384 end New_Constraint_Error;
386 -----------------------
387 -- New_External_Name --
388 -----------------------
390 function New_External_Name
391 (Related_Id : Name_Id;
392 Suffix : Character := ' ';
393 Suffix_Index : Int := 0;
394 Prefix : Character := ' ') return Name_Id
397 Get_Name_String (Related_Id);
399 if Prefix /= ' ' then
400 pragma Assert (Is_OK_Internal_Letter (Prefix));
402 for J in reverse 1 .. Name_Len loop
403 Name_Buffer (J + 1) := Name_Buffer (J);
406 Name_Len := Name_Len + 1;
407 Name_Buffer (1) := Prefix;
410 if Suffix /= ' ' then
411 pragma Assert (Is_OK_Internal_Letter (Suffix));
412 Name_Len := Name_Len + 1;
413 Name_Buffer (Name_Len) := Suffix;
416 if Suffix_Index /= 0 then
417 if Suffix_Index < 0 then
418 Add_Unique_Serial_Number;
420 Add_Nat_To_Name_Buffer (Suffix_Index);
425 end New_External_Name;
427 function New_External_Name
428 (Related_Id : Name_Id;
430 Suffix_Index : Int := 0;
431 Prefix : Character := ' ') return Name_Id
434 Get_Name_String (Related_Id);
436 if Prefix /= ' ' then
437 pragma Assert (Is_OK_Internal_Letter (Prefix));
439 for J in reverse 1 .. Name_Len loop
440 Name_Buffer (J + 1) := Name_Buffer (J);
443 Name_Len := Name_Len + 1;
444 Name_Buffer (1) := Prefix;
448 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
449 Name_Len := Name_Len + Suffix'Length;
452 if Suffix_Index /= 0 then
453 if Suffix_Index < 0 then
454 Add_Unique_Serial_Number;
456 Add_Nat_To_Name_Buffer (Suffix_Index);
461 end New_External_Name;
463 function New_External_Name
465 Suffix_Index : Nat) return Name_Id
468 Name_Buffer (1) := Suffix;
470 Add_Nat_To_Name_Buffer (Suffix_Index);
472 end New_External_Name;
474 -----------------------
475 -- New_Internal_Name --
476 -----------------------
478 function New_Internal_Name (Id_Char : Character) return Name_Id is
480 pragma Assert (Is_OK_Internal_Letter (Id_Char));
481 Name_Buffer (1) := Id_Char;
483 Add_Unique_Serial_Number;
485 end New_Internal_Name;
487 -----------------------
488 -- New_Occurrence_Of --
489 -----------------------
491 function New_Occurrence_Of
493 Loc : Source_Ptr) return Node_Id
495 Occurrence : Node_Id;
498 Occurrence := New_Node (N_Identifier, Loc);
499 Set_Chars (Occurrence, Chars (Def_Id));
500 Set_Entity (Occurrence, Def_Id);
502 if Is_Type (Def_Id) then
503 Set_Etype (Occurrence, Def_Id);
505 Set_Etype (Occurrence, Etype (Def_Id));
509 end New_Occurrence_Of;
511 ----------------------
512 -- New_Reference_To --
513 ----------------------
515 function New_Reference_To
517 Loc : Source_Ptr) return Node_Id
519 Occurrence : Node_Id;
522 Occurrence := New_Node (N_Identifier, Loc);
523 Set_Chars (Occurrence, Chars (Def_Id));
524 Set_Entity (Occurrence, Def_Id);
526 end New_Reference_To;
528 -----------------------
529 -- New_Suffixed_Name --
530 -----------------------
532 function New_Suffixed_Name
533 (Related_Id : Name_Id;
534 Suffix : String) return Name_Id
537 Get_Name_String (Related_Id);
538 Name_Len := Name_Len + 1;
539 Name_Buffer (Name_Len) := '_';
540 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
541 Name_Len := Name_Len + Suffix'Length;
543 end New_Suffixed_Name;
549 function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
553 Make_Type_Conversion (Sloc (Expr),
554 Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
555 Expression => Relocate_Node (Expr));
556 Set_Conversion_OK (Result, True);
557 Set_Etype (Result, Typ);
561 --------------------------
562 -- Unchecked_Convert_To --
563 --------------------------
565 function Unchecked_Convert_To
567 Expr : Node_Id) return Node_Id
569 Loc : constant Source_Ptr := Sloc (Expr);
573 -- If the expression is already of the correct type, then nothing
574 -- to do, except for relocating the node in case this is required.
576 if Present (Etype (Expr))
577 and then (Base_Type (Etype (Expr)) = Typ
578 or else Etype (Expr) = Typ)
580 return Relocate_Node (Expr);
582 -- Cases where the inner expression is itself an unchecked conversion
583 -- to the same type, and we can thus eliminate the outer conversion.
585 elsif Nkind (Expr) = N_Unchecked_Type_Conversion
586 and then Entity (Subtype_Mark (Expr)) = Typ
588 Result := Relocate_Node (Expr);
590 elsif Nkind (Expr) = N_Null
591 and then Is_Access_Type (Typ)
593 -- No need for a conversion
595 Result := Relocate_Node (Expr);
601 Make_Unchecked_Type_Conversion (Loc,
602 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
603 Expression => Relocate_Node (Expr));
606 Set_Etype (Result, Typ);
608 end Unchecked_Convert_To;