]>
Commit | Line | Data |
---|---|---|
38cbfe40 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- L I B -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
fbf5a39b | 9 | -- Copyright (C) 1992-2003 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- -- | |
13 | -- ware Foundation; either version 2, or (at your option) any later ver- -- | |
14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
17 | -- for more details. You should have received a copy of the GNU General -- | |
18 | -- Public License distributed with GNAT; see file COPYING. If not, write -- | |
19 | -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- | |
20 | -- MA 02111-1307, USA. -- | |
21 | -- -- | |
22 | -- As a special exception, if other files instantiate generics from this -- | |
23 | -- unit, or you link this unit with other files to produce an executable, -- | |
24 | -- this unit does not by itself cause the resulting executable to be -- | |
25 | -- covered by the GNU General Public License. This exception does not -- | |
26 | -- however invalidate any other reasons why the executable file might be -- | |
27 | -- covered by the GNU Public License. -- | |
28 | -- -- | |
29 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 30 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
38cbfe40 RK |
31 | -- -- |
32 | ------------------------------------------------------------------------------ | |
33 | ||
34 | pragma Style_Checks (All_Checks); | |
35 | -- Subprogram ordering not enforced in this unit | |
36 | -- (because of some logical groupings). | |
37 | ||
38 | with Atree; use Atree; | |
39 | with Einfo; use Einfo; | |
40 | with Fname; use Fname; | |
41 | with Namet; use Namet; | |
42 | with Namet; use Namet; | |
43 | with Output; use Output; | |
44 | with Sinfo; use Sinfo; | |
45 | with Sinput; use Sinput; | |
46 | with Stand; use Stand; | |
47 | with Stringt; use Stringt; | |
48 | with Tree_IO; use Tree_IO; | |
49 | with Uname; use Uname; | |
50 | ||
51 | package body Lib is | |
52 | ||
53 | ----------------------- | |
54 | -- Local Subprograms -- | |
55 | ----------------------- | |
56 | ||
57 | type SEU_Result is ( | |
58 | Yes_Before, -- S1 is in same extended unit as S2 and appears before it | |
59 | Yes_Same, -- S1 is in same extended unit as S2, Slocs are the same | |
60 | Yes_After, -- S1 is in same extended unit as S2, and appears after it | |
61 | No); -- S2 is not in same extended unit as S2 | |
62 | ||
63 | function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result; | |
64 | -- Used by In_Same_Extended_Unit and Earlier_In_Extended_Unit. Returns | |
65 | -- value as described above. | |
66 | ||
67 | -------------------------------------------- | |
68 | -- Access Functions for Unit Table Fields -- | |
69 | -------------------------------------------- | |
70 | ||
71 | function Cunit (U : Unit_Number_Type) return Node_Id is | |
72 | begin | |
73 | return Units.Table (U).Cunit; | |
74 | end Cunit; | |
75 | ||
76 | function Cunit_Entity (U : Unit_Number_Type) return Entity_Id is | |
77 | begin | |
78 | return Units.Table (U).Cunit_Entity; | |
79 | end Cunit_Entity; | |
80 | ||
81 | function Dependency_Num (U : Unit_Number_Type) return Nat is | |
82 | begin | |
83 | return Units.Table (U).Dependency_Num; | |
84 | end Dependency_Num; | |
85 | ||
86 | function Dependent_Unit (U : Unit_Number_Type) return Boolean is | |
87 | begin | |
88 | return Units.Table (U).Dependent_Unit; | |
89 | end Dependent_Unit; | |
90 | ||
91 | function Dynamic_Elab (U : Unit_Number_Type) return Boolean is | |
92 | begin | |
93 | return Units.Table (U).Dynamic_Elab; | |
94 | end Dynamic_Elab; | |
95 | ||
96 | function Error_Location (U : Unit_Number_Type) return Source_Ptr is | |
97 | begin | |
98 | return Units.Table (U).Error_Location; | |
99 | end Error_Location; | |
100 | ||
101 | function Expected_Unit (U : Unit_Number_Type) return Unit_Name_Type is | |
102 | begin | |
103 | return Units.Table (U).Expected_Unit; | |
104 | end Expected_Unit; | |
105 | ||
106 | function Fatal_Error (U : Unit_Number_Type) return Boolean is | |
107 | begin | |
108 | return Units.Table (U).Fatal_Error; | |
109 | end Fatal_Error; | |
110 | ||
111 | function Generate_Code (U : Unit_Number_Type) return Boolean is | |
112 | begin | |
113 | return Units.Table (U).Generate_Code; | |
114 | end Generate_Code; | |
115 | ||
116 | function Has_RACW (U : Unit_Number_Type) return Boolean is | |
117 | begin | |
118 | return Units.Table (U).Has_RACW; | |
119 | end Has_RACW; | |
120 | ||
121 | function Ident_String (U : Unit_Number_Type) return Node_Id is | |
122 | begin | |
123 | return Units.Table (U).Ident_String; | |
124 | end Ident_String; | |
125 | ||
126 | function Loading (U : Unit_Number_Type) return Boolean is | |
127 | begin | |
128 | return Units.Table (U).Loading; | |
129 | end Loading; | |
130 | ||
131 | function Main_Priority (U : Unit_Number_Type) return Int is | |
132 | begin | |
133 | return Units.Table (U).Main_Priority; | |
134 | end Main_Priority; | |
135 | ||
136 | function Source_Index (U : Unit_Number_Type) return Source_File_Index is | |
137 | begin | |
138 | return Units.Table (U).Source_Index; | |
139 | end Source_Index; | |
140 | ||
141 | function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type is | |
142 | begin | |
143 | return Units.Table (U).Unit_File_Name; | |
144 | end Unit_File_Name; | |
145 | ||
146 | function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type is | |
147 | begin | |
148 | return Units.Table (U).Unit_Name; | |
149 | end Unit_Name; | |
150 | ||
151 | ------------------------------------------ | |
152 | -- Subprograms to Set Unit Table Fields -- | |
153 | ------------------------------------------ | |
154 | ||
155 | procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id) is | |
156 | begin | |
157 | Units.Table (U).Cunit := N; | |
158 | end Set_Cunit; | |
159 | ||
160 | procedure Set_Cunit_Entity (U : Unit_Number_Type; E : Entity_Id) is | |
161 | begin | |
162 | Units.Table (U).Cunit_Entity := E; | |
163 | Set_Is_Compilation_Unit (E); | |
164 | end Set_Cunit_Entity; | |
165 | ||
166 | procedure Set_Dynamic_Elab (U : Unit_Number_Type; B : Boolean := True) is | |
167 | begin | |
168 | Units.Table (U).Dynamic_Elab := B; | |
169 | end Set_Dynamic_Elab; | |
170 | ||
171 | procedure Set_Error_Location (U : Unit_Number_Type; W : Source_Ptr) is | |
172 | begin | |
173 | Units.Table (U).Error_Location := W; | |
174 | end Set_Error_Location; | |
175 | ||
176 | procedure Set_Fatal_Error (U : Unit_Number_Type; B : Boolean := True) is | |
177 | begin | |
07fc65c4 | 178 | Units.Table (U).Fatal_Error := B; |
38cbfe40 RK |
179 | end Set_Fatal_Error; |
180 | ||
181 | procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True) is | |
182 | begin | |
183 | Units.Table (U).Generate_Code := B; | |
184 | end Set_Generate_Code; | |
185 | ||
186 | procedure Set_Has_RACW (U : Unit_Number_Type; B : Boolean := True) is | |
187 | begin | |
188 | Units.Table (U).Has_RACW := B; | |
189 | end Set_Has_RACW; | |
190 | ||
191 | procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id) is | |
192 | begin | |
193 | Units.Table (U).Ident_String := N; | |
194 | end Set_Ident_String; | |
195 | ||
196 | procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True) is | |
197 | begin | |
198 | Units.Table (U).Loading := B; | |
199 | end Set_Loading; | |
200 | ||
201 | procedure Set_Main_Priority (U : Unit_Number_Type; P : Int) is | |
202 | begin | |
203 | Units.Table (U).Main_Priority := P; | |
204 | end Set_Main_Priority; | |
205 | ||
206 | procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type) is | |
207 | begin | |
208 | Units.Table (U).Unit_Name := N; | |
209 | end Set_Unit_Name; | |
210 | ||
211 | ------------------------------ | |
212 | -- Check_Same_Extended_Unit -- | |
213 | ------------------------------ | |
214 | ||
215 | function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result is | |
216 | Sloc1 : Source_Ptr; | |
217 | Sloc2 : Source_Ptr; | |
218 | Sind1 : Source_File_Index; | |
219 | Sind2 : Source_File_Index; | |
220 | Inst1 : Source_Ptr; | |
221 | Inst2 : Source_Ptr; | |
222 | Unum1 : Unit_Number_Type; | |
223 | Unum2 : Unit_Number_Type; | |
224 | Unit1 : Node_Id; | |
225 | Unit2 : Node_Id; | |
226 | Depth1 : Nat; | |
227 | Depth2 : Nat; | |
228 | ||
229 | begin | |
230 | if S1 = No_Location or else S2 = No_Location then | |
231 | return No; | |
232 | ||
233 | elsif S1 = Standard_Location then | |
234 | if S2 = Standard_Location then | |
235 | return Yes_Same; | |
236 | else | |
237 | return No; | |
238 | end if; | |
239 | ||
240 | elsif S2 = Standard_Location then | |
241 | return No; | |
242 | end if; | |
243 | ||
244 | Sloc1 := S1; | |
245 | Sloc2 := S2; | |
246 | Unum1 := Get_Code_Unit (Sloc1); | |
247 | Unum2 := Get_Code_Unit (Sloc2); | |
248 | ||
249 | loop | |
250 | Sind1 := Get_Source_File_Index (Sloc1); | |
251 | Sind2 := Get_Source_File_Index (Sloc2); | |
252 | ||
253 | if Sind1 = Sind2 then | |
254 | if Sloc1 < Sloc2 then | |
255 | return Yes_Before; | |
256 | elsif Sloc1 > Sloc2 then | |
257 | return Yes_After; | |
258 | else | |
259 | return Yes_Same; | |
260 | end if; | |
261 | end if; | |
262 | ||
263 | -- OK, the two nodes are in separate source elements, but this is not | |
264 | -- decisive, because of the issue of subunits and instantiations. | |
265 | ||
266 | -- First we deal with subunits, since if the subunit is in an | |
267 | -- instantiation, we know that the parent is in the corresponding | |
268 | -- instantiation, since that is the only way we can have a subunit | |
269 | -- that is part of an instantiation. | |
270 | ||
271 | Unit1 := Unit (Cunit (Unum1)); | |
272 | Unit2 := Unit (Cunit (Unum2)); | |
273 | ||
274 | if Nkind (Unit1) = N_Subunit | |
275 | and then Present (Corresponding_Stub (Unit1)) | |
276 | then | |
277 | -- Both in subunits. They could have a common ancestor. If they | |
278 | -- do, then the deeper one must have a longer unit name. Replace | |
279 | -- the deeper one with its corresponding stub, in order to find | |
280 | -- nearest common ancestor, if any. | |
281 | ||
282 | if Nkind (Unit2) = N_Subunit | |
283 | and then Present (Corresponding_Stub (Unit2)) | |
284 | then | |
285 | if Length_Of_Name (Unit_Name (Unum1)) < | |
286 | Length_Of_Name (Unit_Name (Unum2)) | |
287 | then | |
288 | Sloc2 := Sloc (Corresponding_Stub (Unit2)); | |
289 | Unum2 := Get_Source_Unit (Sloc2); | |
290 | goto Continue; | |
291 | ||
292 | else | |
293 | Sloc1 := Sloc (Corresponding_Stub (Unit1)); | |
294 | Unum1 := Get_Source_Unit (Sloc1); | |
295 | goto Continue; | |
296 | end if; | |
297 | ||
298 | -- Nod1 in subunit, Nod2 not | |
299 | ||
300 | else | |
301 | Sloc1 := Sloc (Corresponding_Stub (Unit1)); | |
302 | Unum1 := Get_Source_Unit (Sloc1); | |
303 | goto Continue; | |
304 | end if; | |
305 | ||
306 | -- Nod2 in subunit, Nod1 not | |
307 | ||
308 | elsif Nkind (Unit2) = N_Subunit | |
309 | and then Present (Corresponding_Stub (Unit2)) | |
310 | then | |
311 | Sloc2 := Sloc (Corresponding_Stub (Unit2)); | |
312 | Unum2 := Get_Source_Unit (Sloc2); | |
313 | goto Continue; | |
314 | end if; | |
315 | ||
316 | -- At this stage we know that neither is a subunit, so we deal | |
317 | -- with instantiations, since we culd have a common ancestor | |
318 | ||
319 | Inst1 := Instantiation (Sind1); | |
320 | Inst2 := Instantiation (Sind2); | |
321 | ||
322 | if Inst1 /= No_Location then | |
323 | ||
324 | -- Both are instantiations | |
325 | ||
326 | if Inst2 /= No_Location then | |
327 | ||
328 | Depth1 := Instantiation_Depth (Sloc1); | |
329 | Depth2 := Instantiation_Depth (Sloc2); | |
330 | ||
331 | if Depth1 < Depth2 then | |
332 | Sloc2 := Inst2; | |
333 | Unum2 := Get_Source_Unit (Sloc2); | |
334 | goto Continue; | |
335 | ||
336 | elsif Depth1 > Depth2 then | |
337 | Sloc1 := Inst1; | |
338 | Unum1 := Get_Source_Unit (Sloc1); | |
339 | goto Continue; | |
340 | ||
341 | else | |
342 | Sloc1 := Inst1; | |
343 | Sloc2 := Inst2; | |
344 | Unum1 := Get_Source_Unit (Sloc1); | |
345 | Unum2 := Get_Source_Unit (Sloc2); | |
346 | goto Continue; | |
347 | end if; | |
348 | ||
349 | -- Only first node is in instantiation | |
350 | ||
351 | else | |
352 | Sloc1 := Inst1; | |
353 | Unum1 := Get_Source_Unit (Sloc1); | |
354 | goto Continue; | |
355 | end if; | |
356 | ||
357 | -- Only second node is instantiation | |
358 | ||
359 | elsif Inst2 /= No_Location then | |
360 | Sloc2 := Inst2; | |
361 | Unum2 := Get_Source_Unit (Sloc2); | |
362 | goto Continue; | |
363 | end if; | |
364 | ||
365 | -- No instantiations involved, so we are not in the same unit | |
366 | -- However, there is one case still to check, namely the case | |
367 | -- where one location is in the spec, and the other in the | |
368 | -- corresponding body (the spec location is earlier). | |
369 | ||
370 | if Nkind (Unit1) = N_Subprogram_Body | |
371 | or else | |
372 | Nkind (Unit1) = N_Package_Body | |
373 | then | |
374 | if Library_Unit (Cunit (Unum1)) = Cunit (Unum2) then | |
375 | return Yes_After; | |
376 | end if; | |
377 | ||
378 | elsif Nkind (Unit2) = N_Subprogram_Body | |
379 | or else | |
380 | Nkind (Unit2) = N_Package_Body | |
381 | then | |
382 | if Library_Unit (Cunit (Unum2)) = Cunit (Unum1) then | |
383 | return Yes_Before; | |
384 | end if; | |
385 | end if; | |
386 | ||
387 | -- If that special case does not occur, then we are certain that | |
388 | -- the two locations are really in separate units. | |
389 | ||
390 | return No; | |
391 | ||
392 | <<Continue>> | |
393 | null; | |
394 | end loop; | |
38cbfe40 RK |
395 | end Check_Same_Extended_Unit; |
396 | ||
07fc65c4 GB |
397 | ------------------------------- |
398 | -- Compilation_Switches_Last -- | |
399 | ------------------------------- | |
400 | ||
401 | function Compilation_Switches_Last return Nat is | |
402 | begin | |
403 | return Compilation_Switches.Last; | |
404 | end Compilation_Switches_Last; | |
405 | ||
38cbfe40 RK |
406 | ------------------------------ |
407 | -- Earlier_In_Extended_Unit -- | |
408 | ------------------------------ | |
409 | ||
410 | function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is | |
411 | begin | |
412 | return Check_Same_Extended_Unit (S1, S2) = Yes_Before; | |
413 | end Earlier_In_Extended_Unit; | |
414 | ||
415 | ---------------------------- | |
416 | -- Entity_Is_In_Main_Unit -- | |
417 | ---------------------------- | |
418 | ||
419 | function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean is | |
420 | S : Entity_Id; | |
421 | ||
422 | begin | |
423 | S := Scope (E); | |
424 | ||
425 | while S /= Standard_Standard loop | |
426 | if S = Main_Unit_Entity then | |
427 | return True; | |
428 | elsif Ekind (S) = E_Package and then Is_Child_Unit (S) then | |
429 | return False; | |
430 | else | |
431 | S := Scope (S); | |
432 | end if; | |
433 | end loop; | |
434 | ||
435 | return False; | |
436 | end Entity_Is_In_Main_Unit; | |
437 | ||
438 | --------------------------------- | |
439 | -- Generic_Separately_Compiled -- | |
440 | --------------------------------- | |
441 | ||
442 | function Generic_Separately_Compiled (E : Entity_Id) return Boolean is | |
443 | begin | |
444 | -- We do not generate object files for internal generics, because | |
445 | -- the only thing they would contain is the elaboration boolean, and | |
446 | -- we are careful to elaborate all predefined units first anyway, so | |
447 | -- this boolean is not needed. | |
448 | ||
449 | if Is_Internal_File_Name | |
450 | (Fname => Unit_File_Name (Get_Source_Unit (E)), | |
451 | Renamings_Included => True) | |
452 | then | |
453 | return False; | |
454 | ||
455 | -- All other generic units do generate object files | |
456 | ||
457 | else | |
458 | return True; | |
459 | end if; | |
460 | end Generic_Separately_Compiled; | |
461 | ||
fbf5a39b AC |
462 | function Generic_Separately_Compiled |
463 | (Sfile : File_Name_Type) | |
464 | return Boolean | |
465 | is | |
466 | begin | |
467 | -- Exactly the same as previous function, but works directly on a file | |
468 | -- name. | |
469 | ||
470 | if Is_Internal_File_Name | |
471 | (Fname => Sfile, | |
472 | Renamings_Included => True) | |
473 | then | |
474 | return False; | |
475 | ||
476 | -- All other generic units do generate object files | |
477 | ||
478 | else | |
479 | return True; | |
480 | end if; | |
481 | end Generic_Separately_Compiled; | |
482 | ||
38cbfe40 RK |
483 | ------------------- |
484 | -- Get_Code_Unit -- | |
485 | ------------------- | |
486 | ||
487 | function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type is | |
38cbfe40 | 488 | begin |
fbf5a39b AC |
489 | -- Search table unless we have No_Location, which can happen if the |
490 | -- relevant location has not been set yet. Happens for example when | |
491 | -- we obtain Sloc (Cunit (Main_Unit)) before it is set. | |
38cbfe40 | 492 | |
fbf5a39b AC |
493 | if S /= No_Location then |
494 | declare | |
495 | Source_File : constant Source_File_Index := | |
496 | Get_Source_File_Index (Top_Level_Location (S)); | |
497 | ||
498 | begin | |
499 | for U in Units.First .. Units.Last loop | |
500 | if Source_Index (U) = Source_File then | |
501 | return U; | |
502 | end if; | |
503 | end loop; | |
504 | end; | |
505 | end if; | |
506 | ||
507 | -- If S was No_Location, or was not in the table, we must be in the | |
508 | -- main source unit (and the value has not been placed in the table yet) | |
38cbfe40 RK |
509 | |
510 | return Main_Unit; | |
511 | end Get_Code_Unit; | |
512 | ||
07fc65c4 | 513 | function Get_Code_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is |
38cbfe40 RK |
514 | begin |
515 | return Get_Code_Unit (Sloc (N)); | |
516 | end Get_Code_Unit; | |
517 | ||
518 | ---------------------------- | |
519 | -- Get_Compilation_Switch -- | |
520 | ---------------------------- | |
521 | ||
522 | function Get_Compilation_Switch (N : Pos) return String_Ptr is | |
523 | begin | |
07fc65c4 | 524 | if N <= Compilation_Switches.Last then |
38cbfe40 RK |
525 | return Compilation_Switches.Table (N); |
526 | ||
527 | else | |
528 | return null; | |
529 | end if; | |
530 | end Get_Compilation_Switch; | |
531 | ||
532 | ---------------------------------- | |
533 | -- Get_Cunit_Entity_Unit_Number -- | |
534 | ---------------------------------- | |
535 | ||
536 | function Get_Cunit_Entity_Unit_Number | |
537 | (E : Entity_Id) | |
538 | return Unit_Number_Type | |
539 | is | |
540 | begin | |
541 | for U in Units.First .. Units.Last loop | |
542 | if Cunit_Entity (U) = E then | |
543 | return U; | |
544 | end if; | |
545 | end loop; | |
546 | ||
547 | -- If not in the table, must be the main source unit, and we just | |
548 | -- have not got it put into the table yet. | |
549 | ||
550 | return Main_Unit; | |
551 | end Get_Cunit_Entity_Unit_Number; | |
552 | ||
553 | --------------------------- | |
554 | -- Get_Cunit_Unit_Number -- | |
555 | --------------------------- | |
556 | ||
557 | function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type is | |
558 | begin | |
559 | for U in Units.First .. Units.Last loop | |
560 | if Cunit (U) = N then | |
561 | return U; | |
562 | end if; | |
563 | end loop; | |
564 | ||
565 | -- If not in the table, must be the main source unit, and we just | |
566 | -- have not got it put into the table yet. | |
567 | ||
568 | return Main_Unit; | |
569 | end Get_Cunit_Unit_Number; | |
570 | ||
571 | --------------------- | |
572 | -- Get_Source_Unit -- | |
573 | --------------------- | |
574 | ||
575 | function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type is | |
38cbfe40 | 576 | begin |
fbf5a39b AC |
577 | -- Search table unless we have No_Location, which can happen if the |
578 | -- relevant location has not been set yet. Happens for example when | |
579 | -- we obtain Sloc (Cunit (Main_Unit)) before it is set. | |
38cbfe40 | 580 | |
fbf5a39b AC |
581 | if S /= No_Location then |
582 | declare | |
583 | Source_File : Source_File_Index := | |
584 | Get_Source_File_Index (Top_Level_Location (S)); | |
38cbfe40 | 585 | |
fbf5a39b AC |
586 | begin |
587 | Source_File := Get_Source_File_Index (S); | |
588 | while Template (Source_File) /= No_Source_File loop | |
589 | Source_File := Template (Source_File); | |
590 | end loop; | |
591 | ||
592 | for U in Units.First .. Units.Last loop | |
593 | if Source_Index (U) = Source_File then | |
594 | return U; | |
595 | end if; | |
596 | end loop; | |
597 | end; | |
598 | end if; | |
599 | ||
600 | -- If S was No_Location, or was not in the table, we must be in the | |
601 | -- main source unit (and the value is not got put into the table yet) | |
38cbfe40 RK |
602 | |
603 | return Main_Unit; | |
604 | end Get_Source_Unit; | |
605 | ||
07fc65c4 | 606 | function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is |
38cbfe40 RK |
607 | begin |
608 | return Get_Source_Unit (Sloc (N)); | |
609 | end Get_Source_Unit; | |
610 | ||
611 | -------------------------------- | |
612 | -- In_Extended_Main_Code_Unit -- | |
613 | -------------------------------- | |
614 | ||
07fc65c4 GB |
615 | function In_Extended_Main_Code_Unit |
616 | (N : Node_Or_Entity_Id) | |
617 | return Boolean | |
618 | is | |
38cbfe40 RK |
619 | begin |
620 | if Sloc (N) = Standard_Location then | |
621 | return True; | |
622 | ||
623 | elsif Sloc (N) = No_Location then | |
624 | return False; | |
625 | ||
626 | -- Special case Itypes to test the Sloc of the associated node. The | |
627 | -- reason we do this is for possible calls from gigi after -gnatD | |
628 | -- processing is complete in sprint. This processing updates the | |
629 | -- sloc fields of all nodes in the tree, but itypes are not in the | |
630 | -- tree so their slocs do not get updated. | |
631 | ||
632 | elsif Nkind (N) = N_Defining_Identifier | |
633 | and then Is_Itype (N) | |
634 | then | |
635 | return In_Extended_Main_Code_Unit (Associated_Node_For_Itype (N)); | |
636 | ||
fbf5a39b AC |
637 | -- Otherwise see if we are in the main unit |
638 | ||
38cbfe40 RK |
639 | elsif Get_Code_Unit (Sloc (N)) = Get_Code_Unit (Cunit (Main_Unit)) then |
640 | return True; | |
641 | ||
fbf5a39b AC |
642 | -- Node may be in spec (or subunit etc) of main unit |
643 | ||
644 | else | |
38cbfe40 RK |
645 | return |
646 | In_Same_Extended_Unit (Sloc (N), Sloc (Cunit (Main_Unit))); | |
647 | end if; | |
648 | end In_Extended_Main_Code_Unit; | |
649 | ||
fbf5a39b AC |
650 | function In_Extended_Main_Code_Unit |
651 | (Loc : Source_Ptr) | |
652 | return Boolean | |
653 | is | |
654 | begin | |
655 | if Loc = Standard_Location then | |
656 | return True; | |
657 | ||
658 | elsif Loc = No_Location then | |
659 | return False; | |
660 | ||
661 | -- Otherwise see if we are in the main unit | |
662 | ||
663 | elsif Get_Code_Unit (Loc) = Get_Code_Unit (Cunit (Main_Unit)) then | |
664 | return True; | |
665 | ||
666 | -- Location may be in spec (or subunit etc) of main unit | |
667 | ||
668 | else | |
669 | return | |
670 | In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit))); | |
671 | end if; | |
672 | end In_Extended_Main_Code_Unit; | |
673 | ||
38cbfe40 RK |
674 | ---------------------------------- |
675 | -- In_Extended_Main_Source_Unit -- | |
676 | ---------------------------------- | |
677 | ||
07fc65c4 GB |
678 | function In_Extended_Main_Source_Unit |
679 | (N : Node_Or_Entity_Id) | |
680 | return Boolean | |
681 | is | |
fbf5a39b AC |
682 | Nloc : constant Source_Ptr := Sloc (N); |
683 | Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit)); | |
684 | ||
38cbfe40 | 685 | begin |
fbf5a39b AC |
686 | -- If Mloc is not set, it means we are still parsing the main unit, |
687 | -- so everything so far is in the extended main source unit. | |
688 | ||
689 | if Mloc = No_Location then | |
38cbfe40 RK |
690 | return True; |
691 | ||
fbf5a39b AC |
692 | -- Special value cases |
693 | ||
694 | elsif Nloc = Standard_Location then | |
695 | return True; | |
696 | ||
697 | elsif Nloc = No_Location then | |
38cbfe40 RK |
698 | return False; |
699 | ||
700 | -- Special case Itypes to test the Sloc of the associated node. The | |
701 | -- reason we do this is for possible calls from gigi after -gnatD | |
702 | -- processing is complete in sprint. This processing updates the | |
703 | -- sloc fields of all nodes in the tree, but itypes are not in the | |
704 | -- tree so their slocs do not get updated. | |
705 | ||
706 | elsif Nkind (N) = N_Defining_Identifier | |
707 | and then Is_Itype (N) | |
708 | then | |
709 | return In_Extended_Main_Source_Unit (Associated_Node_For_Itype (N)); | |
710 | ||
fbf5a39b AC |
711 | -- Otherwise compare original locations to see if in same unit |
712 | ||
38cbfe40 RK |
713 | else |
714 | return | |
715 | In_Same_Extended_Unit | |
fbf5a39b AC |
716 | (Original_Location (Nloc), Original_Location (Mloc)); |
717 | end if; | |
718 | end In_Extended_Main_Source_Unit; | |
719 | ||
720 | function In_Extended_Main_Source_Unit | |
721 | (Loc : Source_Ptr) | |
722 | return Boolean | |
723 | is | |
724 | Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit)); | |
725 | ||
726 | begin | |
727 | -- If Mloc is not set, it means we are still parsing the main unit, | |
728 | -- so everything so far is in the extended main source unit. | |
729 | ||
730 | if Mloc = No_Location then | |
731 | return True; | |
732 | ||
733 | -- Special value cases | |
734 | ||
735 | elsif Loc = Standard_Location then | |
736 | return True; | |
737 | ||
738 | elsif Loc = No_Location then | |
739 | return False; | |
740 | ||
741 | -- Otherwise compare original locations to see if in same unit | |
742 | ||
743 | else | |
744 | return | |
745 | In_Same_Extended_Unit | |
746 | (Original_Location (Loc), Original_Location (Mloc)); | |
38cbfe40 RK |
747 | end if; |
748 | end In_Extended_Main_Source_Unit; | |
749 | ||
750 | ----------------------- | |
751 | -- In_Same_Code_Unit -- | |
752 | ----------------------- | |
753 | ||
754 | function In_Same_Code_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is | |
755 | S1 : constant Source_Ptr := Sloc (N1); | |
756 | S2 : constant Source_Ptr := Sloc (N2); | |
757 | ||
758 | begin | |
759 | if S1 = No_Location or else S2 = No_Location then | |
760 | return False; | |
761 | ||
762 | elsif S1 = Standard_Location then | |
763 | return S2 = Standard_Location; | |
764 | ||
765 | elsif S2 = Standard_Location then | |
766 | return False; | |
767 | end if; | |
768 | ||
769 | return Get_Code_Unit (N1) = Get_Code_Unit (N2); | |
770 | end In_Same_Code_Unit; | |
771 | ||
772 | --------------------------- | |
773 | -- In_Same_Extended_Unit -- | |
774 | --------------------------- | |
775 | ||
776 | function In_Same_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is | |
777 | begin | |
778 | return Check_Same_Extended_Unit (S1, S2) /= No; | |
779 | end In_Same_Extended_Unit; | |
780 | ||
781 | ------------------------- | |
782 | -- In_Same_Source_Unit -- | |
783 | ------------------------- | |
784 | ||
785 | function In_Same_Source_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is | |
786 | S1 : constant Source_Ptr := Sloc (N1); | |
787 | S2 : constant Source_Ptr := Sloc (N2); | |
788 | ||
789 | begin | |
790 | if S1 = No_Location or else S2 = No_Location then | |
791 | return False; | |
792 | ||
793 | elsif S1 = Standard_Location then | |
794 | return S2 = Standard_Location; | |
795 | ||
796 | elsif S2 = Standard_Location then | |
797 | return False; | |
798 | end if; | |
799 | ||
800 | return Get_Source_Unit (N1) = Get_Source_Unit (N2); | |
801 | end In_Same_Source_Unit; | |
802 | ||
803 | ----------------------------- | |
804 | -- Increment_Serial_Number -- | |
805 | ----------------------------- | |
806 | ||
807 | function Increment_Serial_Number return Nat is | |
808 | TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number; | |
809 | ||
810 | begin | |
811 | TSN := TSN + 1; | |
812 | return TSN; | |
813 | end Increment_Serial_Number; | |
814 | ||
815 | ---------------- | |
816 | -- Initialize -- | |
817 | ---------------- | |
818 | ||
819 | procedure Initialize is | |
820 | begin | |
821 | Linker_Option_Lines.Init; | |
822 | Load_Stack.Init; | |
823 | Units.Init; | |
824 | Unit_Exception_Table_Present := False; | |
825 | Compilation_Switches.Init; | |
826 | end Initialize; | |
827 | ||
828 | --------------- | |
829 | -- Is_Loaded -- | |
830 | --------------- | |
831 | ||
832 | function Is_Loaded (Uname : Unit_Name_Type) return Boolean is | |
833 | begin | |
834 | for Unum in Units.First .. Units.Last loop | |
835 | if Uname = Unit_Name (Unum) then | |
836 | return True; | |
837 | end if; | |
838 | end loop; | |
839 | ||
840 | return False; | |
841 | end Is_Loaded; | |
842 | ||
843 | --------------- | |
844 | -- Last_Unit -- | |
845 | --------------- | |
846 | ||
847 | function Last_Unit return Unit_Number_Type is | |
848 | begin | |
849 | return Units.Last; | |
850 | end Last_Unit; | |
851 | ||
852 | ---------- | |
853 | -- List -- | |
854 | ---------- | |
855 | ||
856 | procedure List (File_Names_Only : Boolean := False) is separate; | |
857 | ||
858 | ---------- | |
859 | -- Lock -- | |
860 | ---------- | |
861 | ||
862 | procedure Lock is | |
863 | begin | |
864 | Linker_Option_Lines.Locked := True; | |
865 | Load_Stack.Locked := True; | |
866 | Units.Locked := True; | |
867 | Linker_Option_Lines.Release; | |
868 | Load_Stack.Release; | |
869 | Units.Release; | |
870 | end Lock; | |
871 | ||
872 | --------------- | |
873 | -- Num_Units -- | |
874 | --------------- | |
875 | ||
876 | function Num_Units return Nat is | |
877 | begin | |
878 | return Int (Units.Last) - Int (Main_Unit) + 1; | |
879 | end Num_Units; | |
880 | ||
881 | ---------------------------------- | |
882 | -- Replace_Linker_Option_String -- | |
883 | ---------------------------------- | |
884 | ||
885 | procedure Replace_Linker_Option_String | |
886 | (S : String_Id; Match_String : String) | |
887 | is | |
888 | begin | |
889 | if Match_String'Length > 0 then | |
890 | for J in 1 .. Linker_Option_Lines.Last loop | |
07fc65c4 | 891 | String_To_Name_Buffer (Linker_Option_Lines.Table (J).Option); |
38cbfe40 RK |
892 | |
893 | if Match_String = Name_Buffer (1 .. Match_String'Length) then | |
07fc65c4 | 894 | Linker_Option_Lines.Table (J).Option := S; |
38cbfe40 RK |
895 | return; |
896 | end if; | |
897 | end loop; | |
898 | end if; | |
899 | ||
900 | Store_Linker_Option_String (S); | |
901 | end Replace_Linker_Option_String; | |
902 | ||
903 | ---------- | |
904 | -- Sort -- | |
905 | ---------- | |
906 | ||
907 | procedure Sort (Tbl : in out Unit_Ref_Table) is separate; | |
908 | ||
909 | ------------------------------ | |
910 | -- Store_Compilation_Switch -- | |
911 | ------------------------------ | |
912 | ||
913 | procedure Store_Compilation_Switch (Switch : String) is | |
914 | begin | |
915 | Compilation_Switches.Increment_Last; | |
f5e44987 RD |
916 | Compilation_Switches.Table (Compilation_Switches.Last) := |
917 | new String'(Switch); | |
fbf5a39b AC |
918 | |
919 | -- Fix up --RTS flag which has been transformed by the gcc driver | |
920 | -- into -fRTS | |
921 | ||
922 | if Switch'Last >= Switch'First + 4 | |
923 | and then Switch (Switch'First .. Switch'First + 4) = "-fRTS" | |
924 | then | |
925 | Compilation_Switches.Table | |
926 | (Compilation_Switches.Last) (Switch'First + 1) := '-'; | |
927 | end if; | |
38cbfe40 RK |
928 | end Store_Compilation_Switch; |
929 | ||
930 | -------------------------------- | |
931 | -- Store_Linker_Option_String -- | |
932 | -------------------------------- | |
933 | ||
934 | procedure Store_Linker_Option_String (S : String_Id) is | |
935 | begin | |
936 | Linker_Option_Lines.Increment_Last; | |
07fc65c4 GB |
937 | Linker_Option_Lines.Table (Linker_Option_Lines.Last) := |
938 | (Option => S, Unit => Current_Sem_Unit); | |
38cbfe40 RK |
939 | end Store_Linker_Option_String; |
940 | ||
941 | --------------- | |
942 | -- Tree_Read -- | |
943 | --------------- | |
944 | ||
945 | procedure Tree_Read is | |
946 | N : Nat; | |
947 | S : String_Ptr; | |
948 | ||
949 | begin | |
950 | Units.Tree_Read; | |
951 | ||
952 | -- Read Compilation_Switches table | |
953 | ||
954 | Tree_Read_Int (N); | |
955 | Compilation_Switches.Set_Last (N); | |
956 | ||
957 | for J in 1 .. N loop | |
958 | Tree_Read_Str (S); | |
959 | Compilation_Switches.Table (J) := S; | |
960 | end loop; | |
961 | end Tree_Read; | |
962 | ||
963 | ---------------- | |
964 | -- Tree_Write -- | |
965 | ---------------- | |
966 | ||
967 | procedure Tree_Write is | |
968 | begin | |
969 | Units.Tree_Write; | |
970 | ||
971 | -- Write Compilation_Switches table | |
972 | ||
973 | Tree_Write_Int (Compilation_Switches.Last); | |
974 | ||
975 | for J in 1 .. Compilation_Switches.Last loop | |
976 | Tree_Write_Str (Compilation_Switches.Table (J)); | |
977 | end loop; | |
978 | end Tree_Write; | |
979 | ||
980 | ----------------- | |
981 | -- Version_Get -- | |
982 | ----------------- | |
983 | ||
984 | function Version_Get (U : Unit_Number_Type) return Word_Hex_String is | |
985 | begin | |
986 | return Get_Hex_String (Units.Table (U).Version); | |
987 | end Version_Get; | |
988 | ||
989 | ------------------------ | |
990 | -- Version_Referenced -- | |
991 | ------------------------ | |
992 | ||
993 | procedure Version_Referenced (S : String_Id) is | |
994 | begin | |
995 | Version_Ref.Append (S); | |
996 | end Version_Referenced; | |
997 | ||
998 | end Lib; |