1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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 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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Elists; use Elists;
30 with Nlists; use Nlists;
31 with Nmake; use Nmake;
33 with Restrict; use Restrict;
34 with Rident; use Rident;
35 with Sem_Aux; use Sem_Aux;
36 with Snames; use Snames;
37 with Stand; use Stand;
38 with Stringt; use Stringt;
39 with Uintp; use Uintp;
41 package body Tbuild is
43 -----------------------
44 -- Local Subprograms --
45 -----------------------
47 procedure Add_Unique_Serial_Number;
48 -- Add a unique serialization to the string in the Name_Buffer. This
49 -- consists of a unit specific serial number, and b/s for body/spec.
51 ------------------------------
52 -- Add_Unique_Serial_Number --
53 ------------------------------
55 Config_Serial_Number : Nat := 0;
56 -- Counter for use in config pragmas, see comment below
58 procedure Add_Unique_Serial_Number is
60 -- If we are analyzing configuration pragmas, Cunit (Main_Unit) will
61 -- not be set yet. This happens for example when analyzing static
62 -- string expressions in configuration pragmas. For this case, we
63 -- just maintain a local counter, defined above and we do not need
64 -- to add a b or s indication in this case.
66 if No (Cunit (Current_Sem_Unit)) then
67 Config_Serial_Number := Config_Serial_Number + 1;
68 Add_Nat_To_Name_Buffer (Config_Serial_Number);
71 -- Normal case, within a unit
75 Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
78 Add_Nat_To_Name_Buffer (Increment_Serial_Number);
80 -- Add either b or s, depending on whether current unit is a spec
81 -- or a body. This is needed because we may generate the same name
82 -- in a spec and a body otherwise.
84 Name_Len := Name_Len + 1;
86 if Nkind (Unit_Node) = N_Package_Declaration
87 or else Nkind (Unit_Node) = N_Subprogram_Declaration
88 or else Nkind (Unit_Node) in N_Generic_Declaration
90 Name_Buffer (Name_Len) := 's';
92 Name_Buffer (Name_Len) := 'b';
96 end Add_Unique_Serial_Number;
102 function Checks_Off (N : Node_Id) return Node_Id is
105 Make_Unchecked_Expression (Sloc (N),
113 function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
117 if Present (Etype (Expr))
118 and then (Etype (Expr)) = Typ
120 return Relocate_Node (Expr);
123 Make_Type_Conversion (Sloc (Expr),
124 Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
125 Expression => Relocate_Node (Expr));
127 Set_Etype (Result, Typ);
136 procedure Discard_List (L : List_Id) is
137 pragma Warnings (Off, L);
146 procedure Discard_Node (N : Node_Or_Entity_Id) is
147 pragma Warnings (Off, N);
152 -------------------------------------------
153 -- Make_Byte_Aligned_Attribute_Reference --
154 -------------------------------------------
156 function Make_Byte_Aligned_Attribute_Reference
159 Attribute_Name : Name_Id)
162 N : constant Node_Id :=
163 Make_Attribute_Reference (Sloc,
165 Attribute_Name => Attribute_Name);
168 pragma Assert (Attribute_Name = Name_Address
170 Attribute_Name = Name_Unrestricted_Access);
171 Set_Must_Be_Byte_Aligned (N, True);
173 end Make_Byte_Aligned_Attribute_Reference;
179 function Make_DT_Access
182 Typ : Entity_Id) return Node_Id
184 Full_Type : Entity_Id := Typ;
187 if Is_Private_Type (Typ) then
188 Full_Type := Underlying_Type (Typ);
192 Unchecked_Convert_To (
194 (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),
195 Make_Selected_Component (Loc,
196 Prefix => New_Copy (Rec),
198 New_Reference_To (First_Tag_Component (Full_Type), Loc)));
201 -------------------------------------
202 -- Make_Implicit_Exception_Handler --
203 -------------------------------------
205 function Make_Implicit_Exception_Handler
207 Choice_Parameter : Node_Id := Empty;
208 Exception_Choices : List_Id;
209 Statements : List_Id) return Node_Id
215 -- Set the source location only when debugging the expanded code
217 -- When debugging the source code directly, we do not want the compiler
218 -- to associate this implicit exception handler with any specific source
219 -- line, because it can potentially confuse the debugger. The most
220 -- damaging situation would arise when the debugger tries to insert a
221 -- breakpoint at a certain line. If the code of the associated implicit
222 -- exception handler is generated before the code of that line, then the
223 -- debugger will end up inserting the breakpoint inside the exception
224 -- handler, rather than the code the user intended to break on. As a
225 -- result, it is likely that the program will not hit the breakpoint
228 if Debug_Generated_Code then
235 Make_Exception_Handler
236 (Loc, Choice_Parameter, Exception_Choices, Statements);
237 Set_Local_Raise_Statements (Handler, No_Elist);
239 end Make_Implicit_Exception_Handler;
241 --------------------------------
242 -- Make_Implicit_If_Statement --
243 --------------------------------
245 function Make_Implicit_If_Statement
248 Then_Statements : List_Id;
249 Elsif_Parts : List_Id := No_List;
250 Else_Statements : List_Id := No_List) return Node_Id
253 Check_Restriction (No_Implicit_Conditionals, Node);
255 return Make_If_Statement (Sloc (Node),
260 end Make_Implicit_If_Statement;
262 -------------------------------------
263 -- Make_Implicit_Label_Declaration --
264 -------------------------------------
266 function Make_Implicit_Label_Declaration
268 Defining_Identifier : Node_Id;
269 Label_Construct : Node_Id) return Node_Id
271 N : constant Node_Id :=
272 Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
274 Set_Label_Construct (N, Label_Construct);
276 end Make_Implicit_Label_Declaration;
278 ----------------------------------
279 -- Make_Implicit_Loop_Statement --
280 ----------------------------------
282 function Make_Implicit_Loop_Statement
284 Statements : List_Id;
285 Identifier : Node_Id := Empty;
286 Iteration_Scheme : Node_Id := Empty;
287 Has_Created_Identifier : Boolean := False;
288 End_Label : Node_Id := Empty) return Node_Id
291 Check_Restriction (No_Implicit_Loops, Node);
293 if Present (Iteration_Scheme)
294 and then Present (Condition (Iteration_Scheme))
296 Check_Restriction (No_Implicit_Conditionals, Node);
299 return Make_Loop_Statement (Sloc (Node),
300 Identifier => Identifier,
301 Iteration_Scheme => Iteration_Scheme,
302 Statements => Statements,
303 Has_Created_Identifier => Has_Created_Identifier,
304 End_Label => End_Label);
305 end Make_Implicit_Loop_Statement;
307 --------------------------
308 -- Make_Integer_Literal --
309 ---------------------------
311 function Make_Integer_Literal
313 Intval : Int) return Node_Id
316 return Make_Integer_Literal (Loc, UI_From_Int (Intval));
317 end Make_Integer_Literal;
319 --------------------------------
320 -- Make_Linker_Section_Pragma --
321 --------------------------------
323 function Make_Linker_Section_Pragma
326 Sec : String) return Node_Id
336 (Make_Pragma_Argument_Association
338 Expression => New_Occurrence_Of (Ent, Loc)),
339 Make_Pragma_Argument_Association
346 Set_Has_Gigi_Rep_Item (Ent);
348 end Make_Linker_Section_Pragma;
357 Pragma_Argument_Associations : List_Id := No_List;
358 Debug_Statement : Node_Id := Empty) return Node_Id
363 Pragma_Argument_Associations => Pragma_Argument_Associations,
364 Debug_Statement => Debug_Statement,
365 Pragma_Identifier => Make_Identifier (Sloc, Chars));
368 ---------------------------------
369 -- Make_Raise_Constraint_Error --
370 ---------------------------------
372 function Make_Raise_Constraint_Error
374 Condition : Node_Id := Empty;
375 Reason : RT_Exception_Code) return Node_Id
378 pragma Assert (Reason in RT_CE_Exceptions);
380 Make_Raise_Constraint_Error (Sloc,
381 Condition => Condition,
383 UI_From_Int (RT_Exception_Code'Pos (Reason)));
384 end Make_Raise_Constraint_Error;
386 ------------------------------
387 -- Make_Raise_Program_Error --
388 ------------------------------
390 function Make_Raise_Program_Error
392 Condition : Node_Id := Empty;
393 Reason : RT_Exception_Code) return Node_Id
396 pragma Assert (Reason in RT_PE_Exceptions);
398 Make_Raise_Program_Error (Sloc,
399 Condition => Condition,
401 UI_From_Int (RT_Exception_Code'Pos (Reason)));
402 end Make_Raise_Program_Error;
404 ------------------------------
405 -- Make_Raise_Storage_Error --
406 ------------------------------
408 function Make_Raise_Storage_Error
410 Condition : Node_Id := Empty;
411 Reason : RT_Exception_Code) return Node_Id
414 pragma Assert (Reason in RT_SE_Exceptions);
416 Make_Raise_Storage_Error (Sloc,
417 Condition => Condition,
419 UI_From_Int (RT_Exception_Code'Pos (Reason)));
420 end Make_Raise_Storage_Error;
422 -------------------------
423 -- Make_String_Literal --
424 -------------------------
426 function Make_String_Literal
428 Strval : String) return Node_Id
432 Store_String_Chars (Strval);
434 Make_String_Literal (Sloc,
435 Strval => End_String);
436 end Make_String_Literal;
442 function Make_Temporary
445 Related_Node : Node_Id := Empty) return Node_Id
447 Temp : constant Node_Id :=
448 Make_Defining_Identifier (Loc,
449 Chars => New_Internal_Name (Id));
451 Set_Related_Expression (Temp, Related_Node);
455 ---------------------------
456 -- Make_Unsuppress_Block --
457 ---------------------------
459 -- Generates the following expansion:
462 -- pragma Suppress (<check>);
467 function Make_Unsuppress_Block
470 Stmts : List_Id) return Node_Id
474 Make_Block_Statement (Loc,
475 Declarations => New_List (
477 Chars => Name_Suppress,
478 Pragma_Argument_Associations => New_List (
479 Make_Pragma_Argument_Association (Loc,
480 Expression => Make_Identifier (Loc, Check))))),
482 Handled_Statement_Sequence =>
483 Make_Handled_Sequence_Of_Statements (Loc,
484 Statements => Stmts));
485 end Make_Unsuppress_Block;
487 --------------------------
488 -- New_Constraint_Error --
489 --------------------------
491 function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
492 Ident_Node : Node_Id;
493 Raise_Node : Node_Id;
496 Ident_Node := New_Node (N_Identifier, Loc);
497 Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
498 Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
499 Raise_Node := New_Node (N_Raise_Statement, Loc);
500 Set_Name (Raise_Node, Ident_Node);
502 end New_Constraint_Error;
504 -----------------------
505 -- New_External_Name --
506 -----------------------
508 function New_External_Name
509 (Related_Id : Name_Id;
510 Suffix : Character := ' ';
511 Suffix_Index : Int := 0;
512 Prefix : Character := ' ') return Name_Id
515 Get_Name_String (Related_Id);
517 if Prefix /= ' ' then
518 pragma Assert (Is_OK_Internal_Letter (Prefix) or else Prefix = '_');
520 for J in reverse 1 .. Name_Len loop
521 Name_Buffer (J + 1) := Name_Buffer (J);
524 Name_Len := Name_Len + 1;
525 Name_Buffer (1) := Prefix;
528 if Suffix /= ' ' then
529 pragma Assert (Is_OK_Internal_Letter (Suffix));
530 Add_Char_To_Name_Buffer (Suffix);
533 if Suffix_Index /= 0 then
534 if Suffix_Index < 0 then
535 Add_Unique_Serial_Number;
537 Add_Nat_To_Name_Buffer (Suffix_Index);
542 end New_External_Name;
544 function New_External_Name
545 (Related_Id : Name_Id;
547 Suffix_Index : Int := 0;
548 Prefix : Character := ' ') return Name_Id
551 Get_Name_String (Related_Id);
553 if Prefix /= ' ' then
554 pragma Assert (Is_OK_Internal_Letter (Prefix));
556 for J in reverse 1 .. Name_Len loop
557 Name_Buffer (J + 1) := Name_Buffer (J);
560 Name_Len := Name_Len + 1;
561 Name_Buffer (1) := Prefix;
565 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
566 Name_Len := Name_Len + Suffix'Length;
569 if Suffix_Index /= 0 then
570 if Suffix_Index < 0 then
571 Add_Unique_Serial_Number;
573 Add_Nat_To_Name_Buffer (Suffix_Index);
578 end New_External_Name;
580 function New_External_Name
582 Suffix_Index : Nat) return Name_Id
585 Name_Buffer (1) := Suffix;
587 Add_Nat_To_Name_Buffer (Suffix_Index);
589 end New_External_Name;
591 -----------------------
592 -- New_Internal_Name --
593 -----------------------
595 function New_Internal_Name (Id_Char : Character) return Name_Id is
597 pragma Assert (Is_OK_Internal_Letter (Id_Char));
598 Name_Buffer (1) := Id_Char;
600 Add_Unique_Serial_Number;
602 end New_Internal_Name;
604 -----------------------
605 -- New_Occurrence_Of --
606 -----------------------
608 function New_Occurrence_Of
610 Loc : Source_Ptr) return Node_Id
612 Occurrence : Node_Id;
615 Occurrence := New_Node (N_Identifier, Loc);
616 Set_Chars (Occurrence, Chars (Def_Id));
617 Set_Entity (Occurrence, Def_Id);
619 if Is_Type (Def_Id) then
620 Set_Etype (Occurrence, Def_Id);
622 Set_Etype (Occurrence, Etype (Def_Id));
626 end New_Occurrence_Of;
633 (New_Node_Kind : Node_Kind;
634 New_Sloc : Source_Ptr) return Node_Id
636 type Name_Of_Type is array (N_Op) of Name_Id;
637 Name_Of : constant Name_Of_Type := Name_Of_Type'(
638 N_Op_And => Name_Op_And,
639 N_Op_Or => Name_Op_Or,
640 N_Op_Xor => Name_Op_Xor,
641 N_Op_Eq => Name_Op_Eq,
642 N_Op_Ne => Name_Op_Ne,
643 N_Op_Lt => Name_Op_Lt,
644 N_Op_Le => Name_Op_Le,
645 N_Op_Gt => Name_Op_Gt,
646 N_Op_Ge => Name_Op_Ge,
647 N_Op_Add => Name_Op_Add,
648 N_Op_Subtract => Name_Op_Subtract,
649 N_Op_Concat => Name_Op_Concat,
650 N_Op_Multiply => Name_Op_Multiply,
651 N_Op_Divide => Name_Op_Divide,
652 N_Op_Mod => Name_Op_Mod,
653 N_Op_Rem => Name_Op_Rem,
654 N_Op_Expon => Name_Op_Expon,
655 N_Op_Plus => Name_Op_Add,
656 N_Op_Minus => Name_Op_Subtract,
657 N_Op_Abs => Name_Op_Abs,
658 N_Op_Not => Name_Op_Not,
660 -- We don't really need these shift operators, since they never
661 -- appear as operators in the source, but the path of least
662 -- resistance is to put them in (the aggregate must be complete)
664 N_Op_Rotate_Left => Name_Rotate_Left,
665 N_Op_Rotate_Right => Name_Rotate_Right,
666 N_Op_Shift_Left => Name_Shift_Left,
667 N_Op_Shift_Right => Name_Shift_Right,
668 N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic);
670 Nod : constant Node_Id := New_Node (New_Node_Kind, New_Sloc);
673 if New_Node_Kind in Name_Of'Range then
674 Set_Chars (Nod, Name_Of (New_Node_Kind));
680 ----------------------
681 -- New_Reference_To --
682 ----------------------
684 function New_Reference_To
686 Loc : Source_Ptr) return Node_Id
688 Occurrence : Node_Id;
691 Occurrence := New_Node (N_Identifier, Loc);
692 Set_Chars (Occurrence, Chars (Def_Id));
693 Set_Entity (Occurrence, Def_Id);
695 end New_Reference_To;
697 -----------------------
698 -- New_Suffixed_Name --
699 -----------------------
701 function New_Suffixed_Name
702 (Related_Id : Name_Id;
703 Suffix : String) return Name_Id
706 Get_Name_String (Related_Id);
707 Add_Char_To_Name_Buffer ('_');
708 Add_Str_To_Name_Buffer (Suffix);
710 end New_Suffixed_Name;
716 function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
720 Make_Type_Conversion (Sloc (Expr),
721 Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
722 Expression => Relocate_Node (Expr));
723 Set_Conversion_OK (Result, True);
724 Set_Etype (Result, Typ);
728 --------------------------
729 -- Unchecked_Convert_To --
730 --------------------------
732 function Unchecked_Convert_To
734 Expr : Node_Id) return Node_Id
736 Loc : constant Source_Ptr := Sloc (Expr);
740 -- If the expression is already of the correct type, then nothing
741 -- to do, except for relocating the node in case this is required.
743 if Present (Etype (Expr))
744 and then (Base_Type (Etype (Expr)) = Typ
745 or else Etype (Expr) = Typ)
747 return Relocate_Node (Expr);
749 -- Cases where the inner expression is itself an unchecked conversion
750 -- to the same type, and we can thus eliminate the outer conversion.
752 elsif Nkind (Expr) = N_Unchecked_Type_Conversion
753 and then Entity (Subtype_Mark (Expr)) = Typ
755 Result := Relocate_Node (Expr);
757 elsif Nkind (Expr) = N_Null
758 and then Is_Access_Type (Typ)
760 -- No need for a conversion
762 Result := Relocate_Node (Expr);
768 Make_Unchecked_Type_Conversion (Loc,
769 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
770 Expression => Relocate_Node (Expr));
773 Set_Etype (Result, Typ);
775 end Unchecked_Convert_To;