1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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 Urealp
; use Urealp
;
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
);
132 ----------------------------
133 -- Convert_To_And_Rewrite --
134 ----------------------------
136 procedure Convert_To_And_Rewrite
(Typ
: Entity_Id
; Expr
: Node_Id
) is
138 Rewrite
(Expr
, Convert_To
(Typ
, Expr
));
139 end Convert_To_And_Rewrite
;
145 procedure Discard_List
(L
: List_Id
) is
146 pragma Warnings
(Off
, L
);
155 procedure Discard_Node
(N
: Node_Or_Entity_Id
) is
156 pragma Warnings
(Off
, N
);
161 -------------------------------------------
162 -- Make_Byte_Aligned_Attribute_Reference --
163 -------------------------------------------
165 function Make_Byte_Aligned_Attribute_Reference
168 Attribute_Name
: Name_Id
)
171 N
: constant Node_Id
:=
172 Make_Attribute_Reference
(Sloc
,
174 Attribute_Name
=> Attribute_Name
);
177 pragma Assert
(Nam_In
(Attribute_Name
, Name_Address
,
178 Name_Unrestricted_Access
));
179 Set_Must_Be_Byte_Aligned
(N
, True);
181 end Make_Byte_Aligned_Attribute_Reference
;
187 function Make_DT_Access
190 Typ
: Entity_Id
) return Node_Id
192 Full_Type
: Entity_Id
:= Typ
;
195 if Is_Private_Type
(Typ
) then
196 Full_Type
:= Underlying_Type
(Typ
);
200 Unchecked_Convert_To
(
202 (Etype
(Node
(First_Elmt
(Access_Disp_Table
(Full_Type
)))), Loc
),
203 Make_Selected_Component
(Loc
,
204 Prefix
=> New_Copy
(Rec
),
206 New_Reference_To
(First_Tag_Component
(Full_Type
), Loc
)));
209 ------------------------
210 -- Make_Float_Literal --
211 ------------------------
213 function Make_Float_Literal
217 Exponent
: Uint
) return Node_Id
220 if Radix
= 2 and then abs Significand
/= 1 then
224 Significand
* Radix
**(Exponent
mod 4),
229 N
: constant Node_Id
:= New_Node
(N_Real_Literal
, Loc
);
234 (Num
=> abs Significand
,
236 Rbase
=> UI_To_Int
(Radix
),
237 Negative
=> Significand
< 0));
241 end Make_Float_Literal
;
243 -------------------------------------
244 -- Make_Implicit_Exception_Handler --
245 -------------------------------------
247 function Make_Implicit_Exception_Handler
249 Choice_Parameter
: Node_Id
:= Empty
;
250 Exception_Choices
: List_Id
;
251 Statements
: List_Id
) return Node_Id
257 -- Set the source location only when debugging the expanded code
259 -- When debugging the source code directly, we do not want the compiler
260 -- to associate this implicit exception handler with any specific source
261 -- line, because it can potentially confuse the debugger. The most
262 -- damaging situation would arise when the debugger tries to insert a
263 -- breakpoint at a certain line. If the code of the associated implicit
264 -- exception handler is generated before the code of that line, then the
265 -- debugger will end up inserting the breakpoint inside the exception
266 -- handler, rather than the code the user intended to break on. As a
267 -- result, it is likely that the program will not hit the breakpoint
270 if Debug_Generated_Code
then
277 Make_Exception_Handler
278 (Loc
, Choice_Parameter
, Exception_Choices
, Statements
);
279 Set_Local_Raise_Statements
(Handler
, No_Elist
);
281 end Make_Implicit_Exception_Handler
;
283 --------------------------------
284 -- Make_Implicit_If_Statement --
285 --------------------------------
287 function Make_Implicit_If_Statement
290 Then_Statements
: List_Id
;
291 Elsif_Parts
: List_Id
:= No_List
;
292 Else_Statements
: List_Id
:= No_List
) return Node_Id
295 Check_Restriction
(No_Implicit_Conditionals
, Node
);
297 return Make_If_Statement
(Sloc
(Node
),
302 end Make_Implicit_If_Statement
;
304 -------------------------------------
305 -- Make_Implicit_Label_Declaration --
306 -------------------------------------
308 function Make_Implicit_Label_Declaration
310 Defining_Identifier
: Node_Id
;
311 Label_Construct
: Node_Id
) return Node_Id
313 N
: constant Node_Id
:=
314 Make_Implicit_Label_Declaration
(Loc
, Defining_Identifier
);
316 Set_Label_Construct
(N
, Label_Construct
);
318 end Make_Implicit_Label_Declaration
;
320 ----------------------------------
321 -- Make_Implicit_Loop_Statement --
322 ----------------------------------
324 function Make_Implicit_Loop_Statement
326 Statements
: List_Id
;
327 Identifier
: Node_Id
:= Empty
;
328 Iteration_Scheme
: Node_Id
:= Empty
;
329 Has_Created_Identifier
: Boolean := False;
330 End_Label
: Node_Id
:= Empty
) return Node_Id
333 Check_Restriction
(No_Implicit_Loops
, Node
);
335 if Present
(Iteration_Scheme
)
336 and then Present
(Condition
(Iteration_Scheme
))
338 Check_Restriction
(No_Implicit_Conditionals
, Node
);
341 return Make_Loop_Statement
(Sloc
(Node
),
342 Identifier
=> Identifier
,
343 Iteration_Scheme
=> Iteration_Scheme
,
344 Statements
=> Statements
,
345 Has_Created_Identifier
=> Has_Created_Identifier
,
346 End_Label
=> End_Label
);
347 end Make_Implicit_Loop_Statement
;
349 --------------------------
350 -- Make_Integer_Literal --
351 ---------------------------
353 function Make_Integer_Literal
355 Intval
: Int
) return Node_Id
358 return Make_Integer_Literal
(Loc
, UI_From_Int
(Intval
));
359 end Make_Integer_Literal
;
361 --------------------------------
362 -- Make_Linker_Section_Pragma --
363 --------------------------------
365 function Make_Linker_Section_Pragma
368 Sec
: String) return Node_Id
378 (Make_Pragma_Argument_Association
380 Expression
=> New_Occurrence_Of
(Ent
, Loc
)),
381 Make_Pragma_Argument_Association
388 Set_Has_Gigi_Rep_Item
(Ent
);
390 end Make_Linker_Section_Pragma
;
399 Pragma_Argument_Associations
: List_Id
:= No_List
) return Node_Id
404 Pragma_Argument_Associations
=> Pragma_Argument_Associations
,
405 Pragma_Identifier
=> Make_Identifier
(Sloc
, Chars
));
408 ---------------------------------
409 -- Make_Raise_Constraint_Error --
410 ---------------------------------
412 function Make_Raise_Constraint_Error
414 Condition
: Node_Id
:= Empty
;
415 Reason
: RT_Exception_Code
) return Node_Id
418 pragma Assert
(Reason
in RT_CE_Exceptions
);
420 Make_Raise_Constraint_Error
(Sloc
,
421 Condition
=> Condition
,
423 UI_From_Int
(RT_Exception_Code
'Pos (Reason
)));
424 end Make_Raise_Constraint_Error
;
426 ------------------------------
427 -- Make_Raise_Program_Error --
428 ------------------------------
430 function Make_Raise_Program_Error
432 Condition
: Node_Id
:= Empty
;
433 Reason
: RT_Exception_Code
) return Node_Id
436 pragma Assert
(Reason
in RT_PE_Exceptions
);
438 Make_Raise_Program_Error
(Sloc
,
439 Condition
=> Condition
,
441 UI_From_Int
(RT_Exception_Code
'Pos (Reason
)));
442 end Make_Raise_Program_Error
;
444 ------------------------------
445 -- Make_Raise_Storage_Error --
446 ------------------------------
448 function Make_Raise_Storage_Error
450 Condition
: Node_Id
:= Empty
;
451 Reason
: RT_Exception_Code
) return Node_Id
454 pragma Assert
(Reason
in RT_SE_Exceptions
);
456 Make_Raise_Storage_Error
(Sloc
,
457 Condition
=> Condition
,
459 UI_From_Int
(RT_Exception_Code
'Pos (Reason
)));
460 end Make_Raise_Storage_Error
;
462 -------------------------
463 -- Make_String_Literal --
464 -------------------------
466 function Make_String_Literal
468 Strval
: String) return Node_Id
472 Store_String_Chars
(Strval
);
474 Make_String_Literal
(Sloc
,
475 Strval
=> End_String
);
476 end Make_String_Literal
;
482 function Make_Temporary
485 Related_Node
: Node_Id
:= Empty
) return Entity_Id
487 Temp
: constant Entity_Id
:=
488 Make_Defining_Identifier
(Loc
,
489 Chars
=> New_Internal_Name
(Id
));
491 Set_Related_Expression
(Temp
, Related_Node
);
495 ---------------------------
496 -- Make_Unsuppress_Block --
497 ---------------------------
499 -- Generates the following expansion:
502 -- pragma Suppress (<check>);
507 function Make_Unsuppress_Block
510 Stmts
: List_Id
) return Node_Id
514 Make_Block_Statement
(Loc
,
515 Declarations
=> New_List
(
517 Chars
=> Name_Suppress
,
518 Pragma_Argument_Associations
=> New_List
(
519 Make_Pragma_Argument_Association
(Loc
,
520 Expression
=> Make_Identifier
(Loc
, Check
))))),
522 Handled_Statement_Sequence
=>
523 Make_Handled_Sequence_Of_Statements
(Loc
,
524 Statements
=> Stmts
));
525 end Make_Unsuppress_Block
;
527 --------------------------
528 -- New_Constraint_Error --
529 --------------------------
531 function New_Constraint_Error
(Loc
: Source_Ptr
) return Node_Id
is
532 Ident_Node
: Node_Id
;
533 Raise_Node
: Node_Id
;
536 Ident_Node
:= New_Node
(N_Identifier
, Loc
);
537 Set_Chars
(Ident_Node
, Chars
(Standard_Entity
(S_Constraint_Error
)));
538 Set_Entity
(Ident_Node
, Standard_Entity
(S_Constraint_Error
));
539 Raise_Node
:= New_Node
(N_Raise_Statement
, Loc
);
540 Set_Name
(Raise_Node
, Ident_Node
);
542 end New_Constraint_Error
;
544 -----------------------
545 -- New_External_Name --
546 -----------------------
548 function New_External_Name
549 (Related_Id
: Name_Id
;
550 Suffix
: Character := ' ';
551 Suffix_Index
: Int
:= 0;
552 Prefix
: Character := ' ') return Name_Id
555 Get_Name_String
(Related_Id
);
557 if Prefix
/= ' ' then
558 pragma Assert
(Is_OK_Internal_Letter
(Prefix
) or else Prefix
= '_');
560 for J
in reverse 1 .. Name_Len
loop
561 Name_Buffer
(J
+ 1) := Name_Buffer
(J
);
564 Name_Len
:= Name_Len
+ 1;
565 Name_Buffer
(1) := Prefix
;
568 if Suffix
/= ' ' then
569 pragma Assert
(Is_OK_Internal_Letter
(Suffix
));
570 Add_Char_To_Name_Buffer
(Suffix
);
573 if Suffix_Index
/= 0 then
574 if Suffix_Index
< 0 then
575 Add_Unique_Serial_Number
;
577 Add_Nat_To_Name_Buffer
(Suffix_Index
);
582 end New_External_Name
;
584 function New_External_Name
585 (Related_Id
: Name_Id
;
587 Suffix_Index
: Int
:= 0;
588 Prefix
: Character := ' ') return Name_Id
591 Get_Name_String
(Related_Id
);
593 if Prefix
/= ' ' then
594 pragma Assert
(Is_OK_Internal_Letter
(Prefix
));
596 for J
in reverse 1 .. Name_Len
loop
597 Name_Buffer
(J
+ 1) := Name_Buffer
(J
);
600 Name_Len
:= Name_Len
+ 1;
601 Name_Buffer
(1) := Prefix
;
605 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ Suffix
'Length) := Suffix
;
606 Name_Len
:= Name_Len
+ Suffix
'Length;
609 if Suffix_Index
/= 0 then
610 if Suffix_Index
< 0 then
611 Add_Unique_Serial_Number
;
613 Add_Nat_To_Name_Buffer
(Suffix_Index
);
618 end New_External_Name
;
620 function New_External_Name
622 Suffix_Index
: Nat
) return Name_Id
625 Name_Buffer
(1) := Suffix
;
627 Add_Nat_To_Name_Buffer
(Suffix_Index
);
629 end New_External_Name
;
631 -----------------------
632 -- New_Internal_Name --
633 -----------------------
635 function New_Internal_Name
(Id_Char
: Character) return Name_Id
is
637 pragma Assert
(Is_OK_Internal_Letter
(Id_Char
));
638 Name_Buffer
(1) := Id_Char
;
640 Add_Unique_Serial_Number
;
642 end New_Internal_Name
;
644 -----------------------
645 -- New_Occurrence_Of --
646 -----------------------
648 function New_Occurrence_Of
650 Loc
: Source_Ptr
) return Node_Id
652 Occurrence
: Node_Id
;
655 Occurrence
:= New_Node
(N_Identifier
, Loc
);
656 Set_Chars
(Occurrence
, Chars
(Def_Id
));
657 Set_Entity
(Occurrence
, Def_Id
);
659 if Is_Type
(Def_Id
) then
660 Set_Etype
(Occurrence
, Def_Id
);
662 Set_Etype
(Occurrence
, Etype
(Def_Id
));
666 end New_Occurrence_Of
;
673 (New_Node_Kind
: Node_Kind
;
674 New_Sloc
: Source_Ptr
) return Node_Id
676 type Name_Of_Type
is array (N_Op
) of Name_Id
;
677 Name_Of
: constant Name_Of_Type
:= Name_Of_Type
'(
678 N_Op_And => Name_Op_And,
679 N_Op_Or => Name_Op_Or,
680 N_Op_Xor => Name_Op_Xor,
681 N_Op_Eq => Name_Op_Eq,
682 N_Op_Ne => Name_Op_Ne,
683 N_Op_Lt => Name_Op_Lt,
684 N_Op_Le => Name_Op_Le,
685 N_Op_Gt => Name_Op_Gt,
686 N_Op_Ge => Name_Op_Ge,
687 N_Op_Add => Name_Op_Add,
688 N_Op_Subtract => Name_Op_Subtract,
689 N_Op_Concat => Name_Op_Concat,
690 N_Op_Multiply => Name_Op_Multiply,
691 N_Op_Divide => Name_Op_Divide,
692 N_Op_Mod => Name_Op_Mod,
693 N_Op_Rem => Name_Op_Rem,
694 N_Op_Expon => Name_Op_Expon,
695 N_Op_Plus => Name_Op_Add,
696 N_Op_Minus => Name_Op_Subtract,
697 N_Op_Abs => Name_Op_Abs,
698 N_Op_Not => Name_Op_Not,
700 -- We don't really need these shift operators, since they never
701 -- appear as operators in the source, but the path of least
702 -- resistance is to put them in (the aggregate must be complete).
704 N_Op_Rotate_Left => Name_Rotate_Left,
705 N_Op_Rotate_Right => Name_Rotate_Right,
706 N_Op_Shift_Left => Name_Shift_Left,
707 N_Op_Shift_Right => Name_Shift_Right,
708 N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic);
710 Nod : constant Node_Id := New_Node (New_Node_Kind, New_Sloc);
713 if New_Node_Kind in Name_Of'Range then
714 Set_Chars (Nod, Name_Of (New_Node_Kind));
720 ----------------------
721 -- New_Reference_To --
722 ----------------------
724 function New_Reference_To
726 Loc : Source_Ptr) return Node_Id
728 pragma Assert (Nkind (Def_Id) in N_Entity);
729 Occurrence : Node_Id;
731 Occurrence := New_Node (N_Identifier, Loc);
732 Set_Chars (Occurrence, Chars (Def_Id));
733 Set_Entity (Occurrence, Def_Id);
735 end New_Reference_To;
737 -----------------------
738 -- New_Suffixed_Name --
739 -----------------------
741 function New_Suffixed_Name
742 (Related_Id : Name_Id;
743 Suffix : String) return Name_Id
746 Get_Name_String (Related_Id);
747 Add_Char_To_Name_Buffer ('_
');
748 Add_Str_To_Name_Buffer (Suffix);
750 end New_Suffixed_Name;
756 function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
760 Make_Type_Conversion (Sloc (Expr),
761 Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
762 Expression => Relocate_Node (Expr));
763 Set_Conversion_OK (Result, True);
764 Set_Etype (Result, Typ);
768 --------------------------
769 -- Unchecked_Convert_To --
770 --------------------------
772 function Unchecked_Convert_To
774 Expr : Node_Id) return Node_Id
776 Loc : constant Source_Ptr := Sloc (Expr);
778 Expr_Parent : Node_Id;
781 -- If the expression is already of the correct type, then nothing
782 -- to do, except for relocating the node in case this is required.
784 if Present (Etype (Expr))
785 and then (Base_Type (Etype (Expr)) = Typ
786 or else Etype (Expr) = Typ)
788 return Relocate_Node (Expr);
790 -- Cases where the inner expression is itself an unchecked conversion
791 -- to the same type, and we can thus eliminate the outer conversion.
793 elsif Nkind (Expr) = N_Unchecked_Type_Conversion
794 and then Entity (Subtype_Mark (Expr)) = Typ
796 Result := Relocate_Node (Expr);
798 elsif Nkind (Expr) = N_Null
799 and then Is_Access_Type (Typ)
801 -- No need for a conversion
803 Result := Relocate_Node (Expr);
808 -- Capture the parent of the expression before relocating it and
809 -- creating the conversion, so the conversion's parent can be set
810 -- to the original parent below.
812 Expr_Parent := Parent (Expr);
815 Make_Unchecked_Type_Conversion (Loc,
816 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
817 Expression => Relocate_Node (Expr));
819 Set_Parent (Result, Expr_Parent);
822 Set_Etype (Result, Typ);
824 end Unchecked_Convert_To;