]>
Commit | Line | Data |
---|---|---|
38cbfe40 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- L I B -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- |
38cbfe40 RK |
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- -- | |
748086b7 | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
38cbfe40 RK |
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 -- | |
748086b7 JJ |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
17 | -- -- | |
18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- | |
19 | -- additional permissions described in the GCC Runtime Library Exception, -- | |
20 | -- version 3.1, as published by the Free Software Foundation. -- | |
21 | -- -- | |
22 | -- You should have received a copy of the GNU General Public License and -- | |
23 | -- a copy of the GCC Runtime Library Exception along with this program; -- | |
24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- | |
25 | -- <http://www.gnu.org/licenses/>. -- | |
38cbfe40 RK |
26 | -- -- |
27 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 28 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
38cbfe40 RK |
29 | -- -- |
30 | ------------------------------------------------------------------------------ | |
31 | ||
32 | pragma Style_Checks (All_Checks); | |
33 | -- Subprogram ordering not enforced in this unit | |
34 | -- (because of some logical groupings). | |
35 | ||
56e94186 AC |
36 | with Atree; use Atree; |
37 | with Csets; use Csets; | |
38 | with Einfo; use Einfo; | |
2a290fec | 39 | with Nlists; use Nlists; |
75e4e36d | 40 | with Opt; use Opt; |
56e94186 AC |
41 | with Output; use Output; |
42 | with Sinfo; use Sinfo; | |
43 | with Sinput; use Sinput; | |
44 | with Stand; use Stand; | |
45 | with Stringt; use Stringt; | |
46 | with Tree_IO; use Tree_IO; | |
47 | with Uname; use Uname; | |
48 | with Widechar; use Widechar; | |
38cbfe40 RK |
49 | |
50 | package body Lib is | |
51 | ||
0da2c8ac | 52 | Switch_Storing_Enabled : Boolean := True; |
7fee6a39 | 53 | -- Controlled by Enable_Switch_Storing/Disable_Switch_Storing |
0da2c8ac | 54 | |
38cbfe40 RK |
55 | ----------------------- |
56 | -- Local Subprograms -- | |
57 | ----------------------- | |
58 | ||
59 | type SEU_Result is ( | |
60 | Yes_Before, -- S1 is in same extended unit as S2 and appears before it | |
61 | Yes_Same, -- S1 is in same extended unit as S2, Slocs are the same | |
62 | Yes_After, -- S1 is in same extended unit as S2, and appears after it | |
63 | No); -- S2 is not in same extended unit as S2 | |
64 | ||
90e491a7 PMR |
65 | function Check_Same_Extended_Unit |
66 | (S1 : Source_Ptr; | |
67 | S2 : Source_Ptr) return SEU_Result; | |
38cbfe40 RK |
68 | -- Used by In_Same_Extended_Unit and Earlier_In_Extended_Unit. Returns |
69 | -- value as described above. | |
70 | ||
68e2ea27 TQ |
71 | function Get_Code_Or_Source_Unit |
72 | (S : Source_Ptr; | |
a5150cb1 AC |
73 | Unwind_Instances : Boolean; |
74 | Unwind_Subunits : Boolean) return Unit_Number_Type; | |
0da343bc AC |
75 | -- Common processing for routines Get_Code_Unit, Get_Source_Unit, and |
76 | -- Get_Top_Level_Code_Unit. Unwind_Instances is True when the unit for the | |
77 | -- top-level instantiation should be returned instead of the unit for the | |
78 | -- template, in the case of an instantiation. Unwind_Subunits is True when | |
79 | -- the corresponding top-level unit should be returned instead of a | |
80 | -- subunit, in the case of a subunit. | |
68e2ea27 | 81 | |
38cbfe40 RK |
82 | -------------------------------------------- |
83 | -- Access Functions for Unit Table Fields -- | |
84 | -------------------------------------------- | |
85 | ||
86 | function Cunit (U : Unit_Number_Type) return Node_Id is | |
87 | begin | |
88 | return Units.Table (U).Cunit; | |
89 | end Cunit; | |
90 | ||
91 | function Cunit_Entity (U : Unit_Number_Type) return Entity_Id is | |
92 | begin | |
93 | return Units.Table (U).Cunit_Entity; | |
94 | end Cunit_Entity; | |
95 | ||
96 | function Dependency_Num (U : Unit_Number_Type) return Nat is | |
97 | begin | |
98 | return Units.Table (U).Dependency_Num; | |
99 | end Dependency_Num; | |
100 | ||
38cbfe40 RK |
101 | function Dynamic_Elab (U : Unit_Number_Type) return Boolean is |
102 | begin | |
103 | return Units.Table (U).Dynamic_Elab; | |
104 | end Dynamic_Elab; | |
105 | ||
106 | function Error_Location (U : Unit_Number_Type) return Source_Ptr is | |
107 | begin | |
108 | return Units.Table (U).Error_Location; | |
109 | end Error_Location; | |
110 | ||
111 | function Expected_Unit (U : Unit_Number_Type) return Unit_Name_Type is | |
112 | begin | |
113 | return Units.Table (U).Expected_Unit; | |
114 | end Expected_Unit; | |
115 | ||
ef2c20e7 | 116 | function Fatal_Error (U : Unit_Number_Type) return Fatal_Type is |
38cbfe40 RK |
117 | begin |
118 | return Units.Table (U).Fatal_Error; | |
119 | end Fatal_Error; | |
120 | ||
121 | function Generate_Code (U : Unit_Number_Type) return Boolean is | |
122 | begin | |
123 | return Units.Table (U).Generate_Code; | |
124 | end Generate_Code; | |
125 | ||
126 | function Has_RACW (U : Unit_Number_Type) return Boolean is | |
127 | begin | |
128 | return Units.Table (U).Has_RACW; | |
129 | end Has_RACW; | |
130 | ||
8ab31c0c AC |
131 | function Is_Predefined_Renaming (U : Unit_Number_Type) return Boolean is |
132 | begin | |
133 | return Units.Table (U).Is_Predefined_Renaming; | |
134 | end Is_Predefined_Renaming; | |
135 | ||
136 | function Is_Internal_Unit (U : Unit_Number_Type) return Boolean is | |
137 | begin | |
138 | return Units.Table (U).Is_Internal_Unit; | |
139 | end Is_Internal_Unit; | |
140 | ||
141 | function Is_Predefined_Unit (U : Unit_Number_Type) return Boolean is | |
142 | begin | |
143 | return Units.Table (U).Is_Predefined_Unit; | |
144 | end Is_Predefined_Unit; | |
145 | ||
38cbfe40 RK |
146 | function Ident_String (U : Unit_Number_Type) return Node_Id is |
147 | begin | |
148 | return Units.Table (U).Ident_String; | |
149 | end Ident_String; | |
150 | ||
151 | function Loading (U : Unit_Number_Type) return Boolean is | |
152 | begin | |
153 | return Units.Table (U).Loading; | |
154 | end Loading; | |
155 | ||
8918fe18 AC |
156 | function Main_CPU (U : Unit_Number_Type) return Int is |
157 | begin | |
158 | return Units.Table (U).Main_CPU; | |
159 | end Main_CPU; | |
160 | ||
38cbfe40 RK |
161 | function Main_Priority (U : Unit_Number_Type) return Int is |
162 | begin | |
163 | return Units.Table (U).Main_Priority; | |
164 | end Main_Priority; | |
165 | ||
2820d220 AC |
166 | function Munit_Index (U : Unit_Number_Type) return Nat is |
167 | begin | |
168 | return Units.Table (U).Munit_Index; | |
169 | end Munit_Index; | |
170 | ||
4887624e | 171 | function No_Elab_Code_All (U : Unit_Number_Type) return Boolean is |
e8cddc3b | 172 | begin |
4887624e AC |
173 | return Units.Table (U).No_Elab_Code_All; |
174 | end No_Elab_Code_All; | |
e8cddc3b | 175 | |
ce4a6e84 RD |
176 | function OA_Setting (U : Unit_Number_Type) return Character is |
177 | begin | |
178 | return Units.Table (U).OA_Setting; | |
179 | end OA_Setting; | |
180 | ||
bad0a3df PMR |
181 | function Primary_Stack_Count (U : Unit_Number_Type) return Int is |
182 | begin | |
183 | return Units.Table (U).Primary_Stack_Count; | |
184 | end Primary_Stack_Count; | |
185 | ||
186 | function Sec_Stack_Count (U : Unit_Number_Type) return Int is | |
187 | begin | |
188 | return Units.Table (U).Sec_Stack_Count; | |
189 | end Sec_Stack_Count; | |
190 | ||
38cbfe40 RK |
191 | function Source_Index (U : Unit_Number_Type) return Source_File_Index is |
192 | begin | |
193 | return Units.Table (U).Source_Index; | |
194 | end Source_Index; | |
195 | ||
196 | function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type is | |
197 | begin | |
198 | return Units.Table (U).Unit_File_Name; | |
199 | end Unit_File_Name; | |
200 | ||
201 | function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type is | |
202 | begin | |
203 | return Units.Table (U).Unit_Name; | |
204 | end Unit_Name; | |
205 | ||
206 | ------------------------------------------ | |
207 | -- Subprograms to Set Unit Table Fields -- | |
208 | ------------------------------------------ | |
209 | ||
210 | procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id) is | |
211 | begin | |
212 | Units.Table (U).Cunit := N; | |
213 | end Set_Cunit; | |
214 | ||
215 | procedure Set_Cunit_Entity (U : Unit_Number_Type; E : Entity_Id) is | |
216 | begin | |
217 | Units.Table (U).Cunit_Entity := E; | |
218 | Set_Is_Compilation_Unit (E); | |
219 | end Set_Cunit_Entity; | |
220 | ||
221 | procedure Set_Dynamic_Elab (U : Unit_Number_Type; B : Boolean := True) is | |
222 | begin | |
223 | Units.Table (U).Dynamic_Elab := B; | |
224 | end Set_Dynamic_Elab; | |
225 | ||
226 | procedure Set_Error_Location (U : Unit_Number_Type; W : Source_Ptr) is | |
227 | begin | |
228 | Units.Table (U).Error_Location := W; | |
229 | end Set_Error_Location; | |
230 | ||
ef2c20e7 | 231 | procedure Set_Fatal_Error (U : Unit_Number_Type; V : Fatal_Type) is |
38cbfe40 | 232 | begin |
ef2c20e7 | 233 | Units.Table (U).Fatal_Error := V; |
38cbfe40 RK |
234 | end Set_Fatal_Error; |
235 | ||
236 | procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True) is | |
237 | begin | |
238 | Units.Table (U).Generate_Code := B; | |
239 | end Set_Generate_Code; | |
240 | ||
241 | procedure Set_Has_RACW (U : Unit_Number_Type; B : Boolean := True) is | |
242 | begin | |
243 | Units.Table (U).Has_RACW := B; | |
244 | end Set_Has_RACW; | |
245 | ||
246 | procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id) is | |
247 | begin | |
248 | Units.Table (U).Ident_String := N; | |
249 | end Set_Ident_String; | |
250 | ||
251 | procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True) is | |
252 | begin | |
253 | Units.Table (U).Loading := B; | |
254 | end Set_Loading; | |
255 | ||
8918fe18 AC |
256 | procedure Set_Main_CPU (U : Unit_Number_Type; P : Int) is |
257 | begin | |
258 | Units.Table (U).Main_CPU := P; | |
259 | end Set_Main_CPU; | |
260 | ||
38cbfe40 RK |
261 | procedure Set_Main_Priority (U : Unit_Number_Type; P : Int) is |
262 | begin | |
263 | Units.Table (U).Main_Priority := P; | |
264 | end Set_Main_Priority; | |
265 | ||
4887624e AC |
266 | procedure Set_No_Elab_Code_All |
267 | (U : Unit_Number_Type; | |
268 | B : Boolean := True) | |
269 | is | |
e8cddc3b | 270 | begin |
4887624e AC |
271 | Units.Table (U).No_Elab_Code_All := B; |
272 | end Set_No_Elab_Code_All; | |
e8cddc3b | 273 | |
ce4a6e84 RD |
274 | procedure Set_OA_Setting (U : Unit_Number_Type; C : Character) is |
275 | begin | |
276 | Units.Table (U).OA_Setting := C; | |
277 | end Set_OA_Setting; | |
278 | ||
38cbfe40 | 279 | procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type) is |
98cbc7e4 EB |
280 | Old_N : constant Unit_Name_Type := Units.Table (U).Unit_Name; |
281 | ||
38cbfe40 | 282 | begin |
98cbc7e4 EB |
283 | -- First unregister the old name, if any |
284 | ||
285 | if Old_N /= No_Unit_Name and then Unit_Names.Get (Old_N) = U then | |
286 | Unit_Names.Set (Old_N, No_Unit); | |
287 | end if; | |
288 | ||
289 | -- Then set the new name | |
290 | ||
38cbfe40 | 291 | Units.Table (U).Unit_Name := N; |
98cbc7e4 EB |
292 | |
293 | -- Finally register the new name | |
294 | ||
295 | if Unit_Names.Get (N) = No_Unit then | |
296 | Unit_Names.Set (N, U); | |
297 | end if; | |
38cbfe40 RK |
298 | end Set_Unit_Name; |
299 | ||
300 | ------------------------------ | |
301 | -- Check_Same_Extended_Unit -- | |
302 | ------------------------------ | |
303 | ||
90e491a7 PMR |
304 | function Check_Same_Extended_Unit |
305 | (S1 : Source_Ptr; | |
306 | S2 : Source_Ptr) return SEU_Result | |
307 | is | |
75e4e36d AC |
308 | Max_Iterations : constant Nat := Maximum_Instantiations * 2; |
309 | -- Limit to prevent a potential infinite loop | |
310 | ||
311 | Counter : Nat := 0; | |
312 | Depth1 : Nat; | |
313 | Depth2 : Nat; | |
314 | Inst1 : Source_Ptr; | |
315 | Inst2 : Source_Ptr; | |
316 | Sind1 : Source_File_Index; | |
317 | Sind2 : Source_File_Index; | |
318 | Sloc1 : Source_Ptr; | |
319 | Sloc2 : Source_Ptr; | |
320 | Unit1 : Node_Id; | |
321 | Unit2 : Node_Id; | |
322 | Unum1 : Unit_Number_Type; | |
323 | Unum2 : Unit_Number_Type; | |
38cbfe40 RK |
324 | |
325 | begin | |
326 | if S1 = No_Location or else S2 = No_Location then | |
327 | return No; | |
328 | ||
329 | elsif S1 = Standard_Location then | |
330 | if S2 = Standard_Location then | |
331 | return Yes_Same; | |
332 | else | |
333 | return No; | |
334 | end if; | |
335 | ||
336 | elsif S2 = Standard_Location then | |
337 | return No; | |
338 | end if; | |
339 | ||
340 | Sloc1 := S1; | |
341 | Sloc2 := S2; | |
66dc8075 AC |
342 | |
343 | Unum1 := Get_Source_Unit (Sloc1); | |
344 | Unum2 := Get_Source_Unit (Sloc2); | |
38cbfe40 RK |
345 | |
346 | loop | |
66dc8075 AC |
347 | -- Step 1: Check whether the two locations are in the same source |
348 | -- file. | |
349 | ||
38cbfe40 RK |
350 | Sind1 := Get_Source_File_Index (Sloc1); |
351 | Sind2 := Get_Source_File_Index (Sloc2); | |
352 | ||
353 | if Sind1 = Sind2 then | |
354 | if Sloc1 < Sloc2 then | |
355 | return Yes_Before; | |
356 | elsif Sloc1 > Sloc2 then | |
357 | return Yes_After; | |
358 | else | |
359 | return Yes_Same; | |
360 | end if; | |
361 | end if; | |
362 | ||
66dc8075 AC |
363 | -- Step 2: Check subunits. If a subunit is instantiated, follow the |
364 | -- instantiation chain rather than the stub chain. | |
38cbfe40 RK |
365 | |
366 | Unit1 := Unit (Cunit (Unum1)); | |
367 | Unit2 := Unit (Cunit (Unum2)); | |
66dc8075 AC |
368 | Inst1 := Instantiation (Sind1); |
369 | Inst2 := Instantiation (Sind2); | |
38cbfe40 RK |
370 | |
371 | if Nkind (Unit1) = N_Subunit | |
372 | and then Present (Corresponding_Stub (Unit1)) | |
66dc8075 | 373 | and then Inst1 = No_Location |
38cbfe40 | 374 | then |
38cbfe40 RK |
375 | if Nkind (Unit2) = N_Subunit |
376 | and then Present (Corresponding_Stub (Unit2)) | |
66dc8075 | 377 | and then Inst2 = No_Location |
38cbfe40 | 378 | then |
66dc8075 AC |
379 | -- Both locations refer to subunits which may have a common |
380 | -- ancestor. If they do, the deeper subunit must have a longer | |
381 | -- unit name. Replace the deeper one with its corresponding | |
382 | -- stub in order to find the nearest ancestor. | |
383 | ||
38cbfe40 RK |
384 | if Length_Of_Name (Unit_Name (Unum1)) < |
385 | Length_Of_Name (Unit_Name (Unum2)) | |
386 | then | |
387 | Sloc2 := Sloc (Corresponding_Stub (Unit2)); | |
388 | Unum2 := Get_Source_Unit (Sloc2); | |
389 | goto Continue; | |
390 | ||
391 | else | |
392 | Sloc1 := Sloc (Corresponding_Stub (Unit1)); | |
393 | Unum1 := Get_Source_Unit (Sloc1); | |
394 | goto Continue; | |
395 | end if; | |
396 | ||
66dc8075 | 397 | -- Sloc1 in subunit, Sloc2 not |
38cbfe40 RK |
398 | |
399 | else | |
400 | Sloc1 := Sloc (Corresponding_Stub (Unit1)); | |
401 | Unum1 := Get_Source_Unit (Sloc1); | |
402 | goto Continue; | |
403 | end if; | |
404 | ||
66dc8075 | 405 | -- Sloc2 in subunit, Sloc1 not |
38cbfe40 RK |
406 | |
407 | elsif Nkind (Unit2) = N_Subunit | |
408 | and then Present (Corresponding_Stub (Unit2)) | |
66dc8075 | 409 | and then Inst2 = No_Location |
38cbfe40 RK |
410 | then |
411 | Sloc2 := Sloc (Corresponding_Stub (Unit2)); | |
412 | Unum2 := Get_Source_Unit (Sloc2); | |
413 | goto Continue; | |
414 | end if; | |
415 | ||
66dc8075 AC |
416 | -- Step 3: Check instances. The two locations may yield a common |
417 | -- ancestor. | |
38cbfe40 RK |
418 | |
419 | if Inst1 /= No_Location then | |
38cbfe40 RK |
420 | if Inst2 /= No_Location then |
421 | ||
66dc8075 AC |
422 | -- Both locations denote instantiations |
423 | ||
38cbfe40 RK |
424 | Depth1 := Instantiation_Depth (Sloc1); |
425 | Depth2 := Instantiation_Depth (Sloc2); | |
426 | ||
427 | if Depth1 < Depth2 then | |
428 | Sloc2 := Inst2; | |
429 | Unum2 := Get_Source_Unit (Sloc2); | |
430 | goto Continue; | |
431 | ||
432 | elsif Depth1 > Depth2 then | |
433 | Sloc1 := Inst1; | |
434 | Unum1 := Get_Source_Unit (Sloc1); | |
435 | goto Continue; | |
436 | ||
437 | else | |
438 | Sloc1 := Inst1; | |
439 | Sloc2 := Inst2; | |
440 | Unum1 := Get_Source_Unit (Sloc1); | |
441 | Unum2 := Get_Source_Unit (Sloc2); | |
442 | goto Continue; | |
443 | end if; | |
444 | ||
66dc8075 | 445 | -- Sloc1 is an instantiation |
38cbfe40 RK |
446 | |
447 | else | |
448 | Sloc1 := Inst1; | |
449 | Unum1 := Get_Source_Unit (Sloc1); | |
450 | goto Continue; | |
451 | end if; | |
452 | ||
66dc8075 | 453 | -- Sloc2 is an instantiation |
38cbfe40 RK |
454 | |
455 | elsif Inst2 /= No_Location then | |
456 | Sloc2 := Inst2; | |
457 | Unum2 := Get_Source_Unit (Sloc2); | |
458 | goto Continue; | |
459 | end if; | |
460 | ||
66dc8075 AC |
461 | -- Step 4: One location in the spec, the other in the corresponding |
462 | -- body of the same unit. The location in the spec is considered | |
463 | -- earlier. | |
38cbfe40 RK |
464 | |
465 | if Nkind (Unit1) = N_Subprogram_Body | |
466 | or else | |
467 | Nkind (Unit1) = N_Package_Body | |
468 | then | |
469 | if Library_Unit (Cunit (Unum1)) = Cunit (Unum2) then | |
470 | return Yes_After; | |
471 | end if; | |
472 | ||
473 | elsif Nkind (Unit2) = N_Subprogram_Body | |
474 | or else | |
475 | Nkind (Unit2) = N_Package_Body | |
476 | then | |
477 | if Library_Unit (Cunit (Unum2)) = Cunit (Unum1) then | |
478 | return Yes_Before; | |
479 | end if; | |
480 | end if; | |
481 | ||
66dc8075 AC |
482 | -- At this point it is certain that the two locations denote two |
483 | -- entirely separate units. | |
38cbfe40 RK |
484 | |
485 | return No; | |
486 | ||
487 | <<Continue>> | |
75e4e36d AC |
488 | Counter := Counter + 1; |
489 | ||
490 | -- Prevent looping forever | |
491 | ||
492 | if Counter > Max_Iterations then | |
90e491a7 | 493 | |
d030f3a4 AC |
494 | -- ??? Not quite right, but return a value to be able to generate |
495 | -- SCIL files and hope for the best. | |
496 | ||
497 | if CodePeer_Mode then | |
498 | return No; | |
499 | else | |
500 | raise Program_Error; | |
501 | end if; | |
75e4e36d | 502 | end if; |
38cbfe40 | 503 | end loop; |
38cbfe40 RK |
504 | end Check_Same_Extended_Unit; |
505 | ||
07fc65c4 GB |
506 | ------------------------------- |
507 | -- Compilation_Switches_Last -- | |
508 | ------------------------------- | |
509 | ||
510 | function Compilation_Switches_Last return Nat is | |
511 | begin | |
512 | return Compilation_Switches.Last; | |
513 | end Compilation_Switches_Last; | |
514 | ||
7fee6a39 BZ |
515 | --------------------------- |
516 | -- Enable_Switch_Storing -- | |
517 | --------------------------- | |
518 | ||
519 | procedure Enable_Switch_Storing is | |
520 | begin | |
521 | Switch_Storing_Enabled := True; | |
522 | end Enable_Switch_Storing; | |
523 | ||
524 | ---------------------------- | |
525 | -- Disable_Switch_Storing -- | |
526 | ---------------------------- | |
527 | ||
0da2c8ac AC |
528 | procedure Disable_Switch_Storing is |
529 | begin | |
530 | Switch_Storing_Enabled := False; | |
531 | end Disable_Switch_Storing; | |
532 | ||
38cbfe40 RK |
533 | ------------------------------ |
534 | -- Earlier_In_Extended_Unit -- | |
535 | ------------------------------ | |
536 | ||
90e491a7 PMR |
537 | function Earlier_In_Extended_Unit |
538 | (S1 : Source_Ptr; | |
539 | S2 : Source_Ptr) return Boolean | |
540 | is | |
38cbfe40 RK |
541 | begin |
542 | return Check_Same_Extended_Unit (S1, S2) = Yes_Before; | |
543 | end Earlier_In_Extended_Unit; | |
544 | ||
90e491a7 PMR |
545 | function Earlier_In_Extended_Unit |
546 | (N1 : Node_Or_Entity_Id; | |
547 | N2 : Node_Or_Entity_Id) return Boolean | |
548 | is | |
549 | begin | |
550 | return Earlier_In_Extended_Unit (Sloc (N1), Sloc (N2)); | |
551 | end Earlier_In_Extended_Unit; | |
552 | ||
56e94186 AC |
553 | ----------------------- |
554 | -- Exact_Source_Name -- | |
555 | ----------------------- | |
556 | ||
557 | function Exact_Source_Name (Loc : Source_Ptr) return String is | |
558 | U : constant Unit_Number_Type := Get_Source_Unit (Loc); | |
559 | Buf : constant Source_Buffer_Ptr := Source_Text (Source_Index (U)); | |
560 | Orig : constant Source_Ptr := Original_Location (Loc); | |
561 | P : Source_Ptr; | |
562 | ||
563 | WC : Char_Code; | |
564 | Err : Boolean; | |
565 | pragma Warnings (Off, WC); | |
566 | pragma Warnings (Off, Err); | |
567 | ||
568 | begin | |
569 | -- Entity is character literal | |
570 | ||
571 | if Buf (Orig) = ''' then | |
572 | return String (Buf (Orig .. Orig + 2)); | |
573 | ||
574 | -- Entity is operator symbol | |
575 | ||
576 | elsif Buf (Orig) = '"' or else Buf (Orig) = '%' then | |
577 | P := Orig; | |
578 | ||
579 | loop | |
580 | P := P + 1; | |
581 | exit when Buf (P) = Buf (Orig); | |
582 | end loop; | |
583 | ||
584 | return String (Buf (Orig .. P)); | |
585 | ||
586 | -- Entity is identifier | |
587 | ||
588 | else | |
589 | P := Orig; | |
590 | ||
591 | loop | |
592 | if Is_Start_Of_Wide_Char (Buf, P) then | |
593 | Scan_Wide (Buf, P, WC, Err); | |
594 | elsif not Identifier_Char (Buf (P)) then | |
595 | exit; | |
596 | else | |
597 | P := P + 1; | |
598 | end if; | |
599 | end loop; | |
600 | ||
601 | -- Write out the identifier by copying the exact source characters | |
602 | -- used in its declaration. Note that this means wide characters will | |
603 | -- be in their original encoded form. | |
604 | ||
605 | return String (Buf (Orig .. P - 1)); | |
606 | end if; | |
607 | end Exact_Source_Name; | |
608 | ||
38cbfe40 RK |
609 | ---------------------------- |
610 | -- Entity_Is_In_Main_Unit -- | |
611 | ---------------------------- | |
612 | ||
613 | function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean is | |
614 | S : Entity_Id; | |
615 | ||
616 | begin | |
617 | S := Scope (E); | |
618 | ||
619 | while S /= Standard_Standard loop | |
620 | if S = Main_Unit_Entity then | |
621 | return True; | |
622 | elsif Ekind (S) = E_Package and then Is_Child_Unit (S) then | |
623 | return False; | |
624 | else | |
625 | S := Scope (S); | |
626 | end if; | |
627 | end loop; | |
628 | ||
629 | return False; | |
630 | end Entity_Is_In_Main_Unit; | |
631 | ||
9410151a TQ |
632 | -------------------------- |
633 | -- Generic_May_Lack_ALI -- | |
634 | -------------------------- | |
635 | ||
8ab31c0c | 636 | function Generic_May_Lack_ALI (Unum : Unit_Number_Type) return Boolean is |
9410151a TQ |
637 | begin |
638 | -- We allow internal generic units to be used without having a | |
639 | -- corresponding ALI files to help bootstrapping with older compilers | |
640 | -- that did not support generating ALIs for such generics. It is safe | |
641 | -- to do so because the only thing the generated code would contain | |
642 | -- is the elaboration boolean, and we are careful to elaborate all | |
643 | -- predefined units first anyway. | |
644 | ||
8ab31c0c | 645 | return Is_Internal_Unit (Unum); |
9410151a | 646 | end Generic_May_Lack_ALI; |
fbf5a39b | 647 | |
68e2ea27 TQ |
648 | ----------------------------- |
649 | -- Get_Code_Or_Source_Unit -- | |
650 | ----------------------------- | |
38cbfe40 | 651 | |
68e2ea27 TQ |
652 | function Get_Code_Or_Source_Unit |
653 | (S : Source_Ptr; | |
a5150cb1 AC |
654 | Unwind_Instances : Boolean; |
655 | Unwind_Subunits : Boolean) return Unit_Number_Type | |
68e2ea27 | 656 | is |
38cbfe40 | 657 | begin |
fbf5a39b AC |
658 | -- Search table unless we have No_Location, which can happen if the |
659 | -- relevant location has not been set yet. Happens for example when | |
660 | -- we obtain Sloc (Cunit (Main_Unit)) before it is set. | |
38cbfe40 | 661 | |
fbf5a39b AC |
662 | if S /= No_Location then |
663 | declare | |
68e2ea27 TQ |
664 | Source_File : Source_File_Index; |
665 | Source_Unit : Unit_Number_Type; | |
a5150cb1 | 666 | Unit_Node : Node_Id; |
fbf5a39b AC |
667 | |
668 | begin | |
68e2ea27 TQ |
669 | Source_File := Get_Source_File_Index (S); |
670 | ||
671 | if Unwind_Instances then | |
cd644ae2 | 672 | while Template (Source_File) > No_Source_File loop |
68e2ea27 TQ |
673 | Source_File := Template (Source_File); |
674 | end loop; | |
675 | end if; | |
676 | ||
677 | Source_Unit := Unit (Source_File); | |
678 | ||
a5150cb1 AC |
679 | if Unwind_Subunits then |
680 | Unit_Node := Unit (Cunit (Source_Unit)); | |
681 | ||
682 | while Nkind (Unit_Node) = N_Subunit | |
683 | and then Present (Corresponding_Stub (Unit_Node)) | |
684 | loop | |
685 | Source_Unit := | |
686 | Get_Code_Or_Source_Unit | |
687 | (Sloc (Corresponding_Stub (Unit_Node)), | |
688 | Unwind_Instances => Unwind_Instances, | |
689 | Unwind_Subunits => Unwind_Subunits); | |
690 | Unit_Node := Unit (Cunit (Source_Unit)); | |
691 | end loop; | |
692 | end if; | |
693 | ||
68e2ea27 TQ |
694 | if Source_Unit /= No_Unit then |
695 | return Source_Unit; | |
696 | end if; | |
fbf5a39b AC |
697 | end; |
698 | end if; | |
699 | ||
68e2ea27 TQ |
700 | -- If S was No_Location, or was not in the table, we must be in the main |
701 | -- source unit (and the value has not been placed in the table yet), | |
702 | -- or in one of the configuration pragma files. | |
38cbfe40 RK |
703 | |
704 | return Main_Unit; | |
68e2ea27 TQ |
705 | end Get_Code_Or_Source_Unit; |
706 | ||
707 | ------------------- | |
708 | -- Get_Code_Unit -- | |
709 | ------------------- | |
710 | ||
711 | function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type is | |
712 | begin | |
0da343bc AC |
713 | return |
714 | Get_Code_Or_Source_Unit | |
715 | (Top_Level_Location (S), | |
716 | Unwind_Instances => False, | |
717 | Unwind_Subunits => False); | |
38cbfe40 RK |
718 | end Get_Code_Unit; |
719 | ||
07fc65c4 | 720 | function Get_Code_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is |
38cbfe40 RK |
721 | begin |
722 | return Get_Code_Unit (Sloc (N)); | |
723 | end Get_Code_Unit; | |
724 | ||
725 | ---------------------------- | |
726 | -- Get_Compilation_Switch -- | |
727 | ---------------------------- | |
728 | ||
729 | function Get_Compilation_Switch (N : Pos) return String_Ptr is | |
730 | begin | |
07fc65c4 | 731 | if N <= Compilation_Switches.Last then |
38cbfe40 | 732 | return Compilation_Switches.Table (N); |
38cbfe40 RK |
733 | else |
734 | return null; | |
735 | end if; | |
736 | end Get_Compilation_Switch; | |
737 | ||
738 | ---------------------------------- | |
739 | -- Get_Cunit_Entity_Unit_Number -- | |
740 | ---------------------------------- | |
741 | ||
742 | function Get_Cunit_Entity_Unit_Number | |
9596236a | 743 | (E : Entity_Id) return Unit_Number_Type |
38cbfe40 RK |
744 | is |
745 | begin | |
746 | for U in Units.First .. Units.Last loop | |
747 | if Cunit_Entity (U) = E then | |
748 | return U; | |
749 | end if; | |
750 | end loop; | |
751 | ||
752 | -- If not in the table, must be the main source unit, and we just | |
753 | -- have not got it put into the table yet. | |
754 | ||
755 | return Main_Unit; | |
756 | end Get_Cunit_Entity_Unit_Number; | |
757 | ||
758 | --------------------------- | |
759 | -- Get_Cunit_Unit_Number -- | |
760 | --------------------------- | |
761 | ||
762 | function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type is | |
763 | begin | |
764 | for U in Units.First .. Units.Last loop | |
765 | if Cunit (U) = N then | |
766 | return U; | |
767 | end if; | |
768 | end loop; | |
769 | ||
f3a67cfc ES |
770 | -- If not in the table, must be a spec created for a main unit that is a |
771 | -- child subprogram body which we have not inserted into the table yet. | |
38cbfe40 | 772 | |
2c011ce1 RD |
773 | if N = Library_Unit (Cunit (Main_Unit)) then |
774 | return Main_Unit; | |
775 | ||
776 | -- If it is anything else, something is seriously wrong, and we really | |
777 | -- don't want to proceed, even if assertions are off, so we explicitly | |
778 | -- raise an exception in this case to terminate compilation. | |
959dd7d8 | 779 | |
f3a67cfc | 780 | else |
2c011ce1 | 781 | raise Program_Error; |
f3a67cfc | 782 | end if; |
38cbfe40 RK |
783 | end Get_Cunit_Unit_Number; |
784 | ||
785 | --------------------- | |
786 | -- Get_Source_Unit -- | |
787 | --------------------- | |
788 | ||
789 | function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type is | |
38cbfe40 | 790 | begin |
0da343bc AC |
791 | return |
792 | Get_Code_Or_Source_Unit | |
90e491a7 PMR |
793 | (S => S, |
794 | Unwind_Instances => True, | |
795 | Unwind_Subunits => False); | |
38cbfe40 RK |
796 | end Get_Source_Unit; |
797 | ||
07fc65c4 | 798 | function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is |
38cbfe40 RK |
799 | begin |
800 | return Get_Source_Unit (Sloc (N)); | |
801 | end Get_Source_Unit; | |
802 | ||
a5150cb1 AC |
803 | ----------------------------- |
804 | -- Get_Top_Level_Code_Unit -- | |
805 | ----------------------------- | |
806 | ||
807 | function Get_Top_Level_Code_Unit (S : Source_Ptr) return Unit_Number_Type is | |
808 | begin | |
0da343bc AC |
809 | return |
810 | Get_Code_Or_Source_Unit | |
811 | (Top_Level_Location (S), | |
812 | Unwind_Instances => False, | |
813 | Unwind_Subunits => True); | |
a5150cb1 AC |
814 | end Get_Top_Level_Code_Unit; |
815 | ||
816 | function Get_Top_Level_Code_Unit | |
817 | (N : Node_Or_Entity_Id) return Unit_Number_Type is | |
818 | begin | |
819 | return Get_Top_Level_Code_Unit (Sloc (N)); | |
820 | end Get_Top_Level_Code_Unit; | |
821 | ||
38cbfe40 RK |
822 | -------------------------------- |
823 | -- In_Extended_Main_Code_Unit -- | |
824 | -------------------------------- | |
825 | ||
07fc65c4 | 826 | function In_Extended_Main_Code_Unit |
9596236a | 827 | (N : Node_Or_Entity_Id) return Boolean |
07fc65c4 | 828 | is |
38cbfe40 RK |
829 | begin |
830 | if Sloc (N) = Standard_Location then | |
3b8056a5 | 831 | return False; |
38cbfe40 RK |
832 | |
833 | elsif Sloc (N) = No_Location then | |
834 | return False; | |
835 | ||
836 | -- Special case Itypes to test the Sloc of the associated node. The | |
837 | -- reason we do this is for possible calls from gigi after -gnatD | |
838 | -- processing is complete in sprint. This processing updates the | |
839 | -- sloc fields of all nodes in the tree, but itypes are not in the | |
840 | -- tree so their slocs do not get updated. | |
841 | ||
842 | elsif Nkind (N) = N_Defining_Identifier | |
843 | and then Is_Itype (N) | |
844 | then | |
845 | return In_Extended_Main_Code_Unit (Associated_Node_For_Itype (N)); | |
846 | ||
fbf5a39b AC |
847 | -- Otherwise see if we are in the main unit |
848 | ||
38cbfe40 RK |
849 | elsif Get_Code_Unit (Sloc (N)) = Get_Code_Unit (Cunit (Main_Unit)) then |
850 | return True; | |
851 | ||
fbf5a39b AC |
852 | -- Node may be in spec (or subunit etc) of main unit |
853 | ||
854 | else | |
90e491a7 | 855 | return In_Same_Extended_Unit (N, Cunit (Main_Unit)); |
38cbfe40 RK |
856 | end if; |
857 | end In_Extended_Main_Code_Unit; | |
858 | ||
9596236a | 859 | function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean is |
fbf5a39b AC |
860 | begin |
861 | if Loc = Standard_Location then | |
3b8056a5 | 862 | return False; |
fbf5a39b AC |
863 | |
864 | elsif Loc = No_Location then | |
865 | return False; | |
866 | ||
867 | -- Otherwise see if we are in the main unit | |
868 | ||
869 | elsif Get_Code_Unit (Loc) = Get_Code_Unit (Cunit (Main_Unit)) then | |
870 | return True; | |
871 | ||
872 | -- Location may be in spec (or subunit etc) of main unit | |
873 | ||
874 | else | |
90e491a7 | 875 | return In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit))); |
fbf5a39b AC |
876 | end if; |
877 | end In_Extended_Main_Code_Unit; | |
878 | ||
38cbfe40 RK |
879 | ---------------------------------- |
880 | -- In_Extended_Main_Source_Unit -- | |
881 | ---------------------------------- | |
882 | ||
07fc65c4 | 883 | function In_Extended_Main_Source_Unit |
9596236a | 884 | (N : Node_Or_Entity_Id) return Boolean |
07fc65c4 | 885 | is |
fbf5a39b AC |
886 | Nloc : constant Source_Ptr := Sloc (N); |
887 | Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit)); | |
888 | ||
38cbfe40 | 889 | begin |
e1d9659d | 890 | -- If parsing, then use the global flag to indicate result |
fbf5a39b | 891 | |
e1d9659d AC |
892 | if Compiler_State = Parsing then |
893 | return Parsing_Main_Extended_Source; | |
38cbfe40 | 894 | |
fbf5a39b AC |
895 | -- Special value cases |
896 | ||
897 | elsif Nloc = Standard_Location then | |
3b8056a5 | 898 | return False; |
fbf5a39b AC |
899 | |
900 | elsif Nloc = No_Location then | |
38cbfe40 RK |
901 | return False; |
902 | ||
903 | -- Special case Itypes to test the Sloc of the associated node. The | |
904 | -- reason we do this is for possible calls from gigi after -gnatD | |
905 | -- processing is complete in sprint. This processing updates the | |
906 | -- sloc fields of all nodes in the tree, but itypes are not in the | |
907 | -- tree so their slocs do not get updated. | |
908 | ||
909 | elsif Nkind (N) = N_Defining_Identifier | |
910 | and then Is_Itype (N) | |
911 | then | |
912 | return In_Extended_Main_Source_Unit (Associated_Node_For_Itype (N)); | |
913 | ||
fbf5a39b AC |
914 | -- Otherwise compare original locations to see if in same unit |
915 | ||
38cbfe40 RK |
916 | else |
917 | return | |
918 | In_Same_Extended_Unit | |
fbf5a39b AC |
919 | (Original_Location (Nloc), Original_Location (Mloc)); |
920 | end if; | |
921 | end In_Extended_Main_Source_Unit; | |
922 | ||
923 | function In_Extended_Main_Source_Unit | |
9596236a | 924 | (Loc : Source_Ptr) return Boolean |
fbf5a39b AC |
925 | is |
926 | Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit)); | |
927 | ||
928 | begin | |
e1d9659d | 929 | -- If parsing, then use the global flag to indicate result |
fbf5a39b | 930 | |
e1d9659d AC |
931 | if Compiler_State = Parsing then |
932 | return Parsing_Main_Extended_Source; | |
fbf5a39b AC |
933 | |
934 | -- Special value cases | |
935 | ||
936 | elsif Loc = Standard_Location then | |
3b8056a5 | 937 | return False; |
fbf5a39b AC |
938 | |
939 | elsif Loc = No_Location then | |
940 | return False; | |
941 | ||
942 | -- Otherwise compare original locations to see if in same unit | |
943 | ||
944 | else | |
945 | return | |
946 | In_Same_Extended_Unit | |
947 | (Original_Location (Loc), Original_Location (Mloc)); | |
38cbfe40 RK |
948 | end if; |
949 | end In_Extended_Main_Source_Unit; | |
950 | ||
be3416c6 AC |
951 | ---------------------- |
952 | -- In_Internal_Unit -- | |
953 | ---------------------- | |
954 | ||
955 | function In_Internal_Unit (N : Node_Or_Entity_Id) return Boolean is | |
956 | begin | |
957 | return In_Internal_Unit (Sloc (N)); | |
958 | end In_Internal_Unit; | |
959 | ||
960 | function In_Internal_Unit (S : Source_Ptr) return Boolean is | |
961 | Unit : constant Unit_Number_Type := Get_Source_Unit (S); | |
be3416c6 | 962 | begin |
8ab31c0c | 963 | return Is_Internal_Unit (Unit); |
be3416c6 AC |
964 | end In_Internal_Unit; |
965 | ||
8ab31c0c AC |
966 | ---------------------------- |
967 | -- In_Predefined_Renaming -- | |
968 | ---------------------------- | |
969 | ||
970 | function In_Predefined_Renaming (N : Node_Or_Entity_Id) return Boolean is | |
971 | begin | |
972 | return In_Predefined_Renaming (Sloc (N)); | |
973 | end In_Predefined_Renaming; | |
974 | ||
975 | function In_Predefined_Renaming (S : Source_Ptr) return Boolean is | |
976 | Unit : constant Unit_Number_Type := Get_Source_Unit (S); | |
977 | begin | |
978 | return Is_Predefined_Renaming (Unit); | |
979 | end In_Predefined_Renaming; | |
980 | ||
9b832db5 RD |
981 | ------------------------ |
982 | -- In_Predefined_Unit -- | |
983 | ------------------------ | |
984 | ||
985 | function In_Predefined_Unit (N : Node_Or_Entity_Id) return Boolean is | |
986 | begin | |
987 | return In_Predefined_Unit (Sloc (N)); | |
988 | end In_Predefined_Unit; | |
989 | ||
990 | function In_Predefined_Unit (S : Source_Ptr) return Boolean is | |
991 | Unit : constant Unit_Number_Type := Get_Source_Unit (S); | |
9b832db5 | 992 | begin |
8ab31c0c | 993 | return Is_Predefined_Unit (Unit); |
9b832db5 RD |
994 | end In_Predefined_Unit; |
995 | ||
38cbfe40 RK |
996 | ----------------------- |
997 | -- In_Same_Code_Unit -- | |
998 | ----------------------- | |
999 | ||
1000 | function In_Same_Code_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is | |
1001 | S1 : constant Source_Ptr := Sloc (N1); | |
1002 | S2 : constant Source_Ptr := Sloc (N2); | |
1003 | ||
1004 | begin | |
1005 | if S1 = No_Location or else S2 = No_Location then | |
1006 | return False; | |
1007 | ||
1008 | elsif S1 = Standard_Location then | |
1009 | return S2 = Standard_Location; | |
1010 | ||
1011 | elsif S2 = Standard_Location then | |
1012 | return False; | |
1013 | end if; | |
1014 | ||
1015 | return Get_Code_Unit (N1) = Get_Code_Unit (N2); | |
1016 | end In_Same_Code_Unit; | |
1017 | ||
1018 | --------------------------- | |
1019 | -- In_Same_Extended_Unit -- | |
1020 | --------------------------- | |
1021 | ||
cc335f43 AC |
1022 | function In_Same_Extended_Unit |
1023 | (N1, N2 : Node_Or_Entity_Id) return Boolean | |
1024 | is | |
1025 | begin | |
1026 | return Check_Same_Extended_Unit (Sloc (N1), Sloc (N2)) /= No; | |
1027 | end In_Same_Extended_Unit; | |
1028 | ||
38cbfe40 RK |
1029 | function In_Same_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is |
1030 | begin | |
1031 | return Check_Same_Extended_Unit (S1, S2) /= No; | |
1032 | end In_Same_Extended_Unit; | |
1033 | ||
1034 | ------------------------- | |
1035 | -- In_Same_Source_Unit -- | |
1036 | ------------------------- | |
1037 | ||
1038 | function In_Same_Source_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is | |
1039 | S1 : constant Source_Ptr := Sloc (N1); | |
1040 | S2 : constant Source_Ptr := Sloc (N2); | |
1041 | ||
1042 | begin | |
1043 | if S1 = No_Location or else S2 = No_Location then | |
1044 | return False; | |
1045 | ||
1046 | elsif S1 = Standard_Location then | |
1047 | return S2 = Standard_Location; | |
1048 | ||
1049 | elsif S2 = Standard_Location then | |
1050 | return False; | |
1051 | end if; | |
1052 | ||
1053 | return Get_Source_Unit (N1) = Get_Source_Unit (N2); | |
1054 | end In_Same_Source_Unit; | |
1055 | ||
bad0a3df PMR |
1056 | ----------------------------------- |
1057 | -- Increment_Primary_Stack_Count -- | |
1058 | ----------------------------------- | |
1059 | ||
1060 | procedure Increment_Primary_Stack_Count (Increment : Int) is | |
1061 | PSC : Int renames Units.Table (Current_Sem_Unit).Primary_Stack_Count; | |
1062 | begin | |
1063 | PSC := PSC + Increment; | |
1064 | end Increment_Primary_Stack_Count; | |
1065 | ||
1066 | ------------------------------- | |
1067 | -- Increment_Sec_Stack_Count -- | |
1068 | ------------------------------- | |
1069 | ||
1070 | procedure Increment_Sec_Stack_Count (Increment : Int) is | |
1071 | SSC : Int renames Units.Table (Current_Sem_Unit).Sec_Stack_Count; | |
1072 | begin | |
1073 | SSC := SSC + Increment; | |
1074 | end Increment_Sec_Stack_Count; | |
1075 | ||
38cbfe40 RK |
1076 | ----------------------------- |
1077 | -- Increment_Serial_Number -- | |
1078 | ----------------------------- | |
1079 | ||
1080 | function Increment_Serial_Number return Nat is | |
1081 | TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number; | |
38cbfe40 RK |
1082 | begin |
1083 | TSN := TSN + 1; | |
1084 | return TSN; | |
1085 | end Increment_Serial_Number; | |
1086 | ||
98cbc7e4 EB |
1087 | ---------------------- |
1088 | -- Init_Unit_Name -- | |
1089 | ---------------------- | |
1090 | ||
1091 | procedure Init_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type) is | |
1092 | begin | |
1093 | Units.Table (U).Unit_Name := N; | |
1094 | Unit_Names.Set (N, U); | |
1095 | end Init_Unit_Name; | |
1096 | ||
38cbfe40 RK |
1097 | ---------------- |
1098 | -- Initialize -- | |
1099 | ---------------- | |
1100 | ||
1101 | procedure Initialize is | |
1102 | begin | |
1103 | Linker_Option_Lines.Init; | |
7eaa7cdf | 1104 | Notes.Init; |
38cbfe40 RK |
1105 | Load_Stack.Init; |
1106 | Units.Init; | |
38cbfe40 RK |
1107 | Compilation_Switches.Init; |
1108 | end Initialize; | |
1109 | ||
1110 | --------------- | |
1111 | -- Is_Loaded -- | |
1112 | --------------- | |
1113 | ||
1114 | function Is_Loaded (Uname : Unit_Name_Type) return Boolean is | |
1115 | begin | |
98cbc7e4 | 1116 | return Unit_Names.Get (Uname) /= No_Unit; |
38cbfe40 RK |
1117 | end Is_Loaded; |
1118 | ||
1119 | --------------- | |
1120 | -- Last_Unit -- | |
1121 | --------------- | |
1122 | ||
1123 | function Last_Unit return Unit_Number_Type is | |
1124 | begin | |
1125 | return Units.Last; | |
1126 | end Last_Unit; | |
1127 | ||
1128 | ---------- | |
1129 | -- List -- | |
1130 | ---------- | |
1131 | ||
1132 | procedure List (File_Names_Only : Boolean := False) is separate; | |
1133 | ||
1134 | ---------- | |
1135 | -- Lock -- | |
1136 | ---------- | |
1137 | ||
1138 | procedure Lock is | |
1139 | begin | |
38cbfe40 | 1140 | Linker_Option_Lines.Release; |
de33eb38 | 1141 | Linker_Option_Lines.Locked := True; |
38cbfe40 | 1142 | Load_Stack.Release; |
de33eb38 | 1143 | Load_Stack.Locked := True; |
38cbfe40 | 1144 | Units.Release; |
de33eb38 | 1145 | Units.Locked := True; |
38cbfe40 RK |
1146 | end Lock; |
1147 | ||
1148 | --------------- | |
1149 | -- Num_Units -- | |
1150 | --------------- | |
1151 | ||
1152 | function Num_Units return Nat is | |
1153 | begin | |
1154 | return Int (Units.Last) - Int (Main_Unit) + 1; | |
1155 | end Num_Units; | |
1156 | ||
6c1e24d3 AC |
1157 | ----------------- |
1158 | -- Remove_Unit -- | |
1159 | ----------------- | |
1160 | ||
1161 | procedure Remove_Unit (U : Unit_Number_Type) is | |
1162 | begin | |
1163 | if U = Units.Last then | |
98cbc7e4 | 1164 | Unit_Names.Set (Unit_Name (U), No_Unit); |
6c1e24d3 AC |
1165 | Units.Decrement_Last; |
1166 | end if; | |
1167 | end Remove_Unit; | |
1168 | ||
38cbfe40 RK |
1169 | ---------------------------------- |
1170 | -- Replace_Linker_Option_String -- | |
1171 | ---------------------------------- | |
1172 | ||
1173 | procedure Replace_Linker_Option_String | |
1174 | (S : String_Id; Match_String : String) | |
1175 | is | |
1176 | begin | |
1177 | if Match_String'Length > 0 then | |
1178 | for J in 1 .. Linker_Option_Lines.Last loop | |
07fc65c4 | 1179 | String_To_Name_Buffer (Linker_Option_Lines.Table (J).Option); |
38cbfe40 RK |
1180 | |
1181 | if Match_String = Name_Buffer (1 .. Match_String'Length) then | |
07fc65c4 | 1182 | Linker_Option_Lines.Table (J).Option := S; |
38cbfe40 RK |
1183 | return; |
1184 | end if; | |
1185 | end loop; | |
1186 | end if; | |
1187 | ||
1188 | Store_Linker_Option_String (S); | |
1189 | end Replace_Linker_Option_String; | |
1190 | ||
1191 | ---------- | |
1192 | -- Sort -- | |
1193 | ---------- | |
1194 | ||
1195 | procedure Sort (Tbl : in out Unit_Ref_Table) is separate; | |
1196 | ||
1197 | ------------------------------ | |
1198 | -- Store_Compilation_Switch -- | |
1199 | ------------------------------ | |
1200 | ||
1201 | procedure Store_Compilation_Switch (Switch : String) is | |
1202 | begin | |
0da2c8ac AC |
1203 | if Switch_Storing_Enabled then |
1204 | Compilation_Switches.Increment_Last; | |
1205 | Compilation_Switches.Table (Compilation_Switches.Last) := | |
1206 | new String'(Switch); | |
fbf5a39b | 1207 | |
0da2c8ac AC |
1208 | -- Fix up --RTS flag which has been transformed by the gcc driver |
1209 | -- into -fRTS | |
fbf5a39b | 1210 | |
0da2c8ac AC |
1211 | if Switch'Last >= Switch'First + 4 |
1212 | and then Switch (Switch'First .. Switch'First + 4) = "-fRTS" | |
1213 | then | |
1214 | Compilation_Switches.Table | |
1215 | (Compilation_Switches.Last) (Switch'First + 1) := '-'; | |
1216 | end if; | |
fbf5a39b | 1217 | end if; |
38cbfe40 RK |
1218 | end Store_Compilation_Switch; |
1219 | ||
1220 | -------------------------------- | |
1221 | -- Store_Linker_Option_String -- | |
1222 | -------------------------------- | |
1223 | ||
1224 | procedure Store_Linker_Option_String (S : String_Id) is | |
1225 | begin | |
7eaa7cdf | 1226 | Linker_Option_Lines.Append ((Option => S, Unit => Current_Sem_Unit)); |
38cbfe40 RK |
1227 | end Store_Linker_Option_String; |
1228 | ||
7eaa7cdf RD |
1229 | ---------------- |
1230 | -- Store_Note -- | |
1231 | ---------------- | |
1232 | ||
1233 | procedure Store_Note (N : Node_Id) is | |
9e5a6ee7 | 1234 | Sfile : constant Source_File_Index := Get_Source_File_Index (Sloc (N)); |
b3f5eef0 | 1235 | |
7eaa7cdf | 1236 | begin |
9e5a6ee7 TQ |
1237 | -- Notes for a generic are emitted when processing the template, never |
1238 | -- in instances. | |
1239 | ||
1240 | if In_Extended_Main_Code_Unit (N) | |
1241 | and then Instance (Sfile) = No_Instance_Id | |
1242 | then | |
1243 | Notes.Append (N); | |
1244 | end if; | |
7eaa7cdf RD |
1245 | end Store_Note; |
1246 | ||
7324bf49 AC |
1247 | ------------------------------- |
1248 | -- Synchronize_Serial_Number -- | |
1249 | ------------------------------- | |
1250 | ||
1251 | procedure Synchronize_Serial_Number is | |
1252 | TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number; | |
1253 | begin | |
1254 | TSN := TSN + 1; | |
1255 | end Synchronize_Serial_Number; | |
1256 | ||
38cbfe40 RK |
1257 | --------------- |
1258 | -- Tree_Read -- | |
1259 | --------------- | |
1260 | ||
1261 | procedure Tree_Read is | |
1262 | N : Nat; | |
1263 | S : String_Ptr; | |
1264 | ||
1265 | begin | |
1266 | Units.Tree_Read; | |
1267 | ||
2491bb7d SR |
1268 | -- Read Compilation_Switches table. First release the memory occupied |
1269 | -- by the previously loaded switches. | |
1270 | ||
1271 | for J in Compilation_Switches.First .. Compilation_Switches.Last loop | |
1272 | Free (Compilation_Switches.Table (J)); | |
1273 | end loop; | |
38cbfe40 RK |
1274 | |
1275 | Tree_Read_Int (N); | |
1276 | Compilation_Switches.Set_Last (N); | |
1277 | ||
1278 | for J in 1 .. N loop | |
1279 | Tree_Read_Str (S); | |
1280 | Compilation_Switches.Table (J) := S; | |
1281 | end loop; | |
1282 | end Tree_Read; | |
1283 | ||
1284 | ---------------- | |
1285 | -- Tree_Write -- | |
1286 | ---------------- | |
1287 | ||
1288 | procedure Tree_Write is | |
1289 | begin | |
1290 | Units.Tree_Write; | |
1291 | ||
1292 | -- Write Compilation_Switches table | |
1293 | ||
1294 | Tree_Write_Int (Compilation_Switches.Last); | |
1295 | ||
1296 | for J in 1 .. Compilation_Switches.Last loop | |
1297 | Tree_Write_Str (Compilation_Switches.Table (J)); | |
1298 | end loop; | |
1299 | end Tree_Write; | |
1300 | ||
98cbc7e4 EB |
1301 | -------------------- |
1302 | -- Unit_Name_Hash -- | |
1303 | -------------------- | |
1304 | ||
1305 | function Unit_Name_Hash (Id : Unit_Name_Type) return Unit_Name_Header_Num is | |
1306 | begin | |
1307 | return Unit_Name_Header_Num (Id mod Unit_Name_Table_Size); | |
1308 | end Unit_Name_Hash; | |
1309 | ||
1c28fe3a RD |
1310 | ------------ |
1311 | -- Unlock -- | |
1312 | ------------ | |
1313 | ||
1314 | procedure Unlock is | |
1315 | begin | |
1316 | Linker_Option_Lines.Locked := False; | |
1317 | Load_Stack.Locked := False; | |
1318 | Units.Locked := False; | |
1319 | end Unlock; | |
1320 | ||
38cbfe40 RK |
1321 | ----------------- |
1322 | -- Version_Get -- | |
1323 | ----------------- | |
1324 | ||
1325 | function Version_Get (U : Unit_Number_Type) return Word_Hex_String is | |
1326 | begin | |
1327 | return Get_Hex_String (Units.Table (U).Version); | |
1328 | end Version_Get; | |
1329 | ||
1330 | ------------------------ | |
1331 | -- Version_Referenced -- | |
1332 | ------------------------ | |
1333 | ||
1334 | procedure Version_Referenced (S : String_Id) is | |
1335 | begin | |
1336 | Version_Ref.Append (S); | |
1337 | end Version_Referenced; | |
1338 | ||
2a290fec AC |
1339 | --------------------- |
1340 | -- Write_Unit_Info -- | |
1341 | --------------------- | |
1342 | ||
1343 | procedure Write_Unit_Info | |
1344 | (Unit_Num : Unit_Number_Type; | |
1345 | Item : Node_Id; | |
1346 | Prefix : String := ""; | |
1347 | Withs : Boolean := False) | |
1348 | is | |
1349 | begin | |
1350 | Write_Str (Prefix); | |
1351 | Write_Unit_Name (Unit_Name (Unit_Num)); | |
1352 | Write_Str (", unit "); | |
1353 | Write_Int (Int (Unit_Num)); | |
1354 | Write_Str (", "); | |
1355 | Write_Int (Int (Item)); | |
1356 | Write_Str ("="); | |
1357 | Write_Str (Node_Kind'Image (Nkind (Item))); | |
1358 | ||
dc67cfea | 1359 | if Is_Rewrite_Substitution (Item) then |
2a290fec AC |
1360 | Write_Str (", orig = "); |
1361 | Write_Int (Int (Original_Node (Item))); | |
1362 | Write_Str ("="); | |
1363 | Write_Str (Node_Kind'Image (Nkind (Original_Node (Item)))); | |
1364 | end if; | |
1365 | ||
1366 | Write_Eol; | |
1367 | ||
1368 | -- Skip the rest if we're not supposed to print the withs | |
1369 | ||
1370 | if not Withs then | |
1371 | return; | |
1372 | end if; | |
1373 | ||
1374 | declare | |
1375 | Context_Item : Node_Id; | |
1376 | ||
1377 | begin | |
1378 | Context_Item := First (Context_Items (Cunit (Unit_Num))); | |
1379 | while Present (Context_Item) | |
1380 | and then (Nkind (Context_Item) /= N_With_Clause | |
1381 | or else Limited_Present (Context_Item)) | |
1382 | loop | |
1383 | Context_Item := Next (Context_Item); | |
1384 | end loop; | |
1385 | ||
1386 | if Present (Context_Item) then | |
1387 | Indent; | |
1388 | Write_Line ("withs:"); | |
1389 | Indent; | |
1390 | ||
1391 | while Present (Context_Item) loop | |
1392 | if Nkind (Context_Item) = N_With_Clause | |
1393 | and then not Limited_Present (Context_Item) | |
1394 | then | |
1395 | pragma Assert (Present (Library_Unit (Context_Item))); | |
1396 | Write_Unit_Name | |
1397 | (Unit_Name | |
1398 | (Get_Cunit_Unit_Number (Library_Unit (Context_Item)))); | |
1399 | ||
1400 | if Implicit_With (Context_Item) then | |
1401 | Write_Str (" -- implicit"); | |
1402 | end if; | |
1403 | ||
1404 | Write_Eol; | |
1405 | end if; | |
1406 | ||
1407 | Context_Item := Next (Context_Item); | |
1408 | end loop; | |
1409 | ||
1410 | Outdent; | |
1411 | Write_Line ("end withs"); | |
1412 | Outdent; | |
1413 | end if; | |
1414 | end; | |
1415 | end Write_Unit_Info; | |
1416 | ||
38cbfe40 | 1417 | end Lib; |