1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2003, 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 Sinfo; use Sinfo;
35 with Snames; use Snames;
36 with Stand; use Stand;
37 with Uintp; use Uintp;
39 package body Tbuild is
41 -----------------------
42 -- Local Subprograms --
43 -----------------------
45 procedure Add_Unique_Serial_Number;
46 -- Add a unique serialization to the string in the Name_Buffer. This
47 -- consists of a unit specific serial number, and b/s for body/spec.
49 ------------------------------
50 -- Add_Unique_Serial_Number --
51 ------------------------------
53 procedure Add_Unique_Serial_Number is
54 Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
57 Add_Nat_To_Name_Buffer (Increment_Serial_Number);
59 -- Add either b or s, depending on whether current unit is a spec
60 -- or a body. This is needed because we may generate the same name
61 -- in a spec and a body otherwise.
63 Name_Len := Name_Len + 1;
65 if Nkind (Unit_Node) = N_Package_Declaration
66 or else Nkind (Unit_Node) = N_Subprogram_Declaration
67 or else Nkind (Unit_Node) in N_Generic_Declaration
69 Name_Buffer (Name_Len) := 's';
71 Name_Buffer (Name_Len) := 'b';
73 end Add_Unique_Serial_Number;
79 function Checks_Off (N : Node_Id) return Node_Id is
82 Make_Unchecked_Expression (Sloc (N),
90 function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
94 if Present (Etype (Expr))
95 and then (Etype (Expr)) = Typ
97 return Relocate_Node (Expr);
100 Make_Type_Conversion (Sloc (Expr),
101 Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
102 Expression => Relocate_Node (Expr));
104 Set_Etype (Result, Typ);
113 procedure Discard_List (L : List_Id) is
114 pragma Warnings (Off, L);
124 procedure Discard_Node (N : Node_Or_Entity_Id) is
125 pragma Warnings (Off, N);
131 -------------------------------------------
132 -- Make_Byte_Aligned_Attribute_Reference --
133 -------------------------------------------
135 function Make_Byte_Aligned_Attribute_Reference
138 Attribute_Name : Name_Id)
141 N : constant Node_Id :=
142 Make_Attribute_Reference (Sloc,
144 Attribute_Name => Attribute_Name);
147 pragma Assert (Attribute_Name = Name_Address
149 Attribute_Name = Name_Unrestricted_Access);
150 Set_Must_Be_Byte_Aligned (N, True);
152 end Make_Byte_Aligned_Attribute_Reference;
158 function Make_DT_Access
164 Full_Type : Entity_Id := Typ;
167 if Is_Private_Type (Typ) then
168 Full_Type := Underlying_Type (Typ);
172 Unchecked_Convert_To (
173 New_Occurrence_Of (Etype (Access_Disp_Table (Full_Type)), Loc),
174 Make_Selected_Component (Loc,
175 Prefix => New_Copy (Rec),
177 New_Reference_To (Tag_Component (Full_Type), Loc)));
180 -----------------------
181 -- Make_DT_Component --
182 -----------------------
184 function Make_DT_Component
191 Full_Type : Entity_Id := Typ;
194 if Is_Private_Type (Typ) then
195 Full_Type := Underlying_Type (Typ);
198 X := First_Component (
199 Designated_Type (Etype (Access_Disp_Table (Full_Type))));
202 X := Next_Component (X);
205 return New_Reference_To (X, Loc);
206 end Make_DT_Component;
208 --------------------------------
209 -- Make_Implicit_If_Statement --
210 --------------------------------
212 function Make_Implicit_If_Statement
215 Then_Statements : List_Id;
216 Elsif_Parts : List_Id := No_List;
217 Else_Statements : List_Id := No_List)
221 Check_Restriction (No_Implicit_Conditionals, Node);
222 return Make_If_Statement (Sloc (Node),
227 end Make_Implicit_If_Statement;
229 -------------------------------------
230 -- Make_Implicit_Label_Declaration --
231 -------------------------------------
233 function Make_Implicit_Label_Declaration
235 Defining_Identifier : Node_Id;
236 Label_Construct : Node_Id)
239 N : constant Node_Id :=
240 Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
243 Set_Label_Construct (N, Label_Construct);
245 end Make_Implicit_Label_Declaration;
247 ----------------------------------
248 -- Make_Implicit_Loop_Statement --
249 ----------------------------------
251 function Make_Implicit_Loop_Statement
253 Statements : List_Id;
254 Identifier : Node_Id := Empty;
255 Iteration_Scheme : Node_Id := Empty;
256 Has_Created_Identifier : Boolean := False;
257 End_Label : Node_Id := Empty)
261 Check_Restriction (No_Implicit_Loops, Node);
263 if Present (Iteration_Scheme)
264 and then Present (Condition (Iteration_Scheme))
266 Check_Restriction (No_Implicit_Conditionals, Node);
269 return Make_Loop_Statement (Sloc (Node),
270 Identifier => Identifier,
271 Iteration_Scheme => Iteration_Scheme,
272 Statements => Statements,
273 Has_Created_Identifier => Has_Created_Identifier,
274 End_Label => End_Label);
275 end Make_Implicit_Loop_Statement;
277 --------------------------
278 -- Make_Integer_Literal --
279 ---------------------------
281 function Make_Integer_Literal
287 return Make_Integer_Literal (Loc, UI_From_Int (Intval));
288 end Make_Integer_Literal;
290 ---------------------------------
291 -- Make_Raise_Constraint_Error --
292 ---------------------------------
294 function Make_Raise_Constraint_Error
296 Condition : Node_Id := Empty;
297 Reason : RT_Exception_Code)
301 pragma Assert (Reason in RT_CE_Exceptions);
303 Make_Raise_Constraint_Error (Sloc,
304 Condition => Condition,
306 UI_From_Int (RT_Exception_Code'Pos (Reason)));
307 end Make_Raise_Constraint_Error;
309 ------------------------------
310 -- Make_Raise_Program_Error --
311 ------------------------------
313 function Make_Raise_Program_Error
315 Condition : Node_Id := Empty;
316 Reason : RT_Exception_Code)
320 pragma Assert (Reason in RT_PE_Exceptions);
322 Make_Raise_Program_Error (Sloc,
323 Condition => Condition,
325 UI_From_Int (RT_Exception_Code'Pos (Reason)));
326 end Make_Raise_Program_Error;
328 ------------------------------
329 -- Make_Raise_Storage_Error --
330 ------------------------------
332 function Make_Raise_Storage_Error
334 Condition : Node_Id := Empty;
335 Reason : RT_Exception_Code)
339 pragma Assert (Reason in RT_SE_Exceptions);
341 Make_Raise_Storage_Error (Sloc,
342 Condition => Condition,
344 UI_From_Int (RT_Exception_Code'Pos (Reason)));
345 end Make_Raise_Storage_Error;
347 ---------------------------
348 -- Make_Unsuppress_Block --
349 ---------------------------
351 -- Generates the following expansion:
354 -- pragma Suppress (<check>);
359 function Make_Unsuppress_Block
367 Make_Block_Statement (Loc,
368 Declarations => New_List (
370 Chars => Name_Suppress,
371 Pragma_Argument_Associations => New_List (
372 Make_Pragma_Argument_Association (Loc,
373 Expression => Make_Identifier (Loc, Check))))),
375 Handled_Statement_Sequence =>
376 Make_Handled_Sequence_Of_Statements (Loc,
377 Statements => Stmts));
378 end Make_Unsuppress_Block;
380 --------------------------
381 -- New_Constraint_Error --
382 --------------------------
384 function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
385 Ident_Node : Node_Id;
386 Raise_Node : Node_Id;
389 Ident_Node := New_Node (N_Identifier, Loc);
390 Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
391 Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
392 Raise_Node := New_Node (N_Raise_Statement, Loc);
393 Set_Name (Raise_Node, Ident_Node);
395 end New_Constraint_Error;
397 -----------------------
398 -- New_External_Name --
399 -----------------------
401 function New_External_Name
402 (Related_Id : Name_Id;
403 Suffix : Character := ' ';
404 Suffix_Index : Int := 0;
405 Prefix : Character := ' ')
409 Get_Name_String (Related_Id);
411 if Prefix /= ' ' then
412 pragma Assert (Is_OK_Internal_Letter (Prefix));
414 for J in reverse 1 .. Name_Len loop
415 Name_Buffer (J + 1) := Name_Buffer (J);
418 Name_Len := Name_Len + 1;
419 Name_Buffer (1) := Prefix;
422 if Suffix /= ' ' then
423 pragma Assert (Is_OK_Internal_Letter (Suffix));
424 Name_Len := Name_Len + 1;
425 Name_Buffer (Name_Len) := Suffix;
428 if Suffix_Index /= 0 then
429 if Suffix_Index < 0 then
430 Add_Unique_Serial_Number;
432 Add_Nat_To_Name_Buffer (Suffix_Index);
437 end New_External_Name;
439 function New_External_Name
440 (Related_Id : Name_Id;
442 Suffix_Index : Int := 0;
443 Prefix : Character := ' ')
447 Get_Name_String (Related_Id);
449 if Prefix /= ' ' then
450 pragma Assert (Is_OK_Internal_Letter (Prefix));
452 for J in reverse 1 .. Name_Len loop
453 Name_Buffer (J + 1) := Name_Buffer (J);
456 Name_Len := Name_Len + 1;
457 Name_Buffer (1) := Prefix;
461 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
462 Name_Len := Name_Len + Suffix'Length;
465 if Suffix_Index /= 0 then
466 if Suffix_Index < 0 then
467 Add_Unique_Serial_Number;
469 Add_Nat_To_Name_Buffer (Suffix_Index);
474 end New_External_Name;
476 function New_External_Name
482 Name_Buffer (1) := Suffix;
484 Add_Nat_To_Name_Buffer (Suffix_Index);
486 end New_External_Name;
488 -----------------------
489 -- New_Internal_Name --
490 -----------------------
492 function New_Internal_Name (Id_Char : Character) return Name_Id is
494 pragma Assert (Is_OK_Internal_Letter (Id_Char));
495 Name_Buffer (1) := Id_Char;
497 Add_Unique_Serial_Number;
499 end New_Internal_Name;
501 -----------------------
502 -- New_Occurrence_Of --
503 -----------------------
505 function New_Occurrence_Of
510 Occurrence : Node_Id;
513 Occurrence := New_Node (N_Identifier, Loc);
514 Set_Chars (Occurrence, Chars (Def_Id));
515 Set_Entity (Occurrence, Def_Id);
517 if Is_Type (Def_Id) then
518 Set_Etype (Occurrence, Def_Id);
520 Set_Etype (Occurrence, Etype (Def_Id));
524 end New_Occurrence_Of;
526 ----------------------
527 -- New_Reference_To --
528 ----------------------
530 function New_Reference_To
535 Occurrence : Node_Id;
538 Occurrence := New_Node (N_Identifier, Loc);
539 Set_Chars (Occurrence, Chars (Def_Id));
540 Set_Entity (Occurrence, Def_Id);
542 end New_Reference_To;
544 -----------------------
545 -- New_Suffixed_Name --
546 -----------------------
548 function New_Suffixed_Name
549 (Related_Id : Name_Id;
554 Get_Name_String (Related_Id);
555 Name_Len := Name_Len + 1;
556 Name_Buffer (Name_Len) := '_';
557 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
558 Name_Len := Name_Len + Suffix'Length;
560 end New_Suffixed_Name;
566 function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
571 Make_Type_Conversion (Sloc (Expr),
572 Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
573 Expression => Relocate_Node (Expr));
574 Set_Conversion_OK (Result, True);
575 Set_Etype (Result, Typ);
579 --------------------------
580 -- Unchecked_Convert_To --
581 --------------------------
583 function Unchecked_Convert_To
588 Loc : constant Source_Ptr := Sloc (Expr);
592 -- If the expression is already of the correct type, then nothing
593 -- to do, except for relocating the node in case this is required.
595 if Present (Etype (Expr))
596 and then (Base_Type (Etype (Expr)) = Typ
597 or else Etype (Expr) = Typ)
599 return Relocate_Node (Expr);
601 -- Cases where the inner expression is itself an unchecked conversion
602 -- to the same type, and we can thus eliminate the outer conversion.
604 elsif Nkind (Expr) = N_Unchecked_Type_Conversion
605 and then Entity (Subtype_Mark (Expr)) = Typ
607 Result := Relocate_Node (Expr);
609 elsif Nkind (Expr) = N_Null then
611 -- No need for a conversion
613 Result := Relocate_Node (Expr);
619 Make_Unchecked_Type_Conversion (Loc,
620 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
621 Expression => Relocate_Node (Expr));
624 Set_Etype (Result, Typ);
626 end Unchecked_Convert_To;