1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 ------------------------------------------------------------------------------
28 with Atree
; use Atree
;
29 with Einfo
; use Einfo
;
31 with Namet
; use Namet
;
32 with Nlists
; use Nlists
;
33 with Nmake
; use Nmake
;
34 with Restrict
; use Restrict
;
35 with Sinfo
; use Sinfo
;
36 with Snames
; use Snames
;
37 with Stand
; use Stand
;
38 with Uintp
; use Uintp
;
40 package body Tbuild
is
42 -----------------------
43 -- Local Subprograms --
44 -----------------------
46 procedure Add_Unique_Serial_Number
;
47 -- Add a unique serialization to the string in the Name_Buffer. This
48 -- consists of a unit specific serial number, and b/s for body/spec.
50 ------------------------------
51 -- Add_Unique_Serial_Number --
52 ------------------------------
54 procedure Add_Unique_Serial_Number
is
55 Unit_Node
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
58 Add_Nat_To_Name_Buffer
(Increment_Serial_Number
);
60 -- Add either b or s, depending on whether current unit is a spec
61 -- or a body. This is needed because we may generate the same name
62 -- in a spec and a body otherwise.
64 Name_Len
:= Name_Len
+ 1;
66 if Nkind
(Unit_Node
) = N_Package_Declaration
67 or else Nkind
(Unit_Node
) = N_Subprogram_Declaration
68 or else Nkind
(Unit_Node
) in N_Generic_Declaration
70 Name_Buffer
(Name_Len
) := 's';
72 Name_Buffer
(Name_Len
) := 'b';
74 end Add_Unique_Serial_Number
;
80 function Checks_Off
(N
: Node_Id
) return Node_Id
is
83 Make_Unchecked_Expression
(Sloc
(N
),
91 function Convert_To
(Typ
: Entity_Id
; Expr
: Node_Id
) return Node_Id
is
95 if Present
(Etype
(Expr
))
96 and then (Etype
(Expr
)) = Typ
98 return Relocate_Node
(Expr
);
101 Make_Type_Conversion
(Sloc
(Expr
),
102 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Sloc
(Expr
)),
103 Expression
=> Relocate_Node
(Expr
));
105 Set_Etype
(Result
, Typ
);
110 -------------------------------------------
111 -- Make_Byte_Aligned_Attribute_Reference --
112 -------------------------------------------
114 function Make_Byte_Aligned_Attribute_Reference
117 Attribute_Name
: Name_Id
)
120 N
: constant Node_Id
:=
121 Make_Attribute_Reference
(Sloc
,
123 Attribute_Name
=> Attribute_Name
);
126 pragma Assert
(Attribute_Name
= Name_Address
128 Attribute_Name
= Name_Unrestricted_Access
);
129 Set_Must_Be_Byte_Aligned
(N
, True);
131 end Make_Byte_Aligned_Attribute_Reference
;
137 function Make_DT_Access
143 Full_Type
: Entity_Id
:= Typ
;
146 if Is_Private_Type
(Typ
) then
147 Full_Type
:= Underlying_Type
(Typ
);
151 Unchecked_Convert_To
(
152 New_Occurrence_Of
(Etype
(Access_Disp_Table
(Full_Type
)), Loc
),
153 Make_Selected_Component
(Loc
,
154 Prefix
=> New_Copy
(Rec
),
156 New_Reference_To
(Tag_Component
(Full_Type
), Loc
)));
159 -----------------------
160 -- Make_DT_Component --
161 -----------------------
163 function Make_DT_Component
170 Full_Type
: Entity_Id
:= Typ
;
173 if Is_Private_Type
(Typ
) then
174 Full_Type
:= Underlying_Type
(Typ
);
177 X
:= First_Component
(
178 Designated_Type
(Etype
(Access_Disp_Table
(Full_Type
))));
181 X
:= Next_Component
(X
);
184 return New_Reference_To
(X
, Loc
);
185 end Make_DT_Component
;
187 --------------------------------
188 -- Make_Implicit_If_Statement --
189 --------------------------------
191 function Make_Implicit_If_Statement
194 Then_Statements
: List_Id
;
195 Elsif_Parts
: List_Id
:= No_List
;
196 Else_Statements
: List_Id
:= No_List
)
200 Check_Restriction
(No_Implicit_Conditionals
, Node
);
201 return Make_If_Statement
(Sloc
(Node
),
206 end Make_Implicit_If_Statement
;
208 -------------------------------------
209 -- Make_Implicit_Label_Declaration --
210 -------------------------------------
212 function Make_Implicit_Label_Declaration
214 Defining_Identifier
: Node_Id
;
215 Label_Construct
: Node_Id
)
218 N
: constant Node_Id
:=
219 Make_Implicit_Label_Declaration
(Loc
, Defining_Identifier
);
222 Set_Label_Construct
(N
, Label_Construct
);
224 end Make_Implicit_Label_Declaration
;
226 ----------------------------------
227 -- Make_Implicit_Loop_Statement --
228 ----------------------------------
230 function Make_Implicit_Loop_Statement
232 Statements
: List_Id
;
233 Identifier
: Node_Id
:= Empty
;
234 Iteration_Scheme
: Node_Id
:= Empty
;
235 Has_Created_Identifier
: Boolean := False;
236 End_Label
: Node_Id
:= Empty
)
240 Check_Restriction
(No_Implicit_Loops
, Node
);
242 if Present
(Iteration_Scheme
)
243 and then Present
(Condition
(Iteration_Scheme
))
245 Check_Restriction
(No_Implicit_Conditionals
, Node
);
248 return Make_Loop_Statement
(Sloc
(Node
),
249 Identifier
=> Identifier
,
250 Iteration_Scheme
=> Iteration_Scheme
,
251 Statements
=> Statements
,
252 Has_Created_Identifier
=> Has_Created_Identifier
,
253 End_Label
=> End_Label
);
254 end Make_Implicit_Loop_Statement
;
256 --------------------------
257 -- Make_Integer_Literal --
258 ---------------------------
260 function Make_Integer_Literal
266 return Make_Integer_Literal
(Loc
, UI_From_Int
(Intval
));
267 end Make_Integer_Literal
;
269 ---------------------------------
270 -- Make_Raise_Constraint_Error --
271 ---------------------------------
273 function Make_Raise_Constraint_Error
275 Condition
: Node_Id
:= Empty
;
276 Reason
: RT_Exception_Code
)
280 pragma Assert
(Reason
in RT_CE_Exceptions
);
282 Make_Raise_Constraint_Error
(Sloc
,
283 Condition
=> Condition
,
285 UI_From_Int
(RT_Exception_Code
'Pos (Reason
)));
286 end Make_Raise_Constraint_Error
;
288 ------------------------------
289 -- Make_Raise_Program_Error --
290 ------------------------------
292 function Make_Raise_Program_Error
294 Condition
: Node_Id
:= Empty
;
295 Reason
: RT_Exception_Code
)
299 pragma Assert
(Reason
in RT_PE_Exceptions
);
301 Make_Raise_Program_Error
(Sloc
,
302 Condition
=> Condition
,
304 UI_From_Int
(RT_Exception_Code
'Pos (Reason
)));
305 end Make_Raise_Program_Error
;
307 ------------------------------
308 -- Make_Raise_Storage_Error --
309 ------------------------------
311 function Make_Raise_Storage_Error
313 Condition
: Node_Id
:= Empty
;
314 Reason
: RT_Exception_Code
)
318 pragma Assert
(Reason
in RT_SE_Exceptions
);
320 Make_Raise_Storage_Error
(Sloc
,
321 Condition
=> Condition
,
323 UI_From_Int
(RT_Exception_Code
'Pos (Reason
)));
324 end Make_Raise_Storage_Error
;
326 ---------------------------
327 -- Make_Unsuppress_Block --
328 ---------------------------
330 -- Generates the following expansion:
333 -- pragma Suppress (<check>);
338 function Make_Unsuppress_Block
346 Make_Block_Statement
(Loc
,
347 Declarations
=> New_List
(
349 Chars
=> Name_Suppress
,
350 Pragma_Argument_Associations
=> New_List
(
351 Make_Pragma_Argument_Association
(Loc
,
352 Expression
=> Make_Identifier
(Loc
, Check
))))),
354 Handled_Statement_Sequence
=>
355 Make_Handled_Sequence_Of_Statements
(Loc
,
356 Statements
=> Stmts
));
357 end Make_Unsuppress_Block
;
359 --------------------------
360 -- New_Constraint_Error --
361 --------------------------
363 function New_Constraint_Error
(Loc
: Source_Ptr
) return Node_Id
is
364 Ident_Node
: Node_Id
;
365 Raise_Node
: Node_Id
;
368 Ident_Node
:= New_Node
(N_Identifier
, Loc
);
369 Set_Chars
(Ident_Node
, Chars
(Standard_Entity
(S_Constraint_Error
)));
370 Set_Entity
(Ident_Node
, Standard_Entity
(S_Constraint_Error
));
371 Raise_Node
:= New_Node
(N_Raise_Statement
, Loc
);
372 Set_Name
(Raise_Node
, Ident_Node
);
374 end New_Constraint_Error
;
376 -----------------------
377 -- New_External_Name --
378 -----------------------
380 function New_External_Name
381 (Related_Id
: Name_Id
;
382 Suffix
: Character := ' ';
383 Suffix_Index
: Int
:= 0;
384 Prefix
: Character := ' ')
388 Get_Name_String
(Related_Id
);
390 if Prefix
/= ' ' then
391 pragma Assert
(Is_OK_Internal_Letter
(Prefix
));
393 for J
in reverse 1 .. Name_Len
loop
394 Name_Buffer
(J
+ 1) := Name_Buffer
(J
);
397 Name_Len
:= Name_Len
+ 1;
398 Name_Buffer
(1) := Prefix
;
401 if Suffix
/= ' ' then
402 pragma Assert
(Is_OK_Internal_Letter
(Suffix
));
403 Name_Len
:= Name_Len
+ 1;
404 Name_Buffer
(Name_Len
) := Suffix
;
407 if Suffix_Index
/= 0 then
408 if Suffix_Index
< 0 then
409 Add_Unique_Serial_Number
;
411 Add_Nat_To_Name_Buffer
(Suffix_Index
);
416 end New_External_Name
;
418 function New_External_Name
419 (Related_Id
: Name_Id
;
421 Suffix_Index
: Int
:= 0;
422 Prefix
: Character := ' ')
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
461 Name_Buffer
(1) := Suffix
;
463 Add_Nat_To_Name_Buffer
(Suffix_Index
);
465 end New_External_Name
;
467 -----------------------
468 -- New_Internal_Name --
469 -----------------------
471 function New_Internal_Name
(Id_Char
: Character) return Name_Id
is
473 pragma Assert
(Is_OK_Internal_Letter
(Id_Char
));
474 Name_Buffer
(1) := Id_Char
;
476 Add_Unique_Serial_Number
;
478 end New_Internal_Name
;
480 -----------------------
481 -- New_Occurrence_Of --
482 -----------------------
484 function New_Occurrence_Of
489 Occurrence
: Node_Id
;
492 Occurrence
:= New_Node
(N_Identifier
, Loc
);
493 Set_Chars
(Occurrence
, Chars
(Def_Id
));
494 Set_Entity
(Occurrence
, Def_Id
);
496 if Is_Type
(Def_Id
) then
497 Set_Etype
(Occurrence
, Def_Id
);
499 Set_Etype
(Occurrence
, Etype
(Def_Id
));
503 end New_Occurrence_Of
;
505 ----------------------
506 -- New_Reference_To --
507 ----------------------
509 function New_Reference_To
514 Occurrence
: Node_Id
;
517 Occurrence
:= New_Node
(N_Identifier
, Loc
);
518 Set_Chars
(Occurrence
, Chars
(Def_Id
));
519 Set_Entity
(Occurrence
, Def_Id
);
521 end New_Reference_To
;
523 -----------------------
524 -- New_Suffixed_Name --
525 -----------------------
527 function New_Suffixed_Name
528 (Related_Id
: Name_Id
;
533 Get_Name_String
(Related_Id
);
534 Name_Len
:= Name_Len
+ 1;
535 Name_Buffer
(Name_Len
) := '_';
536 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ Suffix
'Length) := Suffix
;
537 Name_Len
:= Name_Len
+ Suffix
'Length;
539 end New_Suffixed_Name
;
545 function OK_Convert_To
(Typ
: Entity_Id
; Expr
: Node_Id
) return Node_Id
is
550 Make_Type_Conversion
(Sloc
(Expr
),
551 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Sloc
(Expr
)),
552 Expression
=> Relocate_Node
(Expr
));
553 Set_Conversion_OK
(Result
, True);
554 Set_Etype
(Result
, Typ
);
558 --------------------------
559 -- Unchecked_Convert_To --
560 --------------------------
562 function Unchecked_Convert_To
567 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
571 -- If the expression is already of the correct type, then nothing
572 -- to do, except for relocating the node in case this is required.
574 if Present
(Etype
(Expr
))
575 and then (Base_Type
(Etype
(Expr
)) = Typ
576 or else Etype
(Expr
) = Typ
)
578 return Relocate_Node
(Expr
);
580 -- Cases where the inner expression is itself an unchecked conversion
581 -- to the same type, and we can thus eliminate the outer conversion.
583 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
584 and then Entity
(Subtype_Mark
(Expr
)) = Typ
586 Result
:= Relocate_Node
(Expr
);
592 Make_Unchecked_Type_Conversion
(Loc
,
593 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
594 Expression
=> Relocate_Node
(Expr
));
597 Set_Etype
(Result
, Typ
);
599 end Unchecked_Convert_To
;