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 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 procedure Add_Unique_Serial_Number
is
56 Unit_Node
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
59 Add_Nat_To_Name_Buffer
(Increment_Serial_Number
);
61 -- Add either b or s, depending on whether current unit is a spec
62 -- or a body. This is needed because we may generate the same name
63 -- in a spec and a body otherwise.
65 Name_Len
:= Name_Len
+ 1;
67 if Nkind
(Unit_Node
) = N_Package_Declaration
68 or else Nkind
(Unit_Node
) = N_Subprogram_Declaration
69 or else Nkind
(Unit_Node
) in N_Generic_Declaration
71 Name_Buffer
(Name_Len
) := 's';
73 Name_Buffer
(Name_Len
) := 'b';
75 end Add_Unique_Serial_Number
;
81 function Checks_Off
(N
: Node_Id
) return Node_Id
is
84 Make_Unchecked_Expression
(Sloc
(N
),
92 function Convert_To
(Typ
: Entity_Id
; Expr
: Node_Id
) return Node_Id
is
96 if Present
(Etype
(Expr
))
97 and then (Etype
(Expr
)) = Typ
99 return Relocate_Node
(Expr
);
102 Make_Type_Conversion
(Sloc
(Expr
),
103 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Sloc
(Expr
)),
104 Expression
=> Relocate_Node
(Expr
));
106 Set_Etype
(Result
, Typ
);
115 procedure Discard_List
(L
: List_Id
) is
116 pragma Warnings
(Off
, L
);
125 procedure Discard_Node
(N
: Node_Or_Entity_Id
) is
126 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
161 Typ
: Entity_Id
) return Node_Id
163 Full_Type
: Entity_Id
:= Typ
;
166 if Is_Private_Type
(Typ
) then
167 Full_Type
:= Underlying_Type
(Typ
);
171 Unchecked_Convert_To
(
172 New_Occurrence_Of
(Etype
(Access_Disp_Table
(Full_Type
)), Loc
),
173 Make_Selected_Component
(Loc
,
174 Prefix
=> New_Copy
(Rec
),
176 New_Reference_To
(Tag_Component
(Full_Type
), Loc
)));
179 -----------------------
180 -- Make_DT_Component --
181 -----------------------
183 function Make_DT_Component
186 I
: Positive) return Node_Id
189 Full_Type
: Entity_Id
:= Typ
;
192 if Is_Private_Type
(Typ
) then
193 Full_Type
:= Underlying_Type
(Typ
);
196 X
:= First_Component
(
197 Designated_Type
(Etype
(Access_Disp_Table
(Full_Type
))));
200 X
:= Next_Component
(X
);
203 return New_Reference_To
(X
, Loc
);
204 end Make_DT_Component
;
206 --------------------------------
207 -- Make_Implicit_If_Statement --
208 --------------------------------
210 function Make_Implicit_If_Statement
213 Then_Statements
: List_Id
;
214 Elsif_Parts
: List_Id
:= No_List
;
215 Else_Statements
: List_Id
:= No_List
) return Node_Id
218 Check_Restriction
(No_Implicit_Conditionals
, Node
);
219 return Make_If_Statement
(Sloc
(Node
),
224 end Make_Implicit_If_Statement
;
226 -------------------------------------
227 -- Make_Implicit_Label_Declaration --
228 -------------------------------------
230 function Make_Implicit_Label_Declaration
232 Defining_Identifier
: Node_Id
;
233 Label_Construct
: Node_Id
) return Node_Id
235 N
: constant Node_Id
:=
236 Make_Implicit_Label_Declaration
(Loc
, Defining_Identifier
);
239 Set_Label_Construct
(N
, Label_Construct
);
241 end Make_Implicit_Label_Declaration
;
243 ----------------------------------
244 -- Make_Implicit_Loop_Statement --
245 ----------------------------------
247 function Make_Implicit_Loop_Statement
249 Statements
: List_Id
;
250 Identifier
: Node_Id
:= Empty
;
251 Iteration_Scheme
: Node_Id
:= Empty
;
252 Has_Created_Identifier
: Boolean := False;
253 End_Label
: Node_Id
:= Empty
) return Node_Id
256 Check_Restriction
(No_Implicit_Loops
, Node
);
258 if Present
(Iteration_Scheme
)
259 and then Present
(Condition
(Iteration_Scheme
))
261 Check_Restriction
(No_Implicit_Conditionals
, Node
);
264 return Make_Loop_Statement
(Sloc
(Node
),
265 Identifier
=> Identifier
,
266 Iteration_Scheme
=> Iteration_Scheme
,
267 Statements
=> Statements
,
268 Has_Created_Identifier
=> Has_Created_Identifier
,
269 End_Label
=> End_Label
);
270 end Make_Implicit_Loop_Statement
;
272 --------------------------
273 -- Make_Integer_Literal --
274 ---------------------------
276 function Make_Integer_Literal
278 Intval
: Int
) return Node_Id
281 return Make_Integer_Literal
(Loc
, UI_From_Int
(Intval
));
282 end Make_Integer_Literal
;
284 ---------------------------------
285 -- Make_Raise_Constraint_Error --
286 ---------------------------------
288 function Make_Raise_Constraint_Error
290 Condition
: Node_Id
:= Empty
;
291 Reason
: RT_Exception_Code
) return Node_Id
294 pragma Assert
(Reason
in RT_CE_Exceptions
);
296 Make_Raise_Constraint_Error
(Sloc
,
297 Condition
=> Condition
,
299 UI_From_Int
(RT_Exception_Code
'Pos (Reason
)));
300 end Make_Raise_Constraint_Error
;
302 ------------------------------
303 -- Make_Raise_Program_Error --
304 ------------------------------
306 function Make_Raise_Program_Error
308 Condition
: Node_Id
:= Empty
;
309 Reason
: RT_Exception_Code
) return Node_Id
312 pragma Assert
(Reason
in RT_PE_Exceptions
);
314 Make_Raise_Program_Error
(Sloc
,
315 Condition
=> Condition
,
317 UI_From_Int
(RT_Exception_Code
'Pos (Reason
)));
318 end Make_Raise_Program_Error
;
320 ------------------------------
321 -- Make_Raise_Storage_Error --
322 ------------------------------
324 function Make_Raise_Storage_Error
326 Condition
: Node_Id
:= Empty
;
327 Reason
: RT_Exception_Code
) return Node_Id
330 pragma Assert
(Reason
in RT_SE_Exceptions
);
332 Make_Raise_Storage_Error
(Sloc
,
333 Condition
=> Condition
,
335 UI_From_Int
(RT_Exception_Code
'Pos (Reason
)));
336 end Make_Raise_Storage_Error
;
338 -------------------------
339 -- Make_String_Literal --
340 -------------------------
342 function Make_String_Literal
344 Strval
: String) return Node_Id
348 Store_String_Chars
(Strval
);
350 Make_String_Literal
(Sloc
,
351 Strval
=> End_String
);
352 end Make_String_Literal
;
354 ---------------------------
355 -- Make_Unsuppress_Block --
356 ---------------------------
358 -- Generates the following expansion:
361 -- pragma Suppress (<check>);
366 function Make_Unsuppress_Block
369 Stmts
: List_Id
) return Node_Id
373 Make_Block_Statement
(Loc
,
374 Declarations
=> New_List
(
376 Chars
=> Name_Suppress
,
377 Pragma_Argument_Associations
=> New_List
(
378 Make_Pragma_Argument_Association
(Loc
,
379 Expression
=> Make_Identifier
(Loc
, Check
))))),
381 Handled_Statement_Sequence
=>
382 Make_Handled_Sequence_Of_Statements
(Loc
,
383 Statements
=> Stmts
));
384 end Make_Unsuppress_Block
;
386 --------------------------
387 -- New_Constraint_Error --
388 --------------------------
390 function New_Constraint_Error
(Loc
: Source_Ptr
) return Node_Id
is
391 Ident_Node
: Node_Id
;
392 Raise_Node
: Node_Id
;
395 Ident_Node
:= New_Node
(N_Identifier
, Loc
);
396 Set_Chars
(Ident_Node
, Chars
(Standard_Entity
(S_Constraint_Error
)));
397 Set_Entity
(Ident_Node
, Standard_Entity
(S_Constraint_Error
));
398 Raise_Node
:= New_Node
(N_Raise_Statement
, Loc
);
399 Set_Name
(Raise_Node
, Ident_Node
);
401 end New_Constraint_Error
;
403 -----------------------
404 -- New_External_Name --
405 -----------------------
407 function New_External_Name
408 (Related_Id
: Name_Id
;
409 Suffix
: Character := ' ';
410 Suffix_Index
: Int
:= 0;
411 Prefix
: Character := ' ') return Name_Id
414 Get_Name_String
(Related_Id
);
416 if Prefix
/= ' ' then
417 pragma Assert
(Is_OK_Internal_Letter
(Prefix
));
419 for J
in reverse 1 .. Name_Len
loop
420 Name_Buffer
(J
+ 1) := Name_Buffer
(J
);
423 Name_Len
:= Name_Len
+ 1;
424 Name_Buffer
(1) := Prefix
;
427 if Suffix
/= ' ' then
428 pragma Assert
(Is_OK_Internal_Letter
(Suffix
));
429 Name_Len
:= Name_Len
+ 1;
430 Name_Buffer
(Name_Len
) := Suffix
;
433 if Suffix_Index
/= 0 then
434 if Suffix_Index
< 0 then
435 Add_Unique_Serial_Number
;
437 Add_Nat_To_Name_Buffer
(Suffix_Index
);
442 end New_External_Name
;
444 function New_External_Name
445 (Related_Id
: Name_Id
;
447 Suffix_Index
: Int
:= 0;
448 Prefix
: Character := ' ') return Name_Id
451 Get_Name_String
(Related_Id
);
453 if Prefix
/= ' ' then
454 pragma Assert
(Is_OK_Internal_Letter
(Prefix
));
456 for J
in reverse 1 .. Name_Len
loop
457 Name_Buffer
(J
+ 1) := Name_Buffer
(J
);
460 Name_Len
:= Name_Len
+ 1;
461 Name_Buffer
(1) := Prefix
;
465 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ Suffix
'Length) := Suffix
;
466 Name_Len
:= Name_Len
+ Suffix
'Length;
469 if Suffix_Index
/= 0 then
470 if Suffix_Index
< 0 then
471 Add_Unique_Serial_Number
;
473 Add_Nat_To_Name_Buffer
(Suffix_Index
);
478 end New_External_Name
;
480 function New_External_Name
482 Suffix_Index
: Nat
) return Name_Id
485 Name_Buffer
(1) := Suffix
;
487 Add_Nat_To_Name_Buffer
(Suffix_Index
);
489 end New_External_Name
;
491 -----------------------
492 -- New_Internal_Name --
493 -----------------------
495 function New_Internal_Name
(Id_Char
: Character) return Name_Id
is
497 pragma Assert
(Is_OK_Internal_Letter
(Id_Char
));
498 Name_Buffer
(1) := Id_Char
;
500 Add_Unique_Serial_Number
;
502 end New_Internal_Name
;
504 -----------------------
505 -- New_Occurrence_Of --
506 -----------------------
508 function New_Occurrence_Of
510 Loc
: Source_Ptr
) return Node_Id
512 Occurrence
: Node_Id
;
515 Occurrence
:= New_Node
(N_Identifier
, Loc
);
516 Set_Chars
(Occurrence
, Chars
(Def_Id
));
517 Set_Entity
(Occurrence
, Def_Id
);
519 if Is_Type
(Def_Id
) then
520 Set_Etype
(Occurrence
, Def_Id
);
522 Set_Etype
(Occurrence
, Etype
(Def_Id
));
526 end New_Occurrence_Of
;
528 ----------------------
529 -- New_Reference_To --
530 ----------------------
532 function New_Reference_To
534 Loc
: Source_Ptr
) return Node_Id
536 Occurrence
: Node_Id
;
539 Occurrence
:= New_Node
(N_Identifier
, Loc
);
540 Set_Chars
(Occurrence
, Chars
(Def_Id
));
541 Set_Entity
(Occurrence
, Def_Id
);
543 end New_Reference_To
;
545 -----------------------
546 -- New_Suffixed_Name --
547 -----------------------
549 function New_Suffixed_Name
550 (Related_Id
: Name_Id
;
551 Suffix
: String) return 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
570 Make_Type_Conversion
(Sloc
(Expr
),
571 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Sloc
(Expr
)),
572 Expression
=> Relocate_Node
(Expr
));
573 Set_Conversion_OK
(Result
, True);
574 Set_Etype
(Result
, Typ
);
578 --------------------------
579 -- Unchecked_Convert_To --
580 --------------------------
582 function Unchecked_Convert_To
584 Expr
: Node_Id
) return Node_Id
586 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
590 -- If the expression is already of the correct type, then nothing
591 -- to do, except for relocating the node in case this is required.
593 if Present
(Etype
(Expr
))
594 and then (Base_Type
(Etype
(Expr
)) = Typ
595 or else Etype
(Expr
) = Typ
)
597 return Relocate_Node
(Expr
);
599 -- Cases where the inner expression is itself an unchecked conversion
600 -- to the same type, and we can thus eliminate the outer conversion.
602 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
603 and then Entity
(Subtype_Mark
(Expr
)) = Typ
605 Result
:= Relocate_Node
(Expr
);
607 elsif Nkind
(Expr
) = N_Null
608 and then Is_Access_Type
(Typ
)
610 -- No need for a conversion
612 Result
:= Relocate_Node
(Expr
);
618 Make_Unchecked_Type_Conversion
(Loc
,
619 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
620 Expression
=> Relocate_Node
(Expr
));
623 Set_Etype
(Result
, Typ
);
625 end Unchecked_Convert_To
;