File : ali.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- A L I --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
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 Butil; use Butil;
27 with Debug; use Debug;
28 with Fname; use Fname;
29 with Opt; use Opt;
30 with Osint; use Osint;
31 with Output; use Output;
32
33 package body ALI is
34
35 use ASCII;
36 -- Make control characters visible
37
38 -- The following variable records which characters currently are
39 -- used as line type markers in the ALI file. This is used in
40 -- Scan_ALI to detect (or skip) invalid lines.
41
42 Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean :=
43 ('V' => True, -- version
44 'M' => True, -- main program
45 'A' => True, -- argument
46 'P' => True, -- program
47 'R' => True, -- restriction
48 'I' => True, -- interrupt
49 'U' => True, -- unit
50 'W' => True, -- with
51 'L' => True, -- linker option
52 'N' => True, -- notes
53 'E' => True, -- external
54 'D' => True, -- dependency
55 'X' => True, -- xref
56 'S' => True, -- specific dispatching
57 'Y' => True, -- limited_with
58 'Z' => True, -- implicit with from instantiation
59 'C' => True, -- SCO information
60 'F' => True, -- SPARK cross-reference information
61 others => False);
62
63 --------------------
64 -- Initialize_ALI --
65 --------------------
66
67 procedure Initialize_ALI is
68 begin
69 -- When (re)initializing ALI data structures the ALI user expects to
70 -- get a fresh set of data structures. Thus we first need to erase the
71 -- marks put in the name table by the previous set of ALI routine calls.
72 -- These two loops are empty and harmless the first time in.
73
74 for J in ALIs.First .. ALIs.Last loop
75 Set_Name_Table_Int (ALIs.Table (J).Afile, 0);
76 end loop;
77
78 for J in Units.First .. Units.Last loop
79 Set_Name_Table_Int (Units.Table (J).Uname, 0);
80 end loop;
81
82 -- Free argument table strings
83
84 for J in Args.First .. Args.Last loop
85 Free (Args.Table (J));
86 end loop;
87
88 -- Initialize all tables
89
90 ALIs.Init;
91 No_Deps.Init;
92 Units.Init;
93 Withs.Init;
94 Sdep.Init;
95 Linker_Options.Init;
96 Notes.Init;
97 Xref_Section.Init;
98 Xref_Entity.Init;
99 Xref.Init;
100 Version_Ref.Reset;
101
102 -- Add dummy zero'th item in Linker_Options and Notes for sort calls
103
104 Linker_Options.Increment_Last;
105 Notes.Increment_Last;
106
107 -- Initialize global variables recording cumulative options in all
108 -- ALI files that are read for a given processing run in gnatbind.
109
110 Dynamic_Elaboration_Checks_Specified := False;
111 Locking_Policy_Specified := ' ';
112 No_Normalize_Scalars_Specified := False;
113 No_Object_Specified := False;
114 GNATprove_Mode_Specified := False;
115 Normalize_Scalars_Specified := False;
116 Partition_Elaboration_Policy_Specified := ' ';
117 Queuing_Policy_Specified := ' ';
118 SSO_Default_Specified := False;
119 Static_Elaboration_Model_Used := False;
120 Task_Dispatching_Policy_Specified := ' ';
121 Unreserve_All_Interrupts_Specified := False;
122 Frontend_Exceptions_Specified := False;
123 Zero_Cost_Exceptions_Specified := False;
124 end Initialize_ALI;
125
126 --------------
127 -- Scan_ALI --
128 --------------
129
130 function Scan_ALI
131 (F : File_Name_Type;
132 T : Text_Buffer_Ptr;
133 Ignore_ED : Boolean;
134 Err : Boolean;
135 Read_Xref : Boolean := False;
136 Read_Lines : String := "";
137 Ignore_Lines : String := "X";
138 Ignore_Errors : Boolean := False;
139 Directly_Scanned : Boolean := False) return ALI_Id
140 is
141 P : Text_Ptr := T'First;
142 Line : Logical_Line_Number := 1;
143 Id : ALI_Id;
144 C : Character;
145 NS_Found : Boolean;
146 First_Arg : Arg_Id;
147
148 Ignore : array (Character range 'A' .. 'Z') of Boolean;
149 -- Ignore (X) is set to True if lines starting with X are to
150 -- be ignored by Scan_ALI and skipped, and False if the lines
151 -- are to be read and processed.
152
153 Bad_ALI_Format : exception;
154 -- Exception raised by Fatal_Error if Err is True
155
156 function At_Eol return Boolean;
157 -- Test if at end of line
158
159 function At_End_Of_Field return Boolean;
160 -- Test if at end of line, or if at blank or horizontal tab
161
162 procedure Check_At_End_Of_Field;
163 -- Check if we are at end of field, fatal error if not
164
165 procedure Checkc (C : Character);
166 -- Check next character is C. If so bump past it, if not fatal error
167
168 procedure Check_Unknown_Line;
169 -- If Ignore_Errors mode, then checks C to make sure that it is not
170 -- an unknown ALI line type characters, and if so, skips lines
171 -- until the first character of the line is one of these characters,
172 -- at which point it does a Getc to put that character in C. The
173 -- call has no effect if C is already an appropriate character.
174 -- If not in Ignore_Errors mode, a fatal error is signalled if the
175 -- line is unknown. Note that if C is an EOL on entry, the line is
176 -- skipped (it is assumed that blank lines are never significant).
177 -- If C is EOF on entry, the call has no effect (it is assumed that
178 -- the caller will properly handle this case).
179
180 procedure Fatal_Error;
181 -- Generate fatal error message for badly formatted ALI file if
182 -- Err is false, or raise Bad_ALI_Format if Err is True.
183
184 procedure Fatal_Error_Ignore;
185 pragma Inline (Fatal_Error_Ignore);
186 -- In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error
187
188 function Getc return Character;
189 -- Get next character, bumping P past the character obtained
190
191 function Get_File_Name
192 (Lower : Boolean := False;
193 May_Be_Quoted : Boolean := False) return File_Name_Type;
194 -- Skip blanks, then scan out a file name (name is left in Name_Buffer
195 -- with length in Name_Len, as well as returning a File_Name_Type value.
196 -- If May_Be_Quoted is True and the first non blank character is '"',
197 -- then remove starting and ending quotes and undoubled internal quotes.
198 -- If lower is false, the case is unchanged, if Lower is True then the
199 -- result is forced to all lower case for systems where file names are
200 -- not case sensitive. This ensures that gnatbind works correctly
201 -- regardless of the case of the file name on all systems. The scan
202 -- is terminated by a end of line, space or horizontal tab. Any other
203 -- special characters are included in the returned name.
204
205 function Get_Name
206 (Ignore_Spaces : Boolean := False;
207 Ignore_Special : Boolean := False;
208 May_Be_Quoted : Boolean := False) return Name_Id;
209 -- Skip blanks, then scan out a name (name is left in Name_Buffer with
210 -- length in Name_Len, as well as being returned in Name_Id form).
211 -- If Lower is set to True then the Name_Buffer will be converted to
212 -- all lower case, for systems where file names are not case sensitive.
213 -- This ensures that gnatbind works correctly regardless of the case
214 -- of the file name on all systems. The termination condition depends
215 -- on the settings of Ignore_Spaces and Ignore_Special:
216 --
217 -- If Ignore_Spaces is False (normal case), then scan is terminated
218 -- by the normal end of field condition (EOL, space, horizontal tab)
219 --
220 -- If Ignore_Special is False (normal case), the scan is terminated by
221 -- a typeref bracket or an equal sign except for the special case of
222 -- an operator name starting with a double quote which is terminated
223 -- by another double quote.
224 --
225 -- If May_Be_Quoted is True and the first non blank character is '"'
226 -- the name is 'unquoted'. In this case Ignore_Special is ignored and
227 -- assumed to be True.
228 --
229 -- It is an error to set both Ignore_Spaces and Ignore_Special to True.
230 -- This function handles wide characters properly.
231
232 function Get_Nat return Nat;
233 -- Skip blanks, then scan out an unsigned integer value in Nat range
234 -- raises ALI_Reading_Error if the encoutered type is not natural.
235
236 function Get_Stamp return Time_Stamp_Type;
237 -- Skip blanks, then scan out a time stamp
238
239 function Get_Unit_Name return Unit_Name_Type;
240 -- Skip blanks, then scan out a file name (name is left in Name_Buffer
241 -- with length in Name_Len, as well as returning a Unit_Name_Type value.
242 -- The case is unchanged and terminated by a normal end of field.
243
244 function Nextc return Character;
245 -- Return current character without modifying pointer P
246
247 procedure Get_Typeref
248 (Current_File_Num : Sdep_Id;
249 Ref : out Tref_Kind;
250 File_Num : out Sdep_Id;
251 Line : out Nat;
252 Ref_Type : out Character;
253 Col : out Nat;
254 Standard_Entity : out Name_Id);
255 -- Parse the definition of a typeref (<...>, {...} or (...))
256
257 procedure Skip_Eol;
258 -- Skip past spaces, then skip past end of line (fatal error if not
259 -- at end of line). Also skips past any following blank lines.
260
261 procedure Skip_Line;
262 -- Skip rest of current line and any following blank lines
263
264 procedure Skip_Space;
265 -- Skip past white space (blanks or horizontal tab)
266
267 procedure Skipc;
268 -- Skip past next character, does not affect value in C. This call
269 -- is like calling Getc and ignoring the returned result.
270
271 ---------------------
272 -- At_End_Of_Field --
273 ---------------------
274
275 function At_End_Of_Field return Boolean is
276 begin
277 return Nextc <= ' ';
278 end At_End_Of_Field;
279
280 ------------
281 -- At_Eol --
282 ------------
283
284 function At_Eol return Boolean is
285 begin
286 return Nextc = EOF or else Nextc = CR or else Nextc = LF;
287 end At_Eol;
288
289 ---------------------------
290 -- Check_At_End_Of_Field --
291 ---------------------------
292
293 procedure Check_At_End_Of_Field is
294 begin
295 if not At_End_Of_Field then
296 if Ignore_Errors then
297 while Nextc > ' ' loop
298 P := P + 1;
299 end loop;
300 else
301 Fatal_Error;
302 end if;
303 end if;
304 end Check_At_End_Of_Field;
305
306 ------------------------
307 -- Check_Unknown_Line --
308 ------------------------
309
310 procedure Check_Unknown_Line is
311 begin
312 while C not in 'A' .. 'Z'
313 or else not Known_ALI_Lines (C)
314 loop
315 if C = CR or else C = LF then
316 Skip_Line;
317 C := Nextc;
318
319 elsif C = EOF then
320 return;
321
322 elsif Ignore_Errors then
323 Skip_Line;
324 C := Getc;
325
326 else
327 Fatal_Error;
328 end if;
329 end loop;
330 end Check_Unknown_Line;
331
332 ------------
333 -- Checkc --
334 ------------
335
336 procedure Checkc (C : Character) is
337 begin
338 if Nextc = C then
339 P := P + 1;
340 elsif Ignore_Errors then
341 P := P + 1;
342 else
343 Fatal_Error;
344 end if;
345 end Checkc;
346
347 -----------------
348 -- Fatal_Error --
349 -----------------
350
351 procedure Fatal_Error is
352 Ptr1 : Text_Ptr;
353 Ptr2 : Text_Ptr;
354 Col : Int;
355
356 procedure Wchar (C : Character);
357 -- Write a single character, replacing horizontal tab by spaces
358
359 procedure Wchar (C : Character) is
360 begin
361 if C = HT then
362 loop
363 Wchar (' ');
364 exit when Col mod 8 = 0;
365 end loop;
366
367 else
368 Write_Char (C);
369 Col := Col + 1;
370 end if;
371 end Wchar;
372
373 -- Start of processing for Fatal_Error
374
375 begin
376 if Err then
377 raise Bad_ALI_Format;
378 end if;
379
380 Set_Standard_Error;
381 Write_Str ("fatal error: file ");
382 Write_Name (F);
383 Write_Str (" is incorrectly formatted");
384 Write_Eol;
385
386 Write_Str ("make sure you are using consistent versions " &
387
388 -- Split the following line so that it can easily be transformed for
389 -- other back-ends where the compiler might have a different name.
390
391 "of gcc/gnatbind");
392
393 Write_Eol;
394
395 -- Find start of line
396
397 Ptr1 := P;
398 while Ptr1 > T'First
399 and then T (Ptr1 - 1) /= CR
400 and then T (Ptr1 - 1) /= LF
401 loop
402 Ptr1 := Ptr1 - 1;
403 end loop;
404
405 Write_Int (Int (Line));
406 Write_Str (". ");
407
408 if Line < 100 then
409 Write_Char (' ');
410 end if;
411
412 if Line < 10 then
413 Write_Char (' ');
414 end if;
415
416 Col := 0;
417 Ptr2 := Ptr1;
418
419 while Ptr2 < T'Last
420 and then T (Ptr2) /= CR
421 and then T (Ptr2) /= LF
422 loop
423 Wchar (T (Ptr2));
424 Ptr2 := Ptr2 + 1;
425 end loop;
426
427 Write_Eol;
428
429 Write_Str (" ");
430 Col := 0;
431
432 while Ptr1 < P loop
433 if T (Ptr1) = HT then
434 Wchar (HT);
435 else
436 Wchar (' ');
437 end if;
438
439 Ptr1 := Ptr1 + 1;
440 end loop;
441
442 Wchar ('|');
443 Write_Eol;
444
445 Exit_Program (E_Fatal);
446 end Fatal_Error;
447
448 ------------------------
449 -- Fatal_Error_Ignore --
450 ------------------------
451
452 procedure Fatal_Error_Ignore is
453 begin
454 if not Ignore_Errors then
455 Fatal_Error;
456 end if;
457 end Fatal_Error_Ignore;
458
459 -------------------
460 -- Get_File_Name --
461 -------------------
462
463 function Get_File_Name
464 (Lower : Boolean := False;
465 May_Be_Quoted : Boolean := False) return File_Name_Type
466 is
467 F : Name_Id;
468
469 begin
470 F := Get_Name (Ignore_Special => True,
471 May_Be_Quoted => May_Be_Quoted);
472
473 -- Convert file name to all lower case if file names are not case
474 -- sensitive. This ensures that we handle names in the canonical
475 -- lower case format, regardless of the actual case.
476
477 if Lower and not File_Names_Case_Sensitive then
478 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
479 return Name_Find;
480 else
481 return File_Name_Type (F);
482 end if;
483 end Get_File_Name;
484
485 --------------
486 -- Get_Name --
487 --------------
488
489 function Get_Name
490 (Ignore_Spaces : Boolean := False;
491 Ignore_Special : Boolean := False;
492 May_Be_Quoted : Boolean := False) return Name_Id
493 is
494 Char : Character;
495
496 begin
497 Name_Len := 0;
498 Skip_Space;
499
500 if At_Eol then
501 if Ignore_Errors then
502 return Error_Name;
503 else
504 Fatal_Error;
505 end if;
506 end if;
507
508 Char := Getc;
509
510 -- Deal with quoted characters
511
512 if May_Be_Quoted and then Char = '"' then
513 loop
514 if At_Eol then
515 if Ignore_Errors then
516 return Error_Name;
517 else
518 Fatal_Error;
519 end if;
520 end if;
521
522 Char := Getc;
523
524 if Char = '"' then
525 if At_Eol then
526 exit;
527
528 else
529 Char := Getc;
530
531 if Char /= '"' then
532 P := P - 1;
533 exit;
534 end if;
535 end if;
536 end if;
537
538 Add_Char_To_Name_Buffer (Char);
539 end loop;
540
541 -- Other than case of quoted character
542
543 else
544 P := P - 1;
545 loop
546 Add_Char_To_Name_Buffer (Getc);
547
548 exit when At_End_Of_Field and then not Ignore_Spaces;
549
550 if not Ignore_Special then
551 if Name_Buffer (1) = '"' then
552 exit when Name_Len > 1
553 and then Name_Buffer (Name_Len) = '"';
554
555 else
556 -- Terminate on parens or angle brackets or equal sign
557
558 exit when Nextc = '(' or else Nextc = ')'
559 or else Nextc = '{' or else Nextc = '}'
560 or else Nextc = '<' or else Nextc = '>'
561 or else Nextc = '=';
562
563 -- Terminate on comma
564
565 exit when Nextc = ',';
566
567 -- Terminate if left bracket not part of wide char
568 -- sequence Note that we only recognize brackets
569 -- notation so far ???
570
571 exit when Nextc = '[' and then T (P + 1) /= '"';
572
573 -- Terminate if right bracket not part of wide char
574 -- sequence.
575
576 exit when Nextc = ']' and then T (P - 1) /= '"';
577 end if;
578 end if;
579 end loop;
580 end if;
581
582 return Name_Find;
583 end Get_Name;
584
585 -------------------
586 -- Get_Unit_Name --
587 -------------------
588
589 function Get_Unit_Name return Unit_Name_Type is
590 begin
591 return Unit_Name_Type (Get_Name);
592 end Get_Unit_Name;
593
594 -------------
595 -- Get_Nat --
596 -------------
597
598 function Get_Nat return Nat is
599 V : Nat;
600
601 begin
602 Skip_Space;
603
604 -- Check if we are on a number. In the case of bad ALI files, this
605 -- may not be true.
606
607 if not (Nextc in '0' .. '9') then
608 Fatal_Error;
609 end if;
610
611 V := 0;
612 loop
613 V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0'));
614
615 exit when At_End_Of_Field;
616 exit when Nextc < '0' or else Nextc > '9';
617 end loop;
618
619 return V;
620 end Get_Nat;
621
622 ---------------
623 -- Get_Stamp --
624 ---------------
625
626 function Get_Stamp return Time_Stamp_Type is
627 T : Time_Stamp_Type;
628 Start : Integer;
629
630 begin
631 Skip_Space;
632
633 if At_Eol then
634 if Ignore_Errors then
635 return Dummy_Time_Stamp;
636 else
637 Fatal_Error;
638 end if;
639 end if;
640
641 -- Following reads old style time stamp missing first two digits
642
643 if Nextc in '7' .. '9' then
644 T (1) := '1';
645 T (2) := '9';
646 Start := 3;
647
648 -- Normal case of full year in time stamp
649
650 else
651 Start := 1;
652 end if;
653
654 for J in Start .. T'Last loop
655 T (J) := Getc;
656 end loop;
657
658 return T;
659 end Get_Stamp;
660
661 -----------------
662 -- Get_Typeref --
663 -----------------
664
665 procedure Get_Typeref
666 (Current_File_Num : Sdep_Id;
667 Ref : out Tref_Kind;
668 File_Num : out Sdep_Id;
669 Line : out Nat;
670 Ref_Type : out Character;
671 Col : out Nat;
672 Standard_Entity : out Name_Id)
673 is
674 N : Nat;
675 begin
676 case Nextc is
677 when '<' => Ref := Tref_Derived;
678 when '(' => Ref := Tref_Access;
679 when '{' => Ref := Tref_Type;
680 when others => Ref := Tref_None;
681 end case;
682
683 -- Case of typeref field present
684
685 if Ref /= Tref_None then
686 P := P + 1; -- skip opening bracket
687
688 if Nextc in 'a' .. 'z' then
689 File_Num := No_Sdep_Id;
690 Line := 0;
691 Ref_Type := ' ';
692 Col := 0;
693 Standard_Entity := Get_Name (Ignore_Spaces => True);
694 else
695 N := Get_Nat;
696
697 if Nextc = '|' then
698 File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
699 P := P + 1;
700 N := Get_Nat;
701 else
702 File_Num := Current_File_Num;
703 end if;
704
705 Line := N;
706 Ref_Type := Getc;
707 Col := Get_Nat;
708 Standard_Entity := No_Name;
709 end if;
710
711 -- ??? Temporary workaround for nested generics case:
712 -- 4i4 Directories{1|4I9[4|6[3|3]]}
713 -- See C918-002
714
715 declare
716 Nested_Brackets : Natural := 0;
717
718 begin
719 loop
720 case Nextc is
721 when '[' =>
722 Nested_Brackets := Nested_Brackets + 1;
723 when ']' =>
724 Nested_Brackets := Nested_Brackets - 1;
725 when others =>
726 if Nested_Brackets = 0 then
727 exit;
728 end if;
729 end case;
730
731 Skipc;
732 end loop;
733 end;
734
735 P := P + 1; -- skip closing bracket
736 Skip_Space;
737
738 -- No typeref entry present
739
740 else
741 File_Num := No_Sdep_Id;
742 Line := 0;
743 Ref_Type := ' ';
744 Col := 0;
745 Standard_Entity := No_Name;
746 end if;
747 end Get_Typeref;
748
749 ----------
750 -- Getc --
751 ----------
752
753 function Getc return Character is
754 begin
755 if P = T'Last then
756 return EOF;
757 else
758 P := P + 1;
759 return T (P - 1);
760 end if;
761 end Getc;
762
763 -----------
764 -- Nextc --
765 -----------
766
767 function Nextc return Character is
768 begin
769 return T (P);
770 end Nextc;
771
772 --------------
773 -- Skip_Eol --
774 --------------
775
776 procedure Skip_Eol is
777 begin
778 Skip_Space;
779
780 if not At_Eol then
781 if Ignore_Errors then
782 while not At_Eol loop
783 P := P + 1;
784 end loop;
785 else
786 Fatal_Error;
787 end if;
788 end if;
789
790 -- Loop to skip past blank lines (first time through skips this EOL)
791
792 while Nextc < ' ' and then Nextc /= EOF loop
793 if Nextc = LF then
794 Line := Line + 1;
795 end if;
796
797 P := P + 1;
798 end loop;
799 end Skip_Eol;
800
801 ---------------
802 -- Skip_Line --
803 ---------------
804
805 procedure Skip_Line is
806 begin
807 while not At_Eol loop
808 P := P + 1;
809 end loop;
810
811 Skip_Eol;
812 end Skip_Line;
813
814 ----------------
815 -- Skip_Space --
816 ----------------
817
818 procedure Skip_Space is
819 begin
820 while Nextc = ' ' or else Nextc = HT loop
821 P := P + 1;
822 end loop;
823 end Skip_Space;
824
825 -----------
826 -- Skipc --
827 -----------
828
829 procedure Skipc is
830 begin
831 if P /= T'Last then
832 P := P + 1;
833 end if;
834 end Skipc;
835
836 -- Start of processing for Scan_ALI
837
838 begin
839 First_Sdep_Entry := Sdep.Last + 1;
840
841 -- Acquire lines to be ignored
842
843 if Read_Xref then
844 Ignore :=
845 ('U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True);
846
847 -- Read_Lines parameter given
848
849 elsif Read_Lines /= "" then
850 Ignore := ('U' => False, others => True);
851
852 for J in Read_Lines'Range loop
853 Ignore (Read_Lines (J)) := False;
854 end loop;
855
856 -- Process Ignore_Lines parameter
857
858 else
859 Ignore := (others => False);
860
861 for J in Ignore_Lines'Range loop
862 pragma Assert (Ignore_Lines (J) /= 'U');
863 Ignore (Ignore_Lines (J)) := True;
864 end loop;
865 end if;
866
867 -- Setup ALI Table entry with appropriate defaults
868
869 ALIs.Increment_Last;
870 Id := ALIs.Last;
871 Set_Name_Table_Int (F, Int (Id));
872
873 ALIs.Table (Id) := (
874 Afile => F,
875 Compile_Errors => False,
876 First_Interrupt_State => Interrupt_States.Last + 1,
877 First_Sdep => No_Sdep_Id,
878 First_Specific_Dispatching => Specific_Dispatching.Last + 1,
879 First_Unit => No_Unit_Id,
880 GNATprove_Mode => False,
881 Last_Interrupt_State => Interrupt_States.Last,
882 Last_Sdep => No_Sdep_Id,
883 Last_Specific_Dispatching => Specific_Dispatching.Last,
884 Last_Unit => No_Unit_Id,
885 Locking_Policy => ' ',
886 Main_Priority => -1,
887 Main_CPU => -1,
888 Main_Program => None,
889 No_Object => False,
890 Normalize_Scalars => False,
891 Ofile_Full_Name => Full_Object_File_Name,
892 Partition_Elaboration_Policy => ' ',
893 Queuing_Policy => ' ',
894 Restrictions => No_Restrictions,
895 SAL_Interface => False,
896 Sfile => No_File,
897 SSO_Default => ' ',
898 Task_Dispatching_Policy => ' ',
899 Time_Slice_Value => -1,
900 WC_Encoding => 'b',
901 Unit_Exception_Table => False,
902 Ver => (others => ' '),
903 Ver_Len => 0,
904 Frontend_Exceptions => False,
905 Zero_Cost_Exceptions => False);
906
907 -- Now we acquire the input lines from the ALI file. Note that the
908 -- convention in the following code is that as we enter each section,
909 -- C is set to contain the first character of the following line.
910
911 C := Getc;
912 Check_Unknown_Line;
913
914 -- Acquire library version
915
916 if C /= 'V' then
917
918 -- The V line missing really indicates trouble, most likely it
919 -- means we don't have an ALI file at all, so here we give a
920 -- fatal error even if we are in Ignore_Errors mode.
921
922 Fatal_Error;
923
924 elsif Ignore ('V') then
925 Skip_Line;
926
927 else
928 Checkc (' ');
929 Skip_Space;
930 Checkc ('"');
931
932 for J in 1 .. Ver_Len_Max loop
933 C := Getc;
934 exit when C = '"';
935 ALIs.Table (Id).Ver (J) := C;
936 ALIs.Table (Id).Ver_Len := J;
937 end loop;
938
939 Skip_Eol;
940 end if;
941
942 C := Getc;
943 Check_Unknown_Line;
944
945 -- Acquire main program line if present
946
947 if C = 'M' then
948 if Ignore ('M') then
949 Skip_Line;
950
951 else
952 Checkc (' ');
953 Skip_Space;
954
955 C := Getc;
956
957 if C = 'F' then
958 ALIs.Table (Id).Main_Program := Func;
959 elsif C = 'P' then
960 ALIs.Table (Id).Main_Program := Proc;
961 else
962 P := P - 1;
963 Fatal_Error;
964 end if;
965
966 Skip_Space;
967
968 if not At_Eol then
969 if Nextc < 'A' then
970 ALIs.Table (Id).Main_Priority := Get_Nat;
971 end if;
972
973 Skip_Space;
974
975 if Nextc = 'T' then
976 P := P + 1;
977 Checkc ('=');
978 ALIs.Table (Id).Time_Slice_Value := Get_Nat;
979 end if;
980
981 Skip_Space;
982
983 if Nextc = 'C' then
984 P := P + 1;
985 Checkc ('=');
986 ALIs.Table (Id).Main_CPU := Get_Nat;
987 end if;
988
989 Skip_Space;
990
991 Checkc ('W');
992 Checkc ('=');
993 ALIs.Table (Id).WC_Encoding := Getc;
994 end if;
995
996 Skip_Eol;
997 end if;
998
999 C := Getc;
1000 end if;
1001
1002 -- Acquire argument lines
1003
1004 First_Arg := Args.Last + 1;
1005
1006 A_Loop : loop
1007 Check_Unknown_Line;
1008 exit A_Loop when C /= 'A';
1009
1010 if Ignore ('A') then
1011 Skip_Line;
1012
1013 else
1014 Checkc (' ');
1015
1016 -- Scan out argument
1017
1018 Name_Len := 0;
1019 while not At_Eol loop
1020 Add_Char_To_Name_Buffer (Getc);
1021 end loop;
1022
1023 -- If -fstack-check, record that it occurred. Note that an
1024 -- additional string parameter can be specified, in the form of
1025 -- -fstack-check={no|generic|specific}. "no" means no checking,
1026 -- "generic" means force the use of old-style checking, and
1027 -- "specific" means use the best checking method.
1028
1029 if Name_Len >= 13
1030 and then Name_Buffer (1 .. 13) = "-fstack-check"
1031 and then Name_Buffer (1 .. Name_Len) /= "-fstack-check=no"
1032 then
1033 Stack_Check_Switch_Set := True;
1034 end if;
1035
1036 -- Store the argument
1037
1038 Args.Increment_Last;
1039 Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len));
1040
1041 Skip_Eol;
1042 end if;
1043
1044 C := Getc;
1045 end loop A_Loop;
1046
1047 -- Acquire P line
1048
1049 Check_Unknown_Line;
1050
1051 while C /= 'P' loop
1052 if Ignore_Errors then
1053 if C = EOF then
1054 Fatal_Error;
1055 else
1056 Skip_Line;
1057 C := Nextc;
1058 end if;
1059 else
1060 Fatal_Error;
1061 end if;
1062 end loop;
1063
1064 if Ignore ('P') then
1065 Skip_Line;
1066
1067 -- Process P line
1068
1069 else
1070 NS_Found := False;
1071
1072 while not At_Eol loop
1073 Checkc (' ');
1074 Skip_Space;
1075 C := Getc;
1076
1077 -- Processing for CE
1078
1079 if C = 'C' then
1080 Checkc ('E');
1081 ALIs.Table (Id).Compile_Errors := True;
1082
1083 -- Processing for DB
1084
1085 elsif C = 'D' then
1086 Checkc ('B');
1087 Detect_Blocking := True;
1088
1089 -- Processing for Ex
1090
1091 elsif C = 'E' then
1092 Partition_Elaboration_Policy_Specified := Getc;
1093 ALIs.Table (Id).Partition_Elaboration_Policy :=
1094 Partition_Elaboration_Policy_Specified;
1095
1096 -- Processing for FX
1097
1098 elsif C = 'F' then
1099 C := Getc;
1100
1101 if C = 'X' then
1102 ALIs.Table (Id).Frontend_Exceptions := True;
1103 Frontend_Exceptions_Specified := True;
1104 else
1105 Fatal_Error_Ignore;
1106 end if;
1107
1108 -- Processing for GP
1109
1110 elsif C = 'G' then
1111 Checkc ('P');
1112 GNATprove_Mode_Specified := True;
1113 ALIs.Table (Id).GNATprove_Mode := True;
1114
1115 -- Processing for Lx
1116
1117 elsif C = 'L' then
1118 Locking_Policy_Specified := Getc;
1119 ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
1120
1121 -- Processing for flags starting with N
1122
1123 elsif C = 'N' then
1124 C := Getc;
1125
1126 -- Processing for NO
1127
1128 if C = 'O' then
1129 ALIs.Table (Id).No_Object := True;
1130 No_Object_Specified := True;
1131
1132 -- Processing for NR
1133
1134 elsif C = 'R' then
1135 No_Run_Time_Mode := True;
1136 Configurable_Run_Time_Mode := True;
1137
1138 -- Processing for NS
1139
1140 elsif C = 'S' then
1141 ALIs.Table (Id).Normalize_Scalars := True;
1142 Normalize_Scalars_Specified := True;
1143 NS_Found := True;
1144
1145 -- Invalid switch starting with N
1146
1147 else
1148 Fatal_Error_Ignore;
1149 end if;
1150
1151 -- Processing for OH/OL
1152
1153 elsif C = 'O' then
1154 C := Getc;
1155
1156 if C = 'L' or else C = 'H' then
1157 ALIs.Table (Id).SSO_Default := C;
1158 SSO_Default_Specified := True;
1159
1160 else
1161 Fatal_Error_Ignore;
1162 end if;
1163
1164 -- Processing for Qx
1165
1166 elsif C = 'Q' then
1167 Queuing_Policy_Specified := Getc;
1168 ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
1169
1170 -- Processing for flags starting with S
1171
1172 elsif C = 'S' then
1173 C := Getc;
1174
1175 -- Processing for SL
1176
1177 if C = 'L' then
1178 ALIs.Table (Id).SAL_Interface := True;
1179
1180 -- Processing for SS
1181
1182 elsif C = 'S' then
1183 Opt.Sec_Stack_Used := True;
1184
1185 -- Invalid switch starting with S
1186
1187 else
1188 Fatal_Error_Ignore;
1189 end if;
1190
1191 -- Processing for Tx
1192
1193 elsif C = 'T' then
1194 Task_Dispatching_Policy_Specified := Getc;
1195 ALIs.Table (Id).Task_Dispatching_Policy :=
1196 Task_Dispatching_Policy_Specified;
1197
1198 -- Processing for switch starting with U
1199
1200 elsif C = 'U' then
1201 C := Getc;
1202
1203 -- Processing for UA
1204
1205 if C = 'A' then
1206 Unreserve_All_Interrupts_Specified := True;
1207
1208 -- Processing for UX
1209
1210 elsif C = 'X' then
1211 ALIs.Table (Id).Unit_Exception_Table := True;
1212
1213 -- Invalid switches starting with U
1214
1215 else
1216 Fatal_Error_Ignore;
1217 end if;
1218
1219 -- Processing for ZX
1220
1221 elsif C = 'Z' then
1222 C := Getc;
1223
1224 if C = 'X' then
1225 ALIs.Table (Id).Zero_Cost_Exceptions := True;
1226 Zero_Cost_Exceptions_Specified := True;
1227 else
1228 Fatal_Error_Ignore;
1229 end if;
1230
1231 -- Invalid parameter
1232
1233 else
1234 C := Getc;
1235 Fatal_Error_Ignore;
1236 end if;
1237 end loop;
1238
1239 if not NS_Found then
1240 No_Normalize_Scalars_Specified := True;
1241 end if;
1242
1243 Skip_Eol;
1244 end if;
1245
1246 C := Getc;
1247 Check_Unknown_Line;
1248
1249 -- Loop to skip to first restrictions line
1250
1251 while C /= 'R' loop
1252 if Ignore_Errors then
1253 if C = EOF then
1254 Fatal_Error;
1255 else
1256 Skip_Line;
1257 C := Nextc;
1258 end if;
1259 else
1260 Fatal_Error;
1261 end if;
1262 end loop;
1263
1264 -- Ignore all 'R' lines if that is required
1265
1266 if Ignore ('R') then
1267 while C = 'R' loop
1268 Skip_Line;
1269 C := Getc;
1270 end loop;
1271
1272 -- Here we process the restrictions lines (other than unit name cases)
1273
1274 else
1275 Scan_Restrictions : declare
1276 Save_R : constant Restrictions_Info := Cumulative_Restrictions;
1277 -- Save cumulative restrictions in case we have a fatal error
1278
1279 Bad_R_Line : exception;
1280 -- Signal bad restrictions line (raised on unexpected character)
1281
1282 Typ : Character;
1283 R : Restriction_Id;
1284 N : Natural;
1285
1286 begin
1287 -- Named restriction case
1288
1289 if Nextc = 'N' then
1290 Skip_Line;
1291 C := Getc;
1292
1293 -- Loop through RR and RV lines
1294
1295 while C = 'R' and then Nextc /= ' ' loop
1296 Typ := Getc;
1297 Checkc (' ');
1298
1299 -- Acquire restriction name
1300
1301 Name_Len := 0;
1302 while not At_Eol and then Nextc /= '=' loop
1303 Name_Len := Name_Len + 1;
1304 Name_Buffer (Name_Len) := Getc;
1305 end loop;
1306
1307 -- Now search list of restrictions to find match
1308
1309 declare
1310 RN : String renames Name_Buffer (1 .. Name_Len);
1311
1312 begin
1313 R := Restriction_Id'First;
1314 while R /= Not_A_Restriction_Id loop
1315 if Restriction_Id'Image (R) = RN then
1316 goto R_Found;
1317 end if;
1318
1319 R := Restriction_Id'Succ (R);
1320 end loop;
1321
1322 -- We don't recognize the restriction. This might be
1323 -- thought of as an error, and it really is, but we
1324 -- want to allow building with inconsistent versions
1325 -- of the binder and ali files (see comments at the
1326 -- start of package System.Rident), so we just ignore
1327 -- this situation.
1328
1329 goto Done_With_Restriction_Line;
1330 end;
1331
1332 <<R_Found>>
1333
1334 case R is
1335
1336 -- Boolean restriction case
1337
1338 when All_Boolean_Restrictions =>
1339 case Typ is
1340 when 'V' =>
1341 ALIs.Table (Id).Restrictions.Violated (R) :=
1342 True;
1343 Cumulative_Restrictions.Violated (R) := True;
1344
1345 when 'R' =>
1346 ALIs.Table (Id).Restrictions.Set (R) := True;
1347 Cumulative_Restrictions.Set (R) := True;
1348
1349 when others =>
1350 raise Bad_R_Line;
1351 end case;
1352
1353 -- Parameter restriction case
1354
1355 when All_Parameter_Restrictions =>
1356 if At_Eol or else Nextc /= '=' then
1357 raise Bad_R_Line;
1358 else
1359 Skipc;
1360 end if;
1361
1362 N := Natural (Get_Nat);
1363
1364 case Typ is
1365
1366 -- Restriction set
1367
1368 when 'R' =>
1369 ALIs.Table (Id).Restrictions.Set (R) := True;
1370 ALIs.Table (Id).Restrictions.Value (R) := N;
1371
1372 if Cumulative_Restrictions.Set (R) then
1373 Cumulative_Restrictions.Value (R) :=
1374 Integer'Min
1375 (Cumulative_Restrictions.Value (R), N);
1376 else
1377 Cumulative_Restrictions.Set (R) := True;
1378 Cumulative_Restrictions.Value (R) := N;
1379 end if;
1380
1381 -- Restriction violated
1382
1383 when 'V' =>
1384 ALIs.Table (Id).Restrictions.Violated (R) :=
1385 True;
1386 Cumulative_Restrictions.Violated (R) := True;
1387 ALIs.Table (Id).Restrictions.Count (R) := N;
1388
1389 -- Checked Max_Parameter case
1390
1391 if R in Checked_Max_Parameter_Restrictions then
1392 Cumulative_Restrictions.Count (R) :=
1393 Integer'Max
1394 (Cumulative_Restrictions.Count (R), N);
1395
1396 -- Other checked parameter cases
1397
1398 else
1399 declare
1400 pragma Unsuppress (Overflow_Check);
1401
1402 begin
1403 Cumulative_Restrictions.Count (R) :=
1404 Cumulative_Restrictions.Count (R) + N;
1405
1406 exception
1407 when Constraint_Error =>
1408
1409 -- A constraint error comes from the
1410 -- addition. We reset to the maximum
1411 -- and indicate that the real value
1412 -- is now unknown.
1413
1414 Cumulative_Restrictions.Value (R) :=
1415 Integer'Last;
1416 Cumulative_Restrictions.Unknown (R) :=
1417 True;
1418 end;
1419 end if;
1420
1421 -- Deal with + case
1422
1423 if Nextc = '+' then
1424 Skipc;
1425 ALIs.Table (Id).Restrictions.Unknown (R) :=
1426 True;
1427 Cumulative_Restrictions.Unknown (R) := True;
1428 end if;
1429
1430 -- Other than 'R' or 'V'
1431
1432 when others =>
1433 raise Bad_R_Line;
1434 end case;
1435
1436 if not At_Eol then
1437 raise Bad_R_Line;
1438 end if;
1439
1440 -- Bizarre error case NOT_A_RESTRICTION
1441
1442 when Not_A_Restriction_Id =>
1443 raise Bad_R_Line;
1444 end case;
1445
1446 if not At_Eol then
1447 raise Bad_R_Line;
1448 end if;
1449
1450 <<Done_With_Restriction_Line>>
1451 Skip_Line;
1452 C := Getc;
1453 end loop;
1454
1455 -- Positional restriction case
1456
1457 else
1458 Checkc (' ');
1459 Skip_Space;
1460
1461 -- Acquire information for boolean restrictions
1462
1463 for R in All_Boolean_Restrictions loop
1464 C := Getc;
1465
1466 case C is
1467 when 'v' =>
1468 ALIs.Table (Id).Restrictions.Violated (R) := True;
1469 Cumulative_Restrictions.Violated (R) := True;
1470
1471 when 'r' =>
1472 ALIs.Table (Id).Restrictions.Set (R) := True;
1473 Cumulative_Restrictions.Set (R) := True;
1474
1475 when 'n' =>
1476 null;
1477
1478 when others =>
1479 raise Bad_R_Line;
1480 end case;
1481 end loop;
1482
1483 -- Acquire information for parameter restrictions
1484
1485 for RP in All_Parameter_Restrictions loop
1486 case Getc is
1487 when 'n' =>
1488 null;
1489
1490 when 'r' =>
1491 ALIs.Table (Id).Restrictions.Set (RP) := True;
1492
1493 declare
1494 N : constant Integer := Integer (Get_Nat);
1495 begin
1496 ALIs.Table (Id).Restrictions.Value (RP) := N;
1497
1498 if Cumulative_Restrictions.Set (RP) then
1499 Cumulative_Restrictions.Value (RP) :=
1500 Integer'Min
1501 (Cumulative_Restrictions.Value (RP), N);
1502 else
1503 Cumulative_Restrictions.Set (RP) := True;
1504 Cumulative_Restrictions.Value (RP) := N;
1505 end if;
1506 end;
1507
1508 when others =>
1509 raise Bad_R_Line;
1510 end case;
1511
1512 -- Acquire restrictions violations information
1513
1514 case Getc is
1515
1516 when 'n' =>
1517 null;
1518
1519 when 'v' =>
1520 ALIs.Table (Id).Restrictions.Violated (RP) := True;
1521 Cumulative_Restrictions.Violated (RP) := True;
1522
1523 declare
1524 N : constant Integer := Integer (Get_Nat);
1525
1526 begin
1527 ALIs.Table (Id).Restrictions.Count (RP) := N;
1528
1529 if RP in Checked_Max_Parameter_Restrictions then
1530 Cumulative_Restrictions.Count (RP) :=
1531 Integer'Max
1532 (Cumulative_Restrictions.Count (RP), N);
1533
1534 else
1535 declare
1536 pragma Unsuppress (Overflow_Check);
1537
1538 begin
1539 Cumulative_Restrictions.Count (RP) :=
1540 Cumulative_Restrictions.Count (RP) + N;
1541
1542 exception
1543 when Constraint_Error =>
1544
1545 -- A constraint error comes from the add. We
1546 -- reset to the maximum and indicate that the
1547 -- real value is now unknown.
1548
1549 Cumulative_Restrictions.Value (RP) :=
1550 Integer'Last;
1551 Cumulative_Restrictions.Unknown (RP) := True;
1552 end;
1553 end if;
1554
1555 if Nextc = '+' then
1556 Skipc;
1557 ALIs.Table (Id).Restrictions.Unknown (RP) := True;
1558 Cumulative_Restrictions.Unknown (RP) := True;
1559 end if;
1560 end;
1561
1562 when others =>
1563 raise Bad_R_Line;
1564 end case;
1565 end loop;
1566
1567 if not At_Eol then
1568 raise Bad_R_Line;
1569 else
1570 Skip_Line;
1571 C := Getc;
1572 end if;
1573 end if;
1574
1575 -- Here if error during scanning of restrictions line
1576
1577 exception
1578 when Bad_R_Line =>
1579
1580 -- In Ignore_Errors mode, undo any changes to restrictions
1581 -- from this unit, and continue on, skipping remaining R
1582 -- lines for this unit.
1583
1584 if Ignore_Errors then
1585 Cumulative_Restrictions := Save_R;
1586 ALIs.Table (Id).Restrictions := No_Restrictions;
1587
1588 loop
1589 Skip_Eol;
1590 C := Getc;
1591 exit when C /= 'R';
1592 end loop;
1593
1594 -- In normal mode, this is a fatal error
1595
1596 else
1597 Fatal_Error;
1598 end if;
1599 end Scan_Restrictions;
1600 end if;
1601
1602 -- Acquire additional restrictions (No_Dependence) lines if present
1603
1604 while C = 'R' loop
1605 if Ignore ('R') then
1606 Skip_Line;
1607 else
1608 Skip_Space;
1609 No_Deps.Append ((Id, Get_Name));
1610 Skip_Eol;
1611 end if;
1612
1613 C := Getc;
1614 end loop;
1615
1616 -- Acquire 'I' lines if present
1617
1618 Check_Unknown_Line;
1619
1620 while C = 'I' loop
1621 if Ignore ('I') then
1622 Skip_Line;
1623
1624 else
1625 declare
1626 Int_Num : Nat;
1627 I_State : Character;
1628 Line_No : Nat;
1629
1630 begin
1631 Int_Num := Get_Nat;
1632 Skip_Space;
1633 I_State := Getc;
1634 Line_No := Get_Nat;
1635
1636 Interrupt_States.Append (
1637 (Interrupt_Id => Int_Num,
1638 Interrupt_State => I_State,
1639 IS_Pragma_Line => Line_No));
1640
1641 ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last;
1642 Skip_Eol;
1643 end;
1644 end if;
1645
1646 C := Getc;
1647 end loop;
1648
1649 -- Acquire 'S' lines if present
1650
1651 Check_Unknown_Line;
1652
1653 while C = 'S' loop
1654 if Ignore ('S') then
1655 Skip_Line;
1656
1657 else
1658 declare
1659 Policy : Character;
1660 First_Prio : Nat;
1661 Last_Prio : Nat;
1662 Line_No : Nat;
1663
1664 begin
1665 Checkc (' ');
1666 Skip_Space;
1667
1668 Policy := Getc;
1669 Skip_Space;
1670 First_Prio := Get_Nat;
1671 Last_Prio := Get_Nat;
1672 Line_No := Get_Nat;
1673
1674 Specific_Dispatching.Append (
1675 (Dispatching_Policy => Policy,
1676 First_Priority => First_Prio,
1677 Last_Priority => Last_Prio,
1678 PSD_Pragma_Line => Line_No));
1679
1680 ALIs.Table (Id).Last_Specific_Dispatching :=
1681 Specific_Dispatching.Last;
1682
1683 Skip_Eol;
1684 end;
1685 end if;
1686
1687 C := Getc;
1688 end loop;
1689
1690 -- Loop to acquire unit entries
1691
1692 U_Loop : loop
1693 Check_Unknown_Line;
1694 exit U_Loop when C /= 'U';
1695
1696 -- Note: as per spec, we never ignore U lines
1697
1698 Checkc (' ');
1699 Skip_Space;
1700 Units.Increment_Last;
1701
1702 if ALIs.Table (Id).First_Unit = No_Unit_Id then
1703 ALIs.Table (Id).First_Unit := Units.Last;
1704 end if;
1705
1706 declare
1707 UL : Unit_Record renames Units.Table (Units.Last);
1708
1709 begin
1710 UL.Uname := Get_Unit_Name;
1711 UL.Predefined := Is_Predefined_Unit;
1712 UL.Internal := Is_Internal_Unit;
1713 UL.My_ALI := Id;
1714 UL.Sfile := Get_File_Name (Lower => True);
1715 UL.Pure := False;
1716 UL.Preelab := False;
1717 UL.No_Elab := False;
1718 UL.Shared_Passive := False;
1719 UL.RCI := False;
1720 UL.Remote_Types := False;
1721 UL.Serious_Errors := False;
1722 UL.Has_RACW := False;
1723 UL.Init_Scalars := False;
1724 UL.Is_Generic := False;
1725 UL.Icasing := Mixed_Case;
1726 UL.Kcasing := All_Lower_Case;
1727 UL.Dynamic_Elab := False;
1728 UL.Elaborate_Body := False;
1729 UL.Set_Elab_Entity := False;
1730 UL.Version := "00000000";
1731 UL.First_With := Withs.Last + 1;
1732 UL.First_Arg := First_Arg;
1733 UL.Elab_Position := 0;
1734 UL.SAL_Interface := ALIs.Table (Id).SAL_Interface;
1735 UL.Directly_Scanned := Directly_Scanned;
1736 UL.Body_Needed_For_SAL := False;
1737 UL.Elaborate_Body_Desirable := False;
1738 UL.Optimize_Alignment := 'O';
1739 UL.Has_Finalizer := False;
1740
1741 if Debug_Flag_U then
1742 Write_Str (" ----> reading unit ");
1743 Write_Int (Int (Units.Last));
1744 Write_Str (" ");
1745 Write_Unit_Name (UL.Uname);
1746 Write_Str (" from file ");
1747 Write_Name (UL.Sfile);
1748 Write_Eol;
1749 end if;
1750 end;
1751
1752 -- Check for duplicated unit in different files
1753
1754 declare
1755 Info : constant Int := Get_Name_Table_Int
1756 (Units.Table (Units.Last).Uname);
1757 begin
1758 if Info /= 0
1759 and then Units.Table (Units.Last).Sfile /=
1760 Units.Table (Unit_Id (Info)).Sfile
1761 then
1762 -- If Err is set then ignore duplicate unit name. This is the
1763 -- case of a call from gnatmake, where the situation can arise
1764 -- from substitution of source files. In such situations, the
1765 -- processing in gnatmake will always result in any required
1766 -- recompilations in any case, and if we consider this to be
1767 -- an error we get strange cases (for example when a generic
1768 -- instantiation is replaced by a normal package) where we
1769 -- read the old ali file, decide to recompile, and then decide
1770 -- that the old and new ali files are incompatible.
1771
1772 if Err then
1773 null;
1774
1775 -- If Err is not set, then this is a fatal error. This is
1776 -- the case of being called from the binder, where we must
1777 -- definitely diagnose this as an error.
1778
1779 else
1780 Set_Standard_Error;
1781 Write_Str ("error: duplicate unit name: ");
1782 Write_Eol;
1783
1784 Write_Str ("error: unit """);
1785 Write_Unit_Name (Units.Table (Units.Last).Uname);
1786 Write_Str (""" found in file """);
1787 Write_Name_Decoded (Units.Table (Units.Last).Sfile);
1788 Write_Char ('"');
1789 Write_Eol;
1790
1791 Write_Str ("error: unit """);
1792 Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
1793 Write_Str (""" found in file """);
1794 Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
1795 Write_Char ('"');
1796 Write_Eol;
1797
1798 Exit_Program (E_Fatal);
1799 end if;
1800 end if;
1801 end;
1802
1803 Set_Name_Table_Int
1804 (Units.Table (Units.Last).Uname, Int (Units.Last));
1805
1806 -- Scan out possible version and other parameters
1807
1808 loop
1809 Skip_Space;
1810 exit when At_Eol;
1811 C := Getc;
1812
1813 -- Version field
1814
1815 if C in '0' .. '9' or else C in 'a' .. 'f' then
1816 Units.Table (Units.Last).Version (1) := C;
1817
1818 for J in 2 .. 8 loop
1819 C := Getc;
1820 Units.Table (Units.Last).Version (J) := C;
1821 end loop;
1822
1823 -- BD/BN parameters
1824
1825 elsif C = 'B' then
1826 C := Getc;
1827
1828 if C = 'D' then
1829 Check_At_End_Of_Field;
1830 Units.Table (Units.Last).Elaborate_Body_Desirable := True;
1831
1832 elsif C = 'N' then
1833 Check_At_End_Of_Field;
1834 Units.Table (Units.Last).Body_Needed_For_SAL := True;
1835
1836 else
1837 Fatal_Error_Ignore;
1838 end if;
1839
1840 -- DE parameter (Dynamic elaboration checks)
1841
1842 elsif C = 'D' then
1843 C := Getc;
1844
1845 if C = 'E' then
1846 Check_At_End_Of_Field;
1847 Units.Table (Units.Last).Dynamic_Elab := True;
1848 Dynamic_Elaboration_Checks_Specified := True;
1849 else
1850 Fatal_Error_Ignore;
1851 end if;
1852
1853 -- EB/EE parameters
1854
1855 elsif C = 'E' then
1856 C := Getc;
1857
1858 if C = 'B' then
1859 Units.Table (Units.Last).Elaborate_Body := True;
1860 elsif C = 'E' then
1861 Units.Table (Units.Last).Set_Elab_Entity := True;
1862 else
1863 Fatal_Error_Ignore;
1864 end if;
1865
1866 Check_At_End_Of_Field;
1867
1868 -- GE parameter (generic)
1869
1870 elsif C = 'G' then
1871 C := Getc;
1872
1873 if C = 'E' then
1874 Check_At_End_Of_Field;
1875 Units.Table (Units.Last).Is_Generic := True;
1876 else
1877 Fatal_Error_Ignore;
1878 end if;
1879
1880 -- IL/IS/IU parameters
1881
1882 elsif C = 'I' then
1883 C := Getc;
1884
1885 if C = 'L' then
1886 Units.Table (Units.Last).Icasing := All_Lower_Case;
1887 elsif C = 'S' then
1888 Units.Table (Units.Last).Init_Scalars := True;
1889 Initialize_Scalars_Used := True;
1890 elsif C = 'U' then
1891 Units.Table (Units.Last).Icasing := All_Upper_Case;
1892 else
1893 Fatal_Error_Ignore;
1894 end if;
1895
1896 Check_At_End_Of_Field;
1897
1898 -- KM/KU parameters
1899
1900 elsif C = 'K' then
1901 C := Getc;
1902
1903 if C = 'M' then
1904 Units.Table (Units.Last).Kcasing := Mixed_Case;
1905 elsif C = 'U' then
1906 Units.Table (Units.Last).Kcasing := All_Upper_Case;
1907 else
1908 Fatal_Error_Ignore;
1909 end if;
1910
1911 Check_At_End_Of_Field;
1912
1913 -- NE parameter
1914
1915 elsif C = 'N' then
1916 C := Getc;
1917
1918 if C = 'E' then
1919 Units.Table (Units.Last).No_Elab := True;
1920 Check_At_End_Of_Field;
1921 else
1922 Fatal_Error_Ignore;
1923 end if;
1924
1925 -- PF/PR/PU/PK parameters
1926
1927 elsif C = 'P' then
1928 C := Getc;
1929
1930 if C = 'F' then
1931 Units.Table (Units.Last).Has_Finalizer := True;
1932 elsif C = 'R' then
1933 Units.Table (Units.Last).Preelab := True;
1934 elsif C = 'U' then
1935 Units.Table (Units.Last).Pure := True;
1936 elsif C = 'K' then
1937 Units.Table (Units.Last).Unit_Kind := 'p';
1938 else
1939 Fatal_Error_Ignore;
1940 end if;
1941
1942 Check_At_End_Of_Field;
1943
1944 -- OL/OO/OS/OT parameters
1945
1946 elsif C = 'O' then
1947 C := Getc;
1948
1949 if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then
1950 Units.Table (Units.Last).Optimize_Alignment := C;
1951 else
1952 Fatal_Error_Ignore;
1953 end if;
1954
1955 Check_At_End_Of_Field;
1956
1957 -- RC/RT parameters
1958
1959 elsif C = 'R' then
1960 C := Getc;
1961
1962 if C = 'C' then
1963 Units.Table (Units.Last).RCI := True;
1964 elsif C = 'T' then
1965 Units.Table (Units.Last).Remote_Types := True;
1966 elsif C = 'A' then
1967 Units.Table (Units.Last).Has_RACW := True;
1968 else
1969 Fatal_Error_Ignore;
1970 end if;
1971
1972 Check_At_End_Of_Field;
1973
1974 -- SE/SP/SU parameters
1975
1976 elsif C = 'S' then
1977 C := Getc;
1978
1979 if C = 'E' then
1980 Units.Table (Units.Last).Serious_Errors := True;
1981 elsif C = 'P' then
1982 Units.Table (Units.Last).Shared_Passive := True;
1983 elsif C = 'U' then
1984 Units.Table (Units.Last).Unit_Kind := 's';
1985 else
1986 Fatal_Error_Ignore;
1987 end if;
1988
1989 Check_At_End_Of_Field;
1990
1991 else
1992 C := Getc;
1993 Fatal_Error_Ignore;
1994 end if;
1995 end loop;
1996
1997 Skip_Eol;
1998
1999 -- Check if static elaboration model used
2000
2001 if not Units.Table (Units.Last).Dynamic_Elab
2002 and then not Units.Table (Units.Last).Internal
2003 then
2004 Static_Elaboration_Model_Used := True;
2005 end if;
2006
2007 C := Getc;
2008
2009 -- Scan out With lines for this unit
2010
2011 With_Loop : loop
2012 Check_Unknown_Line;
2013 exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z';
2014
2015 if Ignore ('W') then
2016 Skip_Line;
2017
2018 else
2019 Checkc (' ');
2020 Skip_Space;
2021 Withs.Increment_Last;
2022 Withs.Table (Withs.Last).Uname := Get_Unit_Name;
2023 Withs.Table (Withs.Last).Elaborate := False;
2024 Withs.Table (Withs.Last).Elaborate_All := False;
2025 Withs.Table (Withs.Last).Elab_Desirable := False;
2026 Withs.Table (Withs.Last).Elab_All_Desirable := False;
2027 Withs.Table (Withs.Last).SAL_Interface := False;
2028 Withs.Table (Withs.Last).Limited_With := (C = 'Y');
2029 Withs.Table (Withs.Last).Implicit_With_From_Instantiation
2030 := (C = 'Z');
2031
2032 -- Generic case with no object file available
2033
2034 if At_Eol then
2035 Withs.Table (Withs.Last).Sfile := No_File;
2036 Withs.Table (Withs.Last).Afile := No_File;
2037
2038 -- Normal case
2039
2040 else
2041 Withs.Table (Withs.Last).Sfile := Get_File_Name
2042 (Lower => True);
2043 Withs.Table (Withs.Last).Afile := Get_File_Name
2044 (Lower => True);
2045
2046 -- Scan out possible E, EA, ED, and AD parameters
2047
2048 while not At_Eol loop
2049 Skip_Space;
2050
2051 if Nextc = 'A' then
2052 P := P + 1;
2053 Checkc ('D');
2054 Check_At_End_Of_Field;
2055
2056 -- Store AD indication unless ignore required
2057
2058 if not Ignore_ED then
2059 Withs.Table (Withs.Last).Elab_All_Desirable :=
2060 True;
2061 end if;
2062
2063 elsif Nextc = 'E' then
2064 P := P + 1;
2065
2066 if At_End_Of_Field then
2067 Withs.Table (Withs.Last).Elaborate := True;
2068
2069 elsif Nextc = 'A' then
2070 P := P + 1;
2071 Check_At_End_Of_Field;
2072 Withs.Table (Withs.Last).Elaborate_All := True;
2073
2074 else
2075 Checkc ('D');
2076 Check_At_End_Of_Field;
2077
2078 -- Store ED indication unless ignore required
2079
2080 if not Ignore_ED then
2081 Withs.Table (Withs.Last).Elab_Desirable :=
2082 True;
2083 end if;
2084 end if;
2085
2086 else
2087 Fatal_Error;
2088 end if;
2089 end loop;
2090 end if;
2091
2092 Skip_Eol;
2093 end if;
2094
2095 C := Getc;
2096 end loop With_Loop;
2097
2098 Units.Table (Units.Last).Last_With := Withs.Last;
2099 Units.Table (Units.Last).Last_Arg := Args.Last;
2100
2101 -- If there are linker options lines present, scan them
2102
2103 Name_Len := 0;
2104
2105 Linker_Options_Loop : loop
2106 Check_Unknown_Line;
2107 exit Linker_Options_Loop when C /= 'L';
2108
2109 if Ignore ('L') then
2110 Skip_Line;
2111
2112 else
2113 Checkc (' ');
2114 Skip_Space;
2115 Checkc ('"');
2116
2117 loop
2118 C := Getc;
2119
2120 if C < Character'Val (16#20#)
2121 or else C > Character'Val (16#7E#)
2122 then
2123 Fatal_Error_Ignore;
2124
2125 elsif C = '{' then
2126 C := Character'Val (0);
2127
2128 declare
2129 V : Natural;
2130
2131 begin
2132 V := 0;
2133 for J in 1 .. 2 loop
2134 C := Getc;
2135
2136 if C in '0' .. '9' then
2137 V := V * 16 +
2138 Character'Pos (C) -
2139 Character'Pos ('0');
2140
2141 elsif C in 'A' .. 'F' then
2142 V := V * 16 +
2143 Character'Pos (C) -
2144 Character'Pos ('A') +
2145 10;
2146
2147 else
2148 Fatal_Error_Ignore;
2149 end if;
2150 end loop;
2151
2152 Checkc ('}');
2153 Add_Char_To_Name_Buffer (Character'Val (V));
2154 end;
2155
2156 else
2157 if C = '"' then
2158 exit when Nextc /= '"';
2159 C := Getc;
2160 end if;
2161
2162 Add_Char_To_Name_Buffer (C);
2163 end if;
2164 end loop;
2165
2166 Add_Char_To_Name_Buffer (NUL);
2167 Skip_Eol;
2168 end if;
2169
2170 C := Getc;
2171 end loop Linker_Options_Loop;
2172
2173 -- Store the linker options entry if one was found
2174
2175 if Name_Len /= 0 then
2176 Linker_Options.Increment_Last;
2177
2178 Linker_Options.Table (Linker_Options.Last).Name :=
2179 Name_Enter;
2180
2181 Linker_Options.Table (Linker_Options.Last).Unit :=
2182 Units.Last;
2183
2184 Linker_Options.Table (Linker_Options.Last).Internal_File :=
2185 Is_Internal_File_Name (F);
2186
2187 Linker_Options.Table (Linker_Options.Last).Original_Pos :=
2188 Linker_Options.Last;
2189 end if;
2190
2191 -- If there are notes present, scan them
2192
2193 Notes_Loop : loop
2194 Check_Unknown_Line;
2195 exit Notes_Loop when C /= 'N';
2196
2197 if Ignore ('N') then
2198 Skip_Line;
2199
2200 else
2201 Checkc (' ');
2202
2203 Notes.Increment_Last;
2204 Notes.Table (Notes.Last).Pragma_Type := Getc;
2205 Notes.Table (Notes.Last).Pragma_Line := Get_Nat;
2206 Checkc (':');
2207 Notes.Table (Notes.Last).Pragma_Col := Get_Nat;
2208
2209 if not At_Eol and then Nextc = ':' then
2210 Checkc (':');
2211 Notes.Table (Notes.Last).Pragma_Source_File :=
2212 Get_File_Name (Lower => True);
2213 else
2214 Notes.Table (Notes.Last).Pragma_Source_File :=
2215 Units.Table (Units.Last).Sfile;
2216 end if;
2217
2218 if At_Eol then
2219 Notes.Table (Notes.Last).Pragma_Args := No_Name;
2220
2221 else
2222 -- Note: can't use Get_Name here as the remainder of the
2223 -- line is unstructured text whose syntax depends on the
2224 -- particular pragma used.
2225
2226 Checkc (' ');
2227
2228 Name_Len := 0;
2229 while not At_Eol loop
2230 Add_Char_To_Name_Buffer (Getc);
2231 end loop;
2232 end if;
2233
2234 Skip_Eol;
2235 end if;
2236
2237 C := Getc;
2238 end loop Notes_Loop;
2239 end loop U_Loop;
2240
2241 -- End loop through units for one ALI file
2242
2243 ALIs.Table (Id).Last_Unit := Units.Last;
2244 ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile;
2245
2246 -- Set types of the units (there can be at most 2 of them)
2247
2248 if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then
2249 Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body;
2250 Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec;
2251
2252 else
2253 -- Deal with body only and spec only cases, note that the reason we
2254 -- do our own checking of the name (rather than using Is_Body_Name)
2255 -- is that Uname drags in far too much compiler junk.
2256
2257 Get_Name_String (Units.Table (Units.Last).Uname);
2258
2259 if Name_Buffer (Name_Len) = 'b' then
2260 Units.Table (Units.Last).Utype := Is_Body_Only;
2261 else
2262 Units.Table (Units.Last).Utype := Is_Spec_Only;
2263 end if;
2264 end if;
2265
2266 -- Scan out external version references and put in hash table
2267
2268 E_Loop : loop
2269 Check_Unknown_Line;
2270 exit E_Loop when C /= 'E';
2271
2272 if Ignore ('E') then
2273 Skip_Line;
2274
2275 else
2276 Checkc (' ');
2277 Skip_Space;
2278
2279 Name_Len := 0;
2280 Name_Len := 0;
2281 loop
2282 C := Getc;
2283
2284 if C < ' ' then
2285 Fatal_Error;
2286 end if;
2287
2288 exit when At_End_Of_Field;
2289 Add_Char_To_Name_Buffer (C);
2290 end loop;
2291
2292 Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
2293 Skip_Eol;
2294 end if;
2295
2296 C := Getc;
2297 end loop E_Loop;
2298
2299 -- Scan out source dependency lines for this ALI file
2300
2301 ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
2302
2303 D_Loop : loop
2304 Check_Unknown_Line;
2305 exit D_Loop when C /= 'D';
2306
2307 if Ignore ('D') then
2308 Skip_Line;
2309
2310 else
2311 Checkc (' ');
2312 Skip_Space;
2313 Sdep.Increment_Last;
2314
2315 -- In the following call, Lower is not set to True, this is either
2316 -- a bug, or it deserves a special comment as to why this is so???
2317
2318 -- The file/path name may be quoted
2319
2320 Sdep.Table (Sdep.Last).Sfile :=
2321 Get_File_Name (May_Be_Quoted => True);
2322
2323 Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
2324 Sdep.Table (Sdep.Last).Dummy_Entry :=
2325 (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
2326
2327 -- Acquire checksum value
2328
2329 Skip_Space;
2330
2331 declare
2332 Ctr : Natural;
2333 Chk : Word;
2334
2335 begin
2336 Ctr := 0;
2337 Chk := 0;
2338
2339 loop
2340 exit when At_Eol or else Ctr = 8;
2341
2342 if Nextc in '0' .. '9' then
2343 Chk := Chk * 16 +
2344 Character'Pos (Nextc) - Character'Pos ('0');
2345
2346 elsif Nextc in 'a' .. 'f' then
2347 Chk := Chk * 16 +
2348 Character'Pos (Nextc) - Character'Pos ('a') + 10;
2349
2350 else
2351 exit;
2352 end if;
2353
2354 Ctr := Ctr + 1;
2355 P := P + 1;
2356 end loop;
2357
2358 if Ctr = 8 and then At_End_Of_Field then
2359 Sdep.Table (Sdep.Last).Checksum := Chk;
2360 else
2361 Fatal_Error;
2362 end if;
2363 end;
2364
2365 -- Acquire (sub)unit and reference file name entries
2366
2367 Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
2368 Sdep.Table (Sdep.Last).Unit_Name := No_Name;
2369 Sdep.Table (Sdep.Last).Rfile :=
2370 Sdep.Table (Sdep.Last).Sfile;
2371 Sdep.Table (Sdep.Last).Start_Line := 1;
2372
2373 if not At_Eol then
2374 Skip_Space;
2375
2376 -- Here for (sub)unit name
2377
2378 if Nextc not in '0' .. '9' then
2379 Name_Len := 0;
2380 while not At_End_Of_Field loop
2381 Add_Char_To_Name_Buffer (Getc);
2382 end loop;
2383
2384 -- Set the (sub)unit name. Note that we use Name_Find rather
2385 -- than Name_Enter here as the subunit name may already
2386 -- have been put in the name table by the Project Manager.
2387
2388 if Name_Len <= 2
2389 or else Name_Buffer (Name_Len - 1) /= '%'
2390 then
2391 Sdep.Table (Sdep.Last).Subunit_Name := Name_Find;
2392 else
2393 Name_Len := Name_Len - 2;
2394 Sdep.Table (Sdep.Last).Unit_Name := Name_Find;
2395 end if;
2396
2397 Skip_Space;
2398 end if;
2399
2400 -- Here for reference file name entry
2401
2402 if Nextc in '0' .. '9' then
2403 Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
2404 Checkc (':');
2405
2406 Name_Len := 0;
2407
2408 while not At_End_Of_Field loop
2409 Add_Char_To_Name_Buffer (Getc);
2410 end loop;
2411
2412 Sdep.Table (Sdep.Last).Rfile := Name_Enter;
2413 end if;
2414 end if;
2415
2416 Skip_Eol;
2417 end if;
2418
2419 C := Getc;
2420 end loop D_Loop;
2421
2422 ALIs.Table (Id).Last_Sdep := Sdep.Last;
2423
2424 -- We must at this stage be at an Xref line or the end of file
2425
2426 if C = EOF then
2427 return Id;
2428 end if;
2429
2430 Check_Unknown_Line;
2431
2432 if C /= 'X' then
2433 Fatal_Error;
2434 end if;
2435
2436 -- If we are ignoring Xref sections we are done (we ignore all
2437 -- remaining lines since only xref related lines follow X).
2438
2439 if Ignore ('X') and then not Debug_Flag_X then
2440 return Id;
2441 end if;
2442
2443 -- Loop through Xref sections
2444
2445 X_Loop : loop
2446 Check_Unknown_Line;
2447 exit X_Loop when C /= 'X';
2448
2449 -- Make new entry in section table
2450
2451 Xref_Section.Increment_Last;
2452
2453 Read_Refs_For_One_File : declare
2454 XS : Xref_Section_Record renames
2455 Xref_Section.Table (Xref_Section.Last);
2456
2457 Current_File_Num : Sdep_Id;
2458 -- Keeps track of the current file number (changed by nn|)
2459
2460 begin
2461 XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
2462 XS.File_Name := Get_File_Name;
2463 XS.First_Entity := Xref_Entity.Last + 1;
2464
2465 Current_File_Num := XS.File_Num;
2466
2467 Skip_Space;
2468
2469 Skip_Eol;
2470 C := Nextc;
2471
2472 -- Loop through Xref entities
2473
2474 while C /= 'X' and then C /= EOF loop
2475 Xref_Entity.Increment_Last;
2476
2477 Read_Refs_For_One_Entity : declare
2478 XE : Xref_Entity_Record renames
2479 Xref_Entity.Table (Xref_Entity.Last);
2480 N : Nat;
2481
2482 procedure Read_Instantiation_Reference;
2483 -- Acquire instantiation reference. Caller has checked
2484 -- that current character is '[' and on return the cursor
2485 -- is skipped past the corresponding closing ']'.
2486
2487 ----------------------------------
2488 -- Read_Instantiation_Reference --
2489 ----------------------------------
2490
2491 procedure Read_Instantiation_Reference is
2492 Local_File_Num : Sdep_Id := Current_File_Num;
2493
2494 begin
2495 Xref.Increment_Last;
2496
2497 declare
2498 XR : Xref_Record renames Xref.Table (Xref.Last);
2499
2500 begin
2501 P := P + 1; -- skip [
2502 N := Get_Nat;
2503
2504 if Nextc = '|' then
2505 XR.File_Num :=
2506 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2507 Local_File_Num := XR.File_Num;
2508 P := P + 1;
2509 N := Get_Nat;
2510
2511 else
2512 XR.File_Num := Local_File_Num;
2513 end if;
2514
2515 XR.Line := N;
2516 XR.Rtype := ' ';
2517 XR.Col := 0;
2518
2519 -- Recursive call for next reference
2520
2521 if Nextc = '[' then
2522 pragma Warnings (Off); -- kill recursion warning
2523 Read_Instantiation_Reference;
2524 pragma Warnings (On);
2525 end if;
2526
2527 -- Skip closing bracket after recursive call
2528
2529 P := P + 1;
2530 end;
2531 end Read_Instantiation_Reference;
2532
2533 -- Start of processing for Read_Refs_For_One_Entity
2534
2535 begin
2536 XE.Line := Get_Nat;
2537 XE.Etype := Getc;
2538 XE.Col := Get_Nat;
2539
2540 case Getc is
2541 when '*' =>
2542 XE.Visibility := Global;
2543 when '+' =>
2544 XE.Visibility := Static;
2545 when others =>
2546 XE.Visibility := Other;
2547 end case;
2548
2549 XE.Entity := Get_Name;
2550
2551 -- Handle the information about generic instantiations
2552
2553 if Nextc = '[' then
2554 Skipc; -- Opening '['
2555 N := Get_Nat;
2556
2557 if Nextc /= '|' then
2558 XE.Iref_File_Num := Current_File_Num;
2559 XE.Iref_Line := N;
2560 else
2561 XE.Iref_File_Num :=
2562 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2563 Skipc;
2564 XE.Iref_Line := Get_Nat;
2565 end if;
2566
2567 if Getc /= ']' then
2568 Fatal_Error;
2569 end if;
2570
2571 else
2572 XE.Iref_File_Num := No_Sdep_Id;
2573 XE.Iref_Line := 0;
2574 end if;
2575
2576 Current_File_Num := XS.File_Num;
2577
2578 -- Renaming reference is present
2579
2580 if Nextc = '=' then
2581 P := P + 1;
2582 XE.Rref_Line := Get_Nat;
2583
2584 if Getc /= ':' then
2585 Fatal_Error;
2586 end if;
2587
2588 XE.Rref_Col := Get_Nat;
2589
2590 -- No renaming reference present
2591
2592 else
2593 XE.Rref_Line := 0;
2594 XE.Rref_Col := 0;
2595 end if;
2596
2597 Skip_Space;
2598
2599 XE.Oref_File_Num := No_Sdep_Id;
2600 XE.Tref_File_Num := No_Sdep_Id;
2601 XE.Tref := Tref_None;
2602 XE.First_Xref := Xref.Last + 1;
2603
2604 -- Loop to check for additional info present
2605
2606 loop
2607 declare
2608 Ref : Tref_Kind;
2609 File : Sdep_Id;
2610 Line : Nat;
2611 Typ : Character;
2612 Col : Nat;
2613 Std : Name_Id;
2614
2615 begin
2616 Get_Typeref
2617 (Current_File_Num, Ref, File, Line, Typ, Col, Std);
2618 exit when Ref = Tref_None;
2619
2620 -- Do we have an overriding procedure?
2621
2622 if Ref = Tref_Derived and then Typ = 'p' then
2623 XE.Oref_File_Num := File;
2624 XE.Oref_Line := Line;
2625 XE.Oref_Col := Col;
2626
2627 -- Arrays never override anything, and <> points to
2628 -- the index types instead
2629
2630 elsif Ref = Tref_Derived and then XE.Etype = 'A' then
2631
2632 -- Index types are stored in the list of references
2633
2634 Xref.Increment_Last;
2635
2636 declare
2637 XR : Xref_Record renames Xref.Table (Xref.Last);
2638 begin
2639 XR.File_Num := File;
2640 XR.Line := Line;
2641 XR.Rtype := Array_Index_Reference;
2642 XR.Col := Col;
2643 XR.Name := Std;
2644 end;
2645
2646 -- Interfaces are stored in the list of references,
2647 -- although the parent type itself is stored in XE.
2648 -- The first interface (when there are only
2649 -- interfaces) is stored in XE.Tref*)
2650
2651 elsif Ref = Tref_Derived
2652 and then Typ = 'R'
2653 and then XE.Tref_File_Num /= No_Sdep_Id
2654 then
2655 Xref.Increment_Last;
2656
2657 declare
2658 XR : Xref_Record renames Xref.Table (Xref.Last);
2659 begin
2660 XR.File_Num := File;
2661 XR.Line := Line;
2662 XR.Rtype := Interface_Reference;
2663 XR.Col := Col;
2664 XR.Name := Std;
2665 end;
2666
2667 else
2668 XE.Tref := Ref;
2669 XE.Tref_File_Num := File;
2670 XE.Tref_Line := Line;
2671 XE.Tref_Type := Typ;
2672 XE.Tref_Col := Col;
2673 XE.Tref_Standard_Entity := Std;
2674 end if;
2675 end;
2676 end loop;
2677
2678 -- Loop through cross-references for this entity
2679
2680 loop
2681 Skip_Space;
2682
2683 if At_Eol then
2684 Skip_Eol;
2685 exit when Nextc /= '.';
2686 P := P + 1;
2687 end if;
2688
2689 Xref.Increment_Last;
2690
2691 declare
2692 XR : Xref_Record renames Xref.Table (Xref.Last);
2693
2694 begin
2695 N := Get_Nat;
2696
2697 if Nextc = '|' then
2698 XR.File_Num :=
2699 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2700 Current_File_Num := XR.File_Num;
2701 P := P + 1;
2702 N := Get_Nat;
2703 else
2704 XR.File_Num := Current_File_Num;
2705 end if;
2706
2707 XR.Line := N;
2708 XR.Rtype := Getc;
2709
2710 -- Imported entities reference as in:
2711 -- 494b<c,__gnat_copy_attribs>25
2712
2713 if Nextc = '<' then
2714 Skipc;
2715 XR.Imported_Lang := Get_Name;
2716
2717 pragma Assert (Nextc = ',');
2718 Skipc;
2719
2720 XR.Imported_Name := Get_Name;
2721
2722 pragma Assert (Nextc = '>');
2723 Skipc;
2724
2725 else
2726 XR.Imported_Lang := No_Name;
2727 XR.Imported_Name := No_Name;
2728 end if;
2729
2730 XR.Col := Get_Nat;
2731
2732 if Nextc = '[' then
2733 Read_Instantiation_Reference;
2734 end if;
2735 end;
2736 end loop;
2737
2738 -- Record last cross-reference
2739
2740 XE.Last_Xref := Xref.Last;
2741 C := Nextc;
2742
2743 exception
2744 when Bad_ALI_Format =>
2745
2746 -- If ignoring errors, then we skip a line with an
2747 -- unexpected error, and try to continue subsequent
2748 -- xref lines.
2749
2750 if Ignore_Errors then
2751 Xref_Entity.Decrement_Last;
2752 Skip_Line;
2753 C := Nextc;
2754
2755 -- Otherwise, we reraise the fatal exception
2756
2757 else
2758 raise;
2759 end if;
2760 end Read_Refs_For_One_Entity;
2761 end loop;
2762
2763 -- Record last entity
2764
2765 XS.Last_Entity := Xref_Entity.Last;
2766
2767 end Read_Refs_For_One_File;
2768
2769 C := Getc;
2770 end loop X_Loop;
2771
2772 -- Here after dealing with xref sections
2773
2774 -- Ignore remaining lines, which belong to an additional section of the
2775 -- ALI file not considered here (like SCO or SPARK information).
2776
2777 Check_Unknown_Line;
2778
2779 return Id;
2780
2781 exception
2782 when Bad_ALI_Format =>
2783 return No_ALI_Id;
2784 end Scan_ALI;
2785
2786 ---------
2787 -- SEq --
2788 ---------
2789
2790 function SEq (F1, F2 : String_Ptr) return Boolean is
2791 begin
2792 return F1.all = F2.all;
2793 end SEq;
2794
2795 -----------
2796 -- SHash --
2797 -----------
2798
2799 function SHash (S : String_Ptr) return Vindex is
2800 H : Word;
2801
2802 begin
2803 H := 0;
2804 for J in S.all'Range loop
2805 H := H * 2 + Character'Pos (S (J));
2806 end loop;
2807
2808 return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));
2809 end SHash;
2810
2811 end ALI;