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
;