|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- T B U I L D --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
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. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 with Atree; use Atree;
|
|
|
27 with Aspects; use Aspects;
|
|
|
28 with Csets; use Csets;
|
|
|
29 with Einfo; use Einfo;
|
|
|
30 with Elists; use Elists;
|
|
|
31 with Lib; use Lib;
|
|
|
32 with Nlists; use Nlists;
|
|
|
33 with Nmake; use Nmake;
|
|
|
34 with Opt; use Opt;
|
|
|
35 with Restrict; use Restrict;
|
|
|
36 with Rident; use Rident;
|
|
|
37 with Sem_Aux; use Sem_Aux;
|
|
|
38 with Snames; use Snames;
|
|
|
39 with Stand; use Stand;
|
|
|
40 with Stringt; use Stringt;
|
|
|
41 with Urealp; use Urealp;
|
|
|
42
|
|
|
43 package body Tbuild is
|
|
|
44
|
|
|
45 -----------------------
|
|
|
46 -- Local Subprograms --
|
|
|
47 -----------------------
|
|
|
48
|
|
|
49 procedure Add_Unique_Serial_Number;
|
|
|
50 -- Add a unique serialization to the string in the Name_Buffer. This
|
|
|
51 -- consists of a unit specific serial number, and b/s for body/spec.
|
|
|
52
|
|
|
53 ------------------------------
|
|
|
54 -- Add_Unique_Serial_Number --
|
|
|
55 ------------------------------
|
|
|
56
|
|
|
57 Config_Serial_Number : Nat := 0;
|
|
|
58 -- Counter for use in config pragmas, see comment below
|
|
|
59
|
|
|
60 procedure Add_Unique_Serial_Number is
|
|
|
61 begin
|
|
|
62 -- If we are analyzing configuration pragmas, Cunit (Main_Unit) will
|
|
|
63 -- not be set yet. This happens for example when analyzing static
|
|
|
64 -- string expressions in configuration pragmas. For this case, we
|
|
|
65 -- just maintain a local counter, defined above and we do not need
|
|
|
66 -- to add a b or s indication in this case.
|
|
|
67
|
|
|
68 if No (Cunit (Current_Sem_Unit)) then
|
|
|
69 Config_Serial_Number := Config_Serial_Number + 1;
|
|
|
70 Add_Nat_To_Name_Buffer (Config_Serial_Number);
|
|
|
71 return;
|
|
|
72
|
|
|
73 -- Normal case, within a unit
|
|
|
74
|
|
|
75 else
|
|
|
76 declare
|
|
|
77 Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
|
|
|
78
|
|
|
79 begin
|
|
|
80 Add_Nat_To_Name_Buffer (Increment_Serial_Number);
|
|
|
81
|
|
|
82 -- Add either b or s, depending on whether current unit is a spec
|
|
|
83 -- or a body. This is needed because we may generate the same name
|
|
|
84 -- in a spec and a body otherwise.
|
|
|
85
|
|
|
86 Name_Len := Name_Len + 1;
|
|
|
87
|
|
|
88 if Nkind (Unit_Node) = N_Package_Declaration
|
|
|
89 or else Nkind (Unit_Node) = N_Subprogram_Declaration
|
|
|
90 or else Nkind (Unit_Node) in N_Generic_Declaration
|
|
|
91 then
|
|
|
92 Name_Buffer (Name_Len) := 's';
|
|
|
93 else
|
|
|
94 Name_Buffer (Name_Len) := 'b';
|
|
|
95 end if;
|
|
|
96 end;
|
|
|
97 end if;
|
|
|
98 end Add_Unique_Serial_Number;
|
|
|
99
|
|
|
100 ----------------
|
|
|
101 -- Checks_Off --
|
|
|
102 ----------------
|
|
|
103
|
|
|
104 function Checks_Off (N : Node_Id) return Node_Id is
|
|
|
105 begin
|
|
|
106 return
|
|
|
107 Make_Unchecked_Expression (Sloc (N),
|
|
|
108 Expression => N);
|
|
|
109 end Checks_Off;
|
|
|
110
|
|
|
111 ----------------
|
|
|
112 -- Convert_To --
|
|
|
113 ----------------
|
|
|
114
|
|
|
115 function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
|
|
|
116 Result : Node_Id;
|
|
|
117
|
|
|
118 begin
|
|
|
119 if Present (Etype (Expr))
|
|
|
120 and then (Etype (Expr)) = Typ
|
|
|
121 then
|
|
|
122 return Relocate_Node (Expr);
|
|
|
123 else
|
|
|
124 Result :=
|
|
|
125 Make_Type_Conversion (Sloc (Expr),
|
|
|
126 Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
|
|
|
127 Expression => Relocate_Node (Expr));
|
|
|
128
|
|
|
129 Set_Etype (Result, Typ);
|
|
|
130 return Result;
|
|
|
131 end if;
|
|
|
132 end Convert_To;
|
|
|
133
|
|
|
134 ----------------------------
|
|
|
135 -- Convert_To_And_Rewrite --
|
|
|
136 ----------------------------
|
|
|
137
|
|
|
138 procedure Convert_To_And_Rewrite (Typ : Entity_Id; Expr : Node_Id) is
|
|
|
139 begin
|
|
|
140 Rewrite (Expr, Convert_To (Typ, Expr));
|
|
|
141 end Convert_To_And_Rewrite;
|
|
|
142
|
|
|
143 ------------------
|
|
|
144 -- Discard_List --
|
|
|
145 ------------------
|
|
|
146
|
|
|
147 procedure Discard_List (L : List_Id) is
|
|
|
148 pragma Warnings (Off, L);
|
|
|
149 begin
|
|
|
150 null;
|
|
|
151 end Discard_List;
|
|
|
152
|
|
|
153 ------------------
|
|
|
154 -- Discard_Node --
|
|
|
155 ------------------
|
|
|
156
|
|
|
157 procedure Discard_Node (N : Node_Or_Entity_Id) is
|
|
|
158 pragma Warnings (Off, N);
|
|
|
159 begin
|
|
|
160 null;
|
|
|
161 end Discard_Node;
|
|
|
162
|
|
|
163 -------------------------------------------
|
|
|
164 -- Make_Byte_Aligned_Attribute_Reference --
|
|
|
165 -------------------------------------------
|
|
|
166
|
|
|
167 function Make_Byte_Aligned_Attribute_Reference
|
|
|
168 (Sloc : Source_Ptr;
|
|
|
169 Prefix : Node_Id;
|
|
|
170 Attribute_Name : Name_Id)
|
|
|
171 return Node_Id
|
|
|
172 is
|
|
|
173 N : constant Node_Id :=
|
|
|
174 Make_Attribute_Reference (Sloc,
|
|
|
175 Prefix => Prefix,
|
|
|
176 Attribute_Name => Attribute_Name);
|
|
|
177
|
|
|
178 begin
|
|
|
179 pragma Assert (Nam_In (Attribute_Name, Name_Address,
|
|
|
180 Name_Unrestricted_Access));
|
|
|
181 Set_Must_Be_Byte_Aligned (N, True);
|
|
|
182 return N;
|
|
|
183 end Make_Byte_Aligned_Attribute_Reference;
|
|
|
184
|
|
|
185 --------------------
|
|
|
186 -- Make_DT_Access --
|
|
|
187 --------------------
|
|
|
188
|
|
|
189 function Make_DT_Access
|
|
|
190 (Loc : Source_Ptr;
|
|
|
191 Rec : Node_Id;
|
|
|
192 Typ : Entity_Id) return Node_Id
|
|
|
193 is
|
|
|
194 Full_Type : Entity_Id := Typ;
|
|
|
195
|
|
|
196 begin
|
|
|
197 if Is_Private_Type (Typ) then
|
|
|
198 Full_Type := Underlying_Type (Typ);
|
|
|
199 end if;
|
|
|
200
|
|
|
201 return
|
|
|
202 Unchecked_Convert_To (
|
|
|
203 New_Occurrence_Of
|
|
|
204 (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),
|
|
|
205 Make_Selected_Component (Loc,
|
|
|
206 Prefix => New_Copy (Rec),
|
|
|
207 Selector_Name =>
|
|
|
208 New_Occurrence_Of (First_Tag_Component (Full_Type), Loc)));
|
|
|
209 end Make_DT_Access;
|
|
|
210
|
|
|
211 ------------------------
|
|
|
212 -- Make_Float_Literal --
|
|
|
213 ------------------------
|
|
|
214
|
|
|
215 function Make_Float_Literal
|
|
|
216 (Loc : Source_Ptr;
|
|
|
217 Radix : Uint;
|
|
|
218 Significand : Uint;
|
|
|
219 Exponent : Uint) return Node_Id
|
|
|
220 is
|
|
|
221 begin
|
|
|
222 if Radix = 2 and then abs Significand /= 1 then
|
|
|
223 return
|
|
|
224 Make_Float_Literal
|
|
|
225 (Loc, Uint_16,
|
|
|
226 Significand * Radix**(Exponent mod 4),
|
|
|
227 Exponent / 4);
|
|
|
228
|
|
|
229 else
|
|
|
230 declare
|
|
|
231 N : constant Node_Id := New_Node (N_Real_Literal, Loc);
|
|
|
232
|
|
|
233 begin
|
|
|
234 Set_Realval (N,
|
|
|
235 UR_From_Components
|
|
|
236 (Num => abs Significand,
|
|
|
237 Den => -Exponent,
|
|
|
238 Rbase => UI_To_Int (Radix),
|
|
|
239 Negative => Significand < 0));
|
|
|
240 return N;
|
|
|
241 end;
|
|
|
242 end if;
|
|
|
243 end Make_Float_Literal;
|
|
|
244
|
|
|
245 -------------
|
|
|
246 -- Make_Id --
|
|
|
247 -------------
|
|
|
248
|
|
|
249 function Make_Id (Str : Text_Buffer) return Node_Id is
|
|
|
250 begin
|
|
|
251 Name_Len := 0;
|
|
|
252
|
|
|
253 for J in Str'Range loop
|
|
|
254 Name_Len := Name_Len + 1;
|
|
|
255 Name_Buffer (Name_Len) := Fold_Lower (Str (J));
|
|
|
256 end loop;
|
|
|
257
|
|
|
258 return
|
|
|
259 Make_Identifier (System_Location,
|
|
|
260 Chars => Name_Find);
|
|
|
261 end Make_Id;
|
|
|
262
|
|
|
263 -------------------------------------
|
|
|
264 -- Make_Implicit_Exception_Handler --
|
|
|
265 -------------------------------------
|
|
|
266
|
|
|
267 function Make_Implicit_Exception_Handler
|
|
|
268 (Sloc : Source_Ptr;
|
|
|
269 Choice_Parameter : Node_Id := Empty;
|
|
|
270 Exception_Choices : List_Id;
|
|
|
271 Statements : List_Id) return Node_Id
|
|
|
272 is
|
|
|
273 Handler : Node_Id;
|
|
|
274 Loc : Source_Ptr;
|
|
|
275
|
|
|
276 begin
|
|
|
277 -- Set the source location only when debugging the expanded code
|
|
|
278
|
|
|
279 -- When debugging the source code directly, we do not want the compiler
|
|
|
280 -- to associate this implicit exception handler with any specific source
|
|
|
281 -- line, because it can potentially confuse the debugger. The most
|
|
|
282 -- damaging situation would arise when the debugger tries to insert a
|
|
|
283 -- breakpoint at a certain line. If the code of the associated implicit
|
|
|
284 -- exception handler is generated before the code of that line, then the
|
|
|
285 -- debugger will end up inserting the breakpoint inside the exception
|
|
|
286 -- handler, rather than the code the user intended to break on. As a
|
|
|
287 -- result, it is likely that the program will not hit the breakpoint
|
|
|
288 -- as expected.
|
|
|
289
|
|
|
290 if Debug_Generated_Code then
|
|
|
291 Loc := Sloc;
|
|
|
292 else
|
|
|
293 Loc := No_Location;
|
|
|
294 end if;
|
|
|
295
|
|
|
296 Handler :=
|
|
|
297 Make_Exception_Handler
|
|
|
298 (Loc, Choice_Parameter, Exception_Choices, Statements);
|
|
|
299 Set_Local_Raise_Statements (Handler, No_Elist);
|
|
|
300 return Handler;
|
|
|
301 end Make_Implicit_Exception_Handler;
|
|
|
302
|
|
|
303 --------------------------------
|
|
|
304 -- Make_Implicit_If_Statement --
|
|
|
305 --------------------------------
|
|
|
306
|
|
|
307 function Make_Implicit_If_Statement
|
|
|
308 (Node : Node_Id;
|
|
|
309 Condition : Node_Id;
|
|
|
310 Then_Statements : List_Id;
|
|
|
311 Elsif_Parts : List_Id := No_List;
|
|
|
312 Else_Statements : List_Id := No_List) return Node_Id
|
|
|
313 is
|
|
|
314 begin
|
|
|
315 Check_Restriction (No_Implicit_Conditionals, Node);
|
|
|
316
|
|
|
317 return Make_If_Statement (Sloc (Node),
|
|
|
318 Condition,
|
|
|
319 Then_Statements,
|
|
|
320 Elsif_Parts,
|
|
|
321 Else_Statements);
|
|
|
322 end Make_Implicit_If_Statement;
|
|
|
323
|
|
|
324 -------------------------------------
|
|
|
325 -- Make_Implicit_Label_Declaration --
|
|
|
326 -------------------------------------
|
|
|
327
|
|
|
328 function Make_Implicit_Label_Declaration
|
|
|
329 (Loc : Source_Ptr;
|
|
|
330 Defining_Identifier : Node_Id;
|
|
|
331 Label_Construct : Node_Id) return Node_Id
|
|
|
332 is
|
|
|
333 N : constant Node_Id :=
|
|
|
334 Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
|
|
|
335 begin
|
|
|
336 Set_Label_Construct (N, Label_Construct);
|
|
|
337 return N;
|
|
|
338 end Make_Implicit_Label_Declaration;
|
|
|
339
|
|
|
340 ----------------------------------
|
|
|
341 -- Make_Implicit_Loop_Statement --
|
|
|
342 ----------------------------------
|
|
|
343
|
|
|
344 function Make_Implicit_Loop_Statement
|
|
|
345 (Node : Node_Id;
|
|
|
346 Statements : List_Id;
|
|
|
347 Identifier : Node_Id := Empty;
|
|
|
348 Iteration_Scheme : Node_Id := Empty;
|
|
|
349 Has_Created_Identifier : Boolean := False;
|
|
|
350 End_Label : Node_Id := Empty) return Node_Id
|
|
|
351 is
|
|
|
352 begin
|
|
|
353 Check_Restriction (No_Implicit_Loops, Node);
|
|
|
354
|
|
|
355 if Present (Iteration_Scheme)
|
|
|
356 and then Present (Condition (Iteration_Scheme))
|
|
|
357 then
|
|
|
358 Check_Restriction (No_Implicit_Conditionals, Node);
|
|
|
359 end if;
|
|
|
360
|
|
|
361 return Make_Loop_Statement (Sloc (Node),
|
|
|
362 Identifier => Identifier,
|
|
|
363 Iteration_Scheme => Iteration_Scheme,
|
|
|
364 Statements => Statements,
|
|
|
365 Has_Created_Identifier => Has_Created_Identifier,
|
|
|
366 End_Label => End_Label);
|
|
|
367 end Make_Implicit_Loop_Statement;
|
|
|
368
|
|
|
369 --------------------------
|
|
|
370 -- Make_Integer_Literal --
|
|
|
371 ---------------------------
|
|
|
372
|
|
|
373 function Make_Integer_Literal
|
|
|
374 (Loc : Source_Ptr;
|
|
|
375 Intval : Int) return Node_Id
|
|
|
376 is
|
|
|
377 begin
|
|
|
378 return Make_Integer_Literal (Loc, UI_From_Int (Intval));
|
|
|
379 end Make_Integer_Literal;
|
|
|
380
|
|
|
381 --------------------------------
|
|
|
382 -- Make_Linker_Section_Pragma --
|
|
|
383 --------------------------------
|
|
|
384
|
|
|
385 function Make_Linker_Section_Pragma
|
|
|
386 (Ent : Entity_Id;
|
|
|
387 Loc : Source_Ptr;
|
|
|
388 Sec : String) return Node_Id
|
|
|
389 is
|
|
|
390 LS : Node_Id;
|
|
|
391
|
|
|
392 begin
|
|
|
393 LS :=
|
|
|
394 Make_Pragma
|
|
|
395 (Loc,
|
|
|
396 Name_Linker_Section,
|
|
|
397 New_List
|
|
|
398 (Make_Pragma_Argument_Association
|
|
|
399 (Sloc => Loc,
|
|
|
400 Expression => New_Occurrence_Of (Ent, Loc)),
|
|
|
401 Make_Pragma_Argument_Association
|
|
|
402 (Sloc => Loc,
|
|
|
403 Expression =>
|
|
|
404 Make_String_Literal
|
|
|
405 (Sloc => Loc,
|
|
|
406 Strval => Sec))));
|
|
|
407
|
|
|
408 Set_Has_Gigi_Rep_Item (Ent);
|
|
|
409 return LS;
|
|
|
410 end Make_Linker_Section_Pragma;
|
|
|
411
|
|
|
412 -----------------
|
|
|
413 -- Make_Pragma --
|
|
|
414 -----------------
|
|
|
415
|
|
|
416 function Make_Pragma
|
|
|
417 (Sloc : Source_Ptr;
|
|
|
418 Chars : Name_Id;
|
|
|
419 Pragma_Argument_Associations : List_Id := No_List) return Node_Id
|
|
|
420 is
|
|
|
421 begin
|
|
|
422 return
|
|
|
423 Make_Pragma (Sloc,
|
|
|
424 Pragma_Argument_Associations => Pragma_Argument_Associations,
|
|
|
425 Pragma_Identifier => Make_Identifier (Sloc, Chars));
|
|
|
426 end Make_Pragma;
|
|
|
427
|
|
|
428 ---------------------------------
|
|
|
429 -- Make_Raise_Constraint_Error --
|
|
|
430 ---------------------------------
|
|
|
431
|
|
|
432 function Make_Raise_Constraint_Error
|
|
|
433 (Sloc : Source_Ptr;
|
|
|
434 Condition : Node_Id := Empty;
|
|
|
435 Reason : RT_Exception_Code) return Node_Id
|
|
|
436 is
|
|
|
437 begin
|
|
|
438 pragma Assert (Rkind (Reason) = CE_Reason);
|
|
|
439 return
|
|
|
440 Make_Raise_Constraint_Error (Sloc,
|
|
|
441 Condition => Condition,
|
|
|
442 Reason => UI_From_Int (RT_Exception_Code'Pos (Reason)));
|
|
|
443 end Make_Raise_Constraint_Error;
|
|
|
444
|
|
|
445 ------------------------------
|
|
|
446 -- Make_Raise_Program_Error --
|
|
|
447 ------------------------------
|
|
|
448
|
|
|
449 function Make_Raise_Program_Error
|
|
|
450 (Sloc : Source_Ptr;
|
|
|
451 Condition : Node_Id := Empty;
|
|
|
452 Reason : RT_Exception_Code) return Node_Id
|
|
|
453 is
|
|
|
454 begin
|
|
|
455 pragma Assert (Rkind (Reason) = PE_Reason);
|
|
|
456 return
|
|
|
457 Make_Raise_Program_Error (Sloc,
|
|
|
458 Condition => Condition,
|
|
|
459 Reason => UI_From_Int (RT_Exception_Code'Pos (Reason)));
|
|
|
460 end Make_Raise_Program_Error;
|
|
|
461
|
|
|
462 ------------------------------
|
|
|
463 -- Make_Raise_Storage_Error --
|
|
|
464 ------------------------------
|
|
|
465
|
|
|
466 function Make_Raise_Storage_Error
|
|
|
467 (Sloc : Source_Ptr;
|
|
|
468 Condition : Node_Id := Empty;
|
|
|
469 Reason : RT_Exception_Code) return Node_Id
|
|
|
470 is
|
|
|
471 begin
|
|
|
472 pragma Assert (Rkind (Reason) = SE_Reason);
|
|
|
473 return
|
|
|
474 Make_Raise_Storage_Error (Sloc,
|
|
|
475 Condition => Condition,
|
|
|
476 Reason => UI_From_Int (RT_Exception_Code'Pos (Reason)));
|
|
|
477 end Make_Raise_Storage_Error;
|
|
|
478
|
|
|
479 -------------
|
|
|
480 -- Make_SC --
|
|
|
481 -------------
|
|
|
482
|
|
|
483 function Make_SC (Pre, Sel : Node_Id) return Node_Id is
|
|
|
484 begin
|
|
|
485 return
|
|
|
486 Make_Selected_Component (System_Location,
|
|
|
487 Prefix => Pre,
|
|
|
488 Selector_Name => Sel);
|
|
|
489 end Make_SC;
|
|
|
490
|
|
|
491 -------------------------
|
|
|
492 -- Make_String_Literal --
|
|
|
493 -------------------------
|
|
|
494
|
|
|
495 function Make_String_Literal
|
|
|
496 (Sloc : Source_Ptr;
|
|
|
497 Strval : String) return Node_Id
|
|
|
498 is
|
|
|
499 begin
|
|
|
500 Start_String;
|
|
|
501 Store_String_Chars (Strval);
|
|
|
502 return Make_String_Literal (Sloc, Strval => End_String);
|
|
|
503 end Make_String_Literal;
|
|
|
504
|
|
|
505 --------------------
|
|
|
506 -- Make_Temporary --
|
|
|
507 --------------------
|
|
|
508
|
|
|
509 function Make_Temporary
|
|
|
510 (Loc : Source_Ptr;
|
|
|
511 Id : Character;
|
|
|
512 Related_Node : Node_Id := Empty) return Entity_Id
|
|
|
513 is
|
|
|
514 Temp : constant Entity_Id :=
|
|
|
515 Make_Defining_Identifier (Loc, Chars => New_Internal_Name (Id));
|
|
|
516 begin
|
|
|
517 Set_Related_Expression (Temp, Related_Node);
|
|
|
518 return Temp;
|
|
|
519 end Make_Temporary;
|
|
|
520
|
|
|
521 ---------------------------
|
|
|
522 -- Make_Unsuppress_Block --
|
|
|
523 ---------------------------
|
|
|
524
|
|
|
525 -- Generates the following expansion:
|
|
|
526
|
|
|
527 -- declare
|
|
|
528 -- pragma Suppress (<check>);
|
|
|
529 -- begin
|
|
|
530 -- <stmts>
|
|
|
531 -- end;
|
|
|
532
|
|
|
533 function Make_Unsuppress_Block
|
|
|
534 (Loc : Source_Ptr;
|
|
|
535 Check : Name_Id;
|
|
|
536 Stmts : List_Id) return Node_Id
|
|
|
537 is
|
|
|
538 begin
|
|
|
539 return
|
|
|
540 Make_Block_Statement (Loc,
|
|
|
541 Declarations => New_List (
|
|
|
542 Make_Pragma (Loc,
|
|
|
543 Chars => Name_Suppress,
|
|
|
544 Pragma_Argument_Associations => New_List (
|
|
|
545 Make_Pragma_Argument_Association (Loc,
|
|
|
546 Expression => Make_Identifier (Loc, Check))))),
|
|
|
547
|
|
|
548 Handled_Statement_Sequence =>
|
|
|
549 Make_Handled_Sequence_Of_Statements (Loc,
|
|
|
550 Statements => Stmts));
|
|
|
551 end Make_Unsuppress_Block;
|
|
|
552
|
|
|
553 --------------------------
|
|
|
554 -- New_Constraint_Error --
|
|
|
555 --------------------------
|
|
|
556
|
|
|
557 function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
|
|
|
558 Ident_Node : Node_Id;
|
|
|
559 Raise_Node : Node_Id;
|
|
|
560
|
|
|
561 begin
|
|
|
562 Ident_Node := New_Node (N_Identifier, Loc);
|
|
|
563 Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
|
|
|
564 Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
|
|
|
565 Raise_Node := New_Node (N_Raise_Statement, Loc);
|
|
|
566 Set_Name (Raise_Node, Ident_Node);
|
|
|
567 return Raise_Node;
|
|
|
568 end New_Constraint_Error;
|
|
|
569
|
|
|
570 -----------------------
|
|
|
571 -- New_External_Name --
|
|
|
572 -----------------------
|
|
|
573
|
|
|
574 function New_External_Name
|
|
|
575 (Related_Id : Name_Id;
|
|
|
576 Suffix : Character := ' ';
|
|
|
577 Suffix_Index : Int := 0;
|
|
|
578 Prefix : Character := ' ') return Name_Id
|
|
|
579 is
|
|
|
580 begin
|
|
|
581 Get_Name_String (Related_Id);
|
|
|
582
|
|
|
583 if Prefix /= ' ' then
|
|
|
584 pragma Assert (Is_OK_Internal_Letter (Prefix) or else Prefix = '_');
|
|
|
585
|
|
|
586 for J in reverse 1 .. Name_Len loop
|
|
|
587 Name_Buffer (J + 1) := Name_Buffer (J);
|
|
|
588 end loop;
|
|
|
589
|
|
|
590 Name_Len := Name_Len + 1;
|
|
|
591 Name_Buffer (1) := Prefix;
|
|
|
592 end if;
|
|
|
593
|
|
|
594 if Suffix /= ' ' then
|
|
|
595 pragma Assert (Is_OK_Internal_Letter (Suffix));
|
|
|
596 Add_Char_To_Name_Buffer (Suffix);
|
|
|
597 end if;
|
|
|
598
|
|
|
599 if Suffix_Index /= 0 then
|
|
|
600 if Suffix_Index < 0 then
|
|
|
601 Add_Unique_Serial_Number;
|
|
|
602 else
|
|
|
603 Add_Nat_To_Name_Buffer (Suffix_Index);
|
|
|
604 end if;
|
|
|
605 end if;
|
|
|
606
|
|
|
607 return Name_Find;
|
|
|
608 end New_External_Name;
|
|
|
609
|
|
|
610 function New_External_Name
|
|
|
611 (Related_Id : Name_Id;
|
|
|
612 Suffix : String;
|
|
|
613 Suffix_Index : Int := 0;
|
|
|
614 Prefix : Character := ' ') return Name_Id
|
|
|
615 is
|
|
|
616 begin
|
|
|
617 Get_Name_String (Related_Id);
|
|
|
618
|
|
|
619 if Prefix /= ' ' then
|
|
|
620 pragma Assert (Is_OK_Internal_Letter (Prefix));
|
|
|
621
|
|
|
622 for J in reverse 1 .. Name_Len loop
|
|
|
623 Name_Buffer (J + 1) := Name_Buffer (J);
|
|
|
624 end loop;
|
|
|
625
|
|
|
626 Name_Len := Name_Len + 1;
|
|
|
627 Name_Buffer (1) := Prefix;
|
|
|
628 end if;
|
|
|
629
|
|
|
630 if Suffix /= "" then
|
|
|
631 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
|
|
|
632 Name_Len := Name_Len + Suffix'Length;
|
|
|
633 end if;
|
|
|
634
|
|
|
635 if Suffix_Index /= 0 then
|
|
|
636 if Suffix_Index < 0 then
|
|
|
637 Add_Unique_Serial_Number;
|
|
|
638 else
|
|
|
639 Add_Nat_To_Name_Buffer (Suffix_Index);
|
|
|
640 end if;
|
|
|
641 end if;
|
|
|
642
|
|
|
643 return Name_Find;
|
|
|
644 end New_External_Name;
|
|
|
645
|
|
|
646 function New_External_Name
|
|
|
647 (Suffix : Character;
|
|
|
648 Suffix_Index : Nat) return Name_Id
|
|
|
649 is
|
|
|
650 begin
|
|
|
651 Name_Buffer (1) := Suffix;
|
|
|
652 Name_Len := 1;
|
|
|
653 Add_Nat_To_Name_Buffer (Suffix_Index);
|
|
|
654 return Name_Find;
|
|
|
655 end New_External_Name;
|
|
|
656
|
|
|
657 -----------------------
|
|
|
658 -- New_Internal_Name --
|
|
|
659 -----------------------
|
|
|
660
|
|
|
661 function New_Internal_Name (Id_Char : Character) return Name_Id is
|
|
|
662 begin
|
|
|
663 pragma Assert (Is_OK_Internal_Letter (Id_Char));
|
|
|
664 Name_Buffer (1) := Id_Char;
|
|
|
665 Name_Len := 1;
|
|
|
666 Add_Unique_Serial_Number;
|
|
|
667 return Name_Enter;
|
|
|
668 end New_Internal_Name;
|
|
|
669
|
|
|
670 -----------------------
|
|
|
671 -- New_Occurrence_Of --
|
|
|
672 -----------------------
|
|
|
673
|
|
|
674 function New_Occurrence_Of
|
|
|
675 (Def_Id : Entity_Id;
|
|
|
676 Loc : Source_Ptr) return Node_Id
|
|
|
677 is
|
|
|
678 pragma Assert (Present (Def_Id) and then Nkind (Def_Id) in N_Entity);
|
|
|
679 Occurrence : Node_Id;
|
|
|
680
|
|
|
681 begin
|
|
|
682 Occurrence := New_Node (N_Identifier, Loc);
|
|
|
683 Set_Chars (Occurrence, Chars (Def_Id));
|
|
|
684 Set_Entity (Occurrence, Def_Id);
|
|
|
685
|
|
|
686 if Is_Type (Def_Id) then
|
|
|
687 Set_Etype (Occurrence, Def_Id);
|
|
|
688 else
|
|
|
689 Set_Etype (Occurrence, Etype (Def_Id));
|
|
|
690 end if;
|
|
|
691
|
|
|
692 if Ekind (Def_Id) = E_Enumeration_Literal then
|
|
|
693 Set_Is_Static_Expression (Occurrence, True);
|
|
|
694 end if;
|
|
|
695
|
|
|
696 return Occurrence;
|
|
|
697 end New_Occurrence_Of;
|
|
|
698
|
|
|
699 -----------------
|
|
|
700 -- New_Op_Node --
|
|
|
701 -----------------
|
|
|
702
|
|
|
703 function New_Op_Node
|
|
|
704 (New_Node_Kind : Node_Kind;
|
|
|
705 New_Sloc : Source_Ptr) return Node_Id
|
|
|
706 is
|
|
|
707 type Name_Of_Type is array (N_Op) of Name_Id;
|
|
|
708 Name_Of : constant Name_Of_Type := Name_Of_Type'(
|
|
|
709 N_Op_And => Name_Op_And,
|
|
|
710 N_Op_Or => Name_Op_Or,
|
|
|
711 N_Op_Xor => Name_Op_Xor,
|
|
|
712 N_Op_Eq => Name_Op_Eq,
|
|
|
713 N_Op_Ne => Name_Op_Ne,
|
|
|
714 N_Op_Lt => Name_Op_Lt,
|
|
|
715 N_Op_Le => Name_Op_Le,
|
|
|
716 N_Op_Gt => Name_Op_Gt,
|
|
|
717 N_Op_Ge => Name_Op_Ge,
|
|
|
718 N_Op_Add => Name_Op_Add,
|
|
|
719 N_Op_Subtract => Name_Op_Subtract,
|
|
|
720 N_Op_Concat => Name_Op_Concat,
|
|
|
721 N_Op_Multiply => Name_Op_Multiply,
|
|
|
722 N_Op_Divide => Name_Op_Divide,
|
|
|
723 N_Op_Mod => Name_Op_Mod,
|
|
|
724 N_Op_Rem => Name_Op_Rem,
|
|
|
725 N_Op_Expon => Name_Op_Expon,
|
|
|
726 N_Op_Plus => Name_Op_Add,
|
|
|
727 N_Op_Minus => Name_Op_Subtract,
|
|
|
728 N_Op_Abs => Name_Op_Abs,
|
|
|
729 N_Op_Not => Name_Op_Not,
|
|
|
730
|
|
|
731 -- We don't really need these shift operators, since they never
|
|
|
732 -- appear as operators in the source, but the path of least
|
|
|
733 -- resistance is to put them in (the aggregate must be complete).
|
|
|
734
|
|
|
735 N_Op_Rotate_Left => Name_Rotate_Left,
|
|
|
736 N_Op_Rotate_Right => Name_Rotate_Right,
|
|
|
737 N_Op_Shift_Left => Name_Shift_Left,
|
|
|
738 N_Op_Shift_Right => Name_Shift_Right,
|
|
|
739 N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic);
|
|
|
740
|
|
|
741 Nod : constant Node_Id := New_Node (New_Node_Kind, New_Sloc);
|
|
|
742
|
|
|
743 begin
|
|
|
744 if New_Node_Kind in Name_Of'Range then
|
|
|
745 Set_Chars (Nod, Name_Of (New_Node_Kind));
|
|
|
746 end if;
|
|
|
747
|
|
|
748 return Nod;
|
|
|
749 end New_Op_Node;
|
|
|
750
|
|
|
751 -----------------------
|
|
|
752 -- New_Suffixed_Name --
|
|
|
753 -----------------------
|
|
|
754
|
|
|
755 function New_Suffixed_Name
|
|
|
756 (Related_Id : Name_Id;
|
|
|
757 Suffix : String) return Name_Id
|
|
|
758 is
|
|
|
759 begin
|
|
|
760 Get_Name_String (Related_Id);
|
|
|
761 Add_Char_To_Name_Buffer ('_');
|
|
|
762 Add_Str_To_Name_Buffer (Suffix);
|
|
|
763 return Name_Find;
|
|
|
764 end New_Suffixed_Name;
|
|
|
765
|
|
|
766 -------------------
|
|
|
767 -- OK_Convert_To --
|
|
|
768 -------------------
|
|
|
769
|
|
|
770 function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
|
|
|
771 Result : Node_Id;
|
|
|
772 begin
|
|
|
773 Result :=
|
|
|
774 Make_Type_Conversion (Sloc (Expr),
|
|
|
775 Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
|
|
|
776 Expression => Relocate_Node (Expr));
|
|
|
777 Set_Conversion_OK (Result, True);
|
|
|
778 Set_Etype (Result, Typ);
|
|
|
779 return Result;
|
|
|
780 end OK_Convert_To;
|
|
|
781
|
|
|
782 -------------
|
|
|
783 -- Set_NOD --
|
|
|
784 -------------
|
|
|
785
|
|
|
786 procedure Set_NOD (Unit : Node_Id) is
|
|
|
787 begin
|
|
|
788 Set_Restriction_No_Dependence (Unit, Warn => False);
|
|
|
789 end Set_NOD;
|
|
|
790
|
|
|
791 -------------
|
|
|
792 -- Set_NSA --
|
|
|
793 -------------
|
|
|
794
|
|
|
795 procedure Set_NSA (Asp : Name_Id; OK : out Boolean) is
|
|
|
796 Asp_Id : constant Aspect_Id := Get_Aspect_Id (Asp);
|
|
|
797 begin
|
|
|
798 if Asp_Id = No_Aspect then
|
|
|
799 OK := False;
|
|
|
800 else
|
|
|
801 OK := True;
|
|
|
802 Set_Restriction_No_Specification_Of_Aspect (Asp_Id);
|
|
|
803 end if;
|
|
|
804 end Set_NSA;
|
|
|
805
|
|
|
806 -------------
|
|
|
807 -- Set_NUA --
|
|
|
808 -------------
|
|
|
809
|
|
|
810 procedure Set_NUA (Attr : Name_Id; OK : out Boolean) is
|
|
|
811 begin
|
|
|
812 if Is_Attribute_Name (Attr) then
|
|
|
813 OK := True;
|
|
|
814 Set_Restriction_No_Use_Of_Attribute (Get_Attribute_Id (Attr));
|
|
|
815 else
|
|
|
816 OK := False;
|
|
|
817 end if;
|
|
|
818 end Set_NUA;
|
|
|
819
|
|
|
820 -------------
|
|
|
821 -- Set_NUP --
|
|
|
822 -------------
|
|
|
823
|
|
|
824 procedure Set_NUP (Prag : Name_Id; OK : out Boolean) is
|
|
|
825 begin
|
|
|
826 if Is_Pragma_Name (Prag) then
|
|
|
827 OK := True;
|
|
|
828 Set_Restriction_No_Use_Of_Pragma (Get_Pragma_Id (Prag));
|
|
|
829 else
|
|
|
830 OK := False;
|
|
|
831 end if;
|
|
|
832 end Set_NUP;
|
|
|
833
|
|
|
834 --------------------------
|
|
|
835 -- Unchecked_Convert_To --
|
|
|
836 --------------------------
|
|
|
837
|
|
|
838 function Unchecked_Convert_To
|
|
|
839 (Typ : Entity_Id;
|
|
|
840 Expr : Node_Id) return Node_Id
|
|
|
841 is
|
|
|
842 Loc : constant Source_Ptr := Sloc (Expr);
|
|
|
843 Result : Node_Id;
|
|
|
844 Expr_Parent : Node_Id;
|
|
|
845
|
|
|
846 begin
|
|
|
847 -- If the expression is already of the correct type, then nothing
|
|
|
848 -- to do, except for relocating the node in case this is required.
|
|
|
849
|
|
|
850 if Present (Etype (Expr))
|
|
|
851 and then (Base_Type (Etype (Expr)) = Typ
|
|
|
852 or else Etype (Expr) = Typ)
|
|
|
853 then
|
|
|
854 return Relocate_Node (Expr);
|
|
|
855
|
|
|
856 -- Cases where the inner expression is itself an unchecked conversion
|
|
|
857 -- to the same type, and we can thus eliminate the outer conversion.
|
|
|
858
|
|
|
859 elsif Nkind (Expr) = N_Unchecked_Type_Conversion
|
|
|
860 and then Entity (Subtype_Mark (Expr)) = Typ
|
|
|
861 then
|
|
|
862 Result := Relocate_Node (Expr);
|
|
|
863
|
|
|
864 elsif Nkind (Expr) = N_Null
|
|
|
865 and then Is_Access_Type (Typ)
|
|
|
866 then
|
|
|
867 -- No need for a conversion
|
|
|
868
|
|
|
869 Result := Relocate_Node (Expr);
|
|
|
870
|
|
|
871 -- All other cases
|
|
|
872
|
|
|
873 else
|
|
|
874 -- Capture the parent of the expression before relocating it and
|
|
|
875 -- creating the conversion, so the conversion's parent can be set
|
|
|
876 -- to the original parent below.
|
|
|
877
|
|
|
878 Expr_Parent := Parent (Expr);
|
|
|
879
|
|
|
880 Result :=
|
|
|
881 Make_Unchecked_Type_Conversion (Loc,
|
|
|
882 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
|
|
|
883 Expression => Relocate_Node (Expr));
|
|
|
884
|
|
|
885 Set_Parent (Result, Expr_Parent);
|
|
|
886 end if;
|
|
|
887
|
|
|
888 Set_Etype (Result, Typ);
|
|
|
889 return Result;
|
|
|
890 end Unchecked_Convert_To;
|
|
|
891
|
|
|
892 end Tbuild;
|
