PR rtl-optimization/79386
[official-gcc.git] / gcc / ada / ali.adb
blobd42cb34431a52e29cc49fbdf43354da9db5f5ffe
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- A L I --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, 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 ------------------------------------------------------------------------------
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;
33 package body ALI is
35 use ASCII;
36 -- Make control characters visible
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.
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);
63 --------------------
64 -- Initialize_ALI --
65 --------------------
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.
74 for J in ALIs.First .. ALIs.Last loop
75 Set_Name_Table_Int (ALIs.Table (J).Afile, 0);
76 end loop;
78 for J in Units.First .. Units.Last loop
79 Set_Name_Table_Int (Units.Table (J).Uname, 0);
80 end loop;
82 -- Free argument table strings
84 for J in Args.First .. Args.Last loop
85 Free (Args.Table (J));
86 end loop;
88 -- Initialize all tables
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;
102 -- Add dummy zero'th item in Linker_Options and Notes for sort calls
104 Linker_Options.Increment_Last;
105 Notes.Increment_Last;
107 -- Initialize global variables recording cumulative options in all
108 -- ALI files that are read for a given processing run in gnatbind.
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 Task_Dispatching_Policy_Specified := ' ';
120 Unreserve_All_Interrupts_Specified := False;
121 Frontend_Exceptions_Specified := False;
122 Zero_Cost_Exceptions_Specified := False;
123 end Initialize_ALI;
125 --------------
126 -- Scan_ALI --
127 --------------
129 function Scan_ALI
130 (F : File_Name_Type;
131 T : Text_Buffer_Ptr;
132 Ignore_ED : Boolean;
133 Err : Boolean;
134 Read_Xref : Boolean := False;
135 Read_Lines : String := "";
136 Ignore_Lines : String := "X";
137 Ignore_Errors : Boolean := False;
138 Directly_Scanned : Boolean := False) return ALI_Id
140 P : Text_Ptr := T'First;
141 Line : Logical_Line_Number := 1;
142 Id : ALI_Id;
143 C : Character;
144 NS_Found : Boolean;
145 First_Arg : Arg_Id;
147 Ignore : array (Character range 'A' .. 'Z') of Boolean;
148 -- Ignore (X) is set to True if lines starting with X are to
149 -- be ignored by Scan_ALI and skipped, and False if the lines
150 -- are to be read and processed.
152 Bad_ALI_Format : exception;
153 -- Exception raised by Fatal_Error if Err is True
155 function At_Eol return Boolean;
156 -- Test if at end of line
158 function At_End_Of_Field return Boolean;
159 -- Test if at end of line, or if at blank or horizontal tab
161 procedure Check_At_End_Of_Field;
162 -- Check if we are at end of field, fatal error if not
164 procedure Checkc (C : Character);
165 -- Check next character is C. If so bump past it, if not fatal error
167 procedure Check_Unknown_Line;
168 -- If Ignore_Errors mode, then checks C to make sure that it is not
169 -- an unknown ALI line type characters, and if so, skips lines
170 -- until the first character of the line is one of these characters,
171 -- at which point it does a Getc to put that character in C. The
172 -- call has no effect if C is already an appropriate character.
173 -- If not in Ignore_Errors mode, a fatal error is signalled if the
174 -- line is unknown. Note that if C is an EOL on entry, the line is
175 -- skipped (it is assumed that blank lines are never significant).
176 -- If C is EOF on entry, the call has no effect (it is assumed that
177 -- the caller will properly handle this case).
179 procedure Fatal_Error;
180 -- Generate fatal error message for badly formatted ALI file if
181 -- Err is false, or raise Bad_ALI_Format if Err is True.
183 procedure Fatal_Error_Ignore;
184 pragma Inline (Fatal_Error_Ignore);
185 -- In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error
187 function Getc return Character;
188 -- Get next character, bumping P past the character obtained
190 function Get_File_Name
191 (Lower : Boolean := False;
192 May_Be_Quoted : Boolean := False) return File_Name_Type;
193 -- Skip blanks, then scan out a file name (name is left in Name_Buffer
194 -- with length in Name_Len, as well as returning a File_Name_Type value.
195 -- If May_Be_Quoted is True and the first non blank character is '"',
196 -- then remove starting and ending quotes and undoubled internal quotes.
197 -- If lower is false, the case is unchanged, if Lower is True then the
198 -- result is forced to all lower case for systems where file names are
199 -- not case sensitive. This ensures that gnatbind works correctly
200 -- regardless of the case of the file name on all systems. The scan
201 -- is terminated by a end of line, space or horizontal tab. Any other
202 -- special characters are included in the returned name.
204 function Get_Name
205 (Ignore_Spaces : Boolean := False;
206 Ignore_Special : Boolean := False;
207 May_Be_Quoted : Boolean := False) return Name_Id;
208 -- Skip blanks, then scan out a name (name is left in Name_Buffer with
209 -- length in Name_Len, as well as being returned in Name_Id form).
210 -- If Lower is set to True then the Name_Buffer will be converted to
211 -- all lower case, for systems where file names are not case sensitive.
212 -- This ensures that gnatbind works correctly regardless of the case
213 -- of the file name on all systems. The termination condition depends
214 -- on the settings of Ignore_Spaces and Ignore_Special:
216 -- If Ignore_Spaces is False (normal case), then scan is terminated
217 -- by the normal end of field condition (EOL, space, horizontal tab)
219 -- If Ignore_Special is False (normal case), the scan is terminated by
220 -- a typeref bracket or an equal sign except for the special case of
221 -- an operator name starting with a double quote which is terminated
222 -- by another double quote.
224 -- If May_Be_Quoted is True and the first non blank character is '"'
225 -- the name is 'unquoted'. In this case Ignore_Special is ignored and
226 -- assumed to be True.
228 -- It is an error to set both Ignore_Spaces and Ignore_Special to True.
229 -- This function handles wide characters properly.
231 function Get_Nat return Nat;
232 -- Skip blanks, then scan out an unsigned integer value in Nat range
233 -- raises ALI_Reading_Error if the encoutered type is not natural.
235 function Get_Stamp return Time_Stamp_Type;
236 -- Skip blanks, then scan out a time stamp
238 function Get_Unit_Name return Unit_Name_Type;
239 -- Skip blanks, then scan out a file name (name is left in Name_Buffer
240 -- with length in Name_Len, as well as returning a Unit_Name_Type value.
241 -- The case is unchanged and terminated by a normal end of field.
243 function Nextc return Character;
244 -- Return current character without modifying pointer P
246 procedure Get_Typeref
247 (Current_File_Num : Sdep_Id;
248 Ref : out Tref_Kind;
249 File_Num : out Sdep_Id;
250 Line : out Nat;
251 Ref_Type : out Character;
252 Col : out Nat;
253 Standard_Entity : out Name_Id);
254 -- Parse the definition of a typeref (<...>, {...} or (...))
256 procedure Skip_Eol;
257 -- Skip past spaces, then skip past end of line (fatal error if not
258 -- at end of line). Also skips past any following blank lines.
260 procedure Skip_Line;
261 -- Skip rest of current line and any following blank lines
263 procedure Skip_Space;
264 -- Skip past white space (blanks or horizontal tab)
266 procedure Skipc;
267 -- Skip past next character, does not affect value in C. This call
268 -- is like calling Getc and ignoring the returned result.
270 ---------------------
271 -- At_End_Of_Field --
272 ---------------------
274 function At_End_Of_Field return Boolean is
275 begin
276 return Nextc <= ' ';
277 end At_End_Of_Field;
279 ------------
280 -- At_Eol --
281 ------------
283 function At_Eol return Boolean is
284 begin
285 return Nextc = EOF or else Nextc = CR or else Nextc = LF;
286 end At_Eol;
288 ---------------------------
289 -- Check_At_End_Of_Field --
290 ---------------------------
292 procedure Check_At_End_Of_Field is
293 begin
294 if not At_End_Of_Field then
295 if Ignore_Errors then
296 while Nextc > ' ' loop
297 P := P + 1;
298 end loop;
299 else
300 Fatal_Error;
301 end if;
302 end if;
303 end Check_At_End_Of_Field;
305 ------------------------
306 -- Check_Unknown_Line --
307 ------------------------
309 procedure Check_Unknown_Line is
310 begin
311 while C not in 'A' .. 'Z'
312 or else not Known_ALI_Lines (C)
313 loop
314 if C = CR or else C = LF then
315 Skip_Line;
316 C := Nextc;
318 elsif C = EOF then
319 return;
321 elsif Ignore_Errors then
322 Skip_Line;
323 C := Getc;
325 else
326 Fatal_Error;
327 end if;
328 end loop;
329 end Check_Unknown_Line;
331 ------------
332 -- Checkc --
333 ------------
335 procedure Checkc (C : Character) is
336 begin
337 if Nextc = C then
338 P := P + 1;
339 elsif Ignore_Errors then
340 P := P + 1;
341 else
342 Fatal_Error;
343 end if;
344 end Checkc;
346 -----------------
347 -- Fatal_Error --
348 -----------------
350 procedure Fatal_Error is
351 Ptr1 : Text_Ptr;
352 Ptr2 : Text_Ptr;
353 Col : Int;
355 procedure Wchar (C : Character);
356 -- Write a single character, replacing horizontal tab by spaces
358 procedure Wchar (C : Character) is
359 begin
360 if C = HT then
361 loop
362 Wchar (' ');
363 exit when Col mod 8 = 0;
364 end loop;
366 else
367 Write_Char (C);
368 Col := Col + 1;
369 end if;
370 end Wchar;
372 -- Start of processing for Fatal_Error
374 begin
375 if Err then
376 raise Bad_ALI_Format;
377 end if;
379 Set_Standard_Error;
380 Write_Str ("fatal error: file ");
381 Write_Name (F);
382 Write_Str (" is incorrectly formatted");
383 Write_Eol;
385 Write_Str ("make sure you are using consistent versions " &
387 -- Split the following line so that it can easily be transformed for
388 -- other back-ends where the compiler might have a different name.
390 "of gcc/gnatbind");
392 Write_Eol;
394 -- Find start of line
396 Ptr1 := P;
397 while Ptr1 > T'First
398 and then T (Ptr1 - 1) /= CR
399 and then T (Ptr1 - 1) /= LF
400 loop
401 Ptr1 := Ptr1 - 1;
402 end loop;
404 Write_Int (Int (Line));
405 Write_Str (". ");
407 if Line < 100 then
408 Write_Char (' ');
409 end if;
411 if Line < 10 then
412 Write_Char (' ');
413 end if;
415 Col := 0;
416 Ptr2 := Ptr1;
418 while Ptr2 < T'Last
419 and then T (Ptr2) /= CR
420 and then T (Ptr2) /= LF
421 loop
422 Wchar (T (Ptr2));
423 Ptr2 := Ptr2 + 1;
424 end loop;
426 Write_Eol;
428 Write_Str (" ");
429 Col := 0;
431 while Ptr1 < P loop
432 if T (Ptr1) = HT then
433 Wchar (HT);
434 else
435 Wchar (' ');
436 end if;
438 Ptr1 := Ptr1 + 1;
439 end loop;
441 Wchar ('|');
442 Write_Eol;
444 Exit_Program (E_Fatal);
445 end Fatal_Error;
447 ------------------------
448 -- Fatal_Error_Ignore --
449 ------------------------
451 procedure Fatal_Error_Ignore is
452 begin
453 if not Ignore_Errors then
454 Fatal_Error;
455 end if;
456 end Fatal_Error_Ignore;
458 -------------------
459 -- Get_File_Name --
460 -------------------
462 function Get_File_Name
463 (Lower : Boolean := False;
464 May_Be_Quoted : Boolean := False) return File_Name_Type
466 F : Name_Id;
468 begin
469 F := Get_Name (Ignore_Special => True,
470 May_Be_Quoted => May_Be_Quoted);
472 -- Convert file name to all lower case if file names are not case
473 -- sensitive. This ensures that we handle names in the canonical
474 -- lower case format, regardless of the actual case.
476 if Lower and not File_Names_Case_Sensitive then
477 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
478 return Name_Find;
479 else
480 return File_Name_Type (F);
481 end if;
482 end Get_File_Name;
484 --------------
485 -- Get_Name --
486 --------------
488 function Get_Name
489 (Ignore_Spaces : Boolean := False;
490 Ignore_Special : Boolean := False;
491 May_Be_Quoted : Boolean := False) return Name_Id
493 Char : Character;
495 begin
496 Name_Len := 0;
497 Skip_Space;
499 if At_Eol then
500 if Ignore_Errors then
501 return Error_Name;
502 else
503 Fatal_Error;
504 end if;
505 end if;
507 Char := Getc;
509 -- Deal with quoted characters
511 if May_Be_Quoted and then Char = '"' then
512 loop
513 if At_Eol then
514 if Ignore_Errors then
515 return Error_Name;
516 else
517 Fatal_Error;
518 end if;
519 end if;
521 Char := Getc;
523 if Char = '"' then
524 if At_Eol then
525 exit;
527 else
528 Char := Getc;
530 if Char /= '"' then
531 P := P - 1;
532 exit;
533 end if;
534 end if;
535 end if;
537 Add_Char_To_Name_Buffer (Char);
538 end loop;
540 -- Other than case of quoted character
542 else
543 P := P - 1;
544 loop
545 Add_Char_To_Name_Buffer (Getc);
547 exit when At_End_Of_Field and then not Ignore_Spaces;
549 if not Ignore_Special then
550 if Name_Buffer (1) = '"' then
551 exit when Name_Len > 1
552 and then Name_Buffer (Name_Len) = '"';
554 else
555 -- Terminate on parens or angle brackets or equal sign
557 exit when Nextc = '(' or else Nextc = ')'
558 or else Nextc = '{' or else Nextc = '}'
559 or else Nextc = '<' or else Nextc = '>'
560 or else Nextc = '=';
562 -- Terminate on comma
564 exit when Nextc = ',';
566 -- Terminate if left bracket not part of wide char
567 -- sequence Note that we only recognize brackets
568 -- notation so far ???
570 exit when Nextc = '[' and then T (P + 1) /= '"';
572 -- Terminate if right bracket not part of wide char
573 -- sequence.
575 exit when Nextc = ']' and then T (P - 1) /= '"';
576 end if;
577 end if;
578 end loop;
579 end if;
581 return Name_Find;
582 end Get_Name;
584 -------------------
585 -- Get_Unit_Name --
586 -------------------
588 function Get_Unit_Name return Unit_Name_Type is
589 begin
590 return Unit_Name_Type (Get_Name);
591 end Get_Unit_Name;
593 -------------
594 -- Get_Nat --
595 -------------
597 function Get_Nat return Nat is
598 V : Nat;
600 begin
601 Skip_Space;
603 -- Check if we are on a number. In the case of bad ALI files, this
604 -- may not be true.
606 if not (Nextc in '0' .. '9') then
607 Fatal_Error;
608 end if;
610 V := 0;
611 loop
612 V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0'));
614 exit when At_End_Of_Field;
615 exit when Nextc < '0' or else Nextc > '9';
616 end loop;
618 return V;
619 end Get_Nat;
621 ---------------
622 -- Get_Stamp --
623 ---------------
625 function Get_Stamp return Time_Stamp_Type is
626 T : Time_Stamp_Type;
627 Start : Integer;
629 begin
630 Skip_Space;
632 if At_Eol then
633 if Ignore_Errors then
634 return Dummy_Time_Stamp;
635 else
636 Fatal_Error;
637 end if;
638 end if;
640 -- Following reads old style time stamp missing first two digits
642 if Nextc in '7' .. '9' then
643 T (1) := '1';
644 T (2) := '9';
645 Start := 3;
647 -- Normal case of full year in time stamp
649 else
650 Start := 1;
651 end if;
653 for J in Start .. T'Last loop
654 T (J) := Getc;
655 end loop;
657 return T;
658 end Get_Stamp;
660 -----------------
661 -- Get_Typeref --
662 -----------------
664 procedure Get_Typeref
665 (Current_File_Num : Sdep_Id;
666 Ref : out Tref_Kind;
667 File_Num : out Sdep_Id;
668 Line : out Nat;
669 Ref_Type : out Character;
670 Col : out Nat;
671 Standard_Entity : out Name_Id)
673 N : Nat;
674 begin
675 case Nextc is
676 when '<' => Ref := Tref_Derived;
677 when '(' => Ref := Tref_Access;
678 when '{' => Ref := Tref_Type;
679 when others => Ref := Tref_None;
680 end case;
682 -- Case of typeref field present
684 if Ref /= Tref_None then
685 P := P + 1; -- skip opening bracket
687 if Nextc in 'a' .. 'z' then
688 File_Num := No_Sdep_Id;
689 Line := 0;
690 Ref_Type := ' ';
691 Col := 0;
692 Standard_Entity := Get_Name (Ignore_Spaces => True);
693 else
694 N := Get_Nat;
696 if Nextc = '|' then
697 File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
698 P := P + 1;
699 N := Get_Nat;
700 else
701 File_Num := Current_File_Num;
702 end if;
704 Line := N;
705 Ref_Type := Getc;
706 Col := Get_Nat;
707 Standard_Entity := No_Name;
708 end if;
710 -- ??? Temporary workaround for nested generics case:
711 -- 4i4 Directories{1|4I9[4|6[3|3]]}
712 -- See C918-002
714 declare
715 Nested_Brackets : Natural := 0;
717 begin
718 loop
719 case Nextc is
720 when '[' =>
721 Nested_Brackets := Nested_Brackets + 1;
722 when ']' =>
723 Nested_Brackets := Nested_Brackets - 1;
724 when others =>
725 if Nested_Brackets = 0 then
726 exit;
727 end if;
728 end case;
730 Skipc;
731 end loop;
732 end;
734 P := P + 1; -- skip closing bracket
735 Skip_Space;
737 -- No typeref entry present
739 else
740 File_Num := No_Sdep_Id;
741 Line := 0;
742 Ref_Type := ' ';
743 Col := 0;
744 Standard_Entity := No_Name;
745 end if;
746 end Get_Typeref;
748 ----------
749 -- Getc --
750 ----------
752 function Getc return Character is
753 begin
754 if P = T'Last then
755 return EOF;
756 else
757 P := P + 1;
758 return T (P - 1);
759 end if;
760 end Getc;
762 -----------
763 -- Nextc --
764 -----------
766 function Nextc return Character is
767 begin
768 return T (P);
769 end Nextc;
771 --------------
772 -- Skip_Eol --
773 --------------
775 procedure Skip_Eol is
776 begin
777 Skip_Space;
779 if not At_Eol then
780 if Ignore_Errors then
781 while not At_Eol loop
782 P := P + 1;
783 end loop;
784 else
785 Fatal_Error;
786 end if;
787 end if;
789 -- Loop to skip past blank lines (first time through skips this EOL)
791 while Nextc < ' ' and then Nextc /= EOF loop
792 if Nextc = LF then
793 Line := Line + 1;
794 end if;
796 P := P + 1;
797 end loop;
798 end Skip_Eol;
800 ---------------
801 -- Skip_Line --
802 ---------------
804 procedure Skip_Line is
805 begin
806 while not At_Eol loop
807 P := P + 1;
808 end loop;
810 Skip_Eol;
811 end Skip_Line;
813 ----------------
814 -- Skip_Space --
815 ----------------
817 procedure Skip_Space is
818 begin
819 while Nextc = ' ' or else Nextc = HT loop
820 P := P + 1;
821 end loop;
822 end Skip_Space;
824 -----------
825 -- Skipc --
826 -----------
828 procedure Skipc is
829 begin
830 if P /= T'Last then
831 P := P + 1;
832 end if;
833 end Skipc;
835 -- Start of processing for Scan_ALI
837 begin
838 First_Sdep_Entry := Sdep.Last + 1;
840 -- Acquire lines to be ignored
842 if Read_Xref then
843 Ignore :=
844 ('U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True);
846 -- Read_Lines parameter given
848 elsif Read_Lines /= "" then
849 Ignore := ('U' => False, others => True);
851 for J in Read_Lines'Range loop
852 Ignore (Read_Lines (J)) := False;
853 end loop;
855 -- Process Ignore_Lines parameter
857 else
858 Ignore := (others => False);
860 for J in Ignore_Lines'Range loop
861 pragma Assert (Ignore_Lines (J) /= 'U');
862 Ignore (Ignore_Lines (J)) := True;
863 end loop;
864 end if;
866 -- Setup ALI Table entry with appropriate defaults
868 ALIs.Increment_Last;
869 Id := ALIs.Last;
870 Set_Name_Table_Int (F, Int (Id));
872 ALIs.Table (Id) := (
873 Afile => F,
874 Compile_Errors => False,
875 First_Interrupt_State => Interrupt_States.Last + 1,
876 First_Sdep => No_Sdep_Id,
877 First_Specific_Dispatching => Specific_Dispatching.Last + 1,
878 First_Unit => No_Unit_Id,
879 GNATprove_Mode => False,
880 Last_Interrupt_State => Interrupt_States.Last,
881 Last_Sdep => No_Sdep_Id,
882 Last_Specific_Dispatching => Specific_Dispatching.Last,
883 Last_Unit => No_Unit_Id,
884 Locking_Policy => ' ',
885 Main_Priority => -1,
886 Main_CPU => -1,
887 Main_Program => None,
888 No_Object => False,
889 Normalize_Scalars => False,
890 Ofile_Full_Name => Full_Object_File_Name,
891 Partition_Elaboration_Policy => ' ',
892 Queuing_Policy => ' ',
893 Restrictions => No_Restrictions,
894 SAL_Interface => False,
895 Sfile => No_File,
896 SSO_Default => ' ',
897 Task_Dispatching_Policy => ' ',
898 Time_Slice_Value => -1,
899 WC_Encoding => 'b',
900 Unit_Exception_Table => False,
901 Ver => (others => ' '),
902 Ver_Len => 0,
903 Frontend_Exceptions => False,
904 Zero_Cost_Exceptions => False);
906 -- Now we acquire the input lines from the ALI file. Note that the
907 -- convention in the following code is that as we enter each section,
908 -- C is set to contain the first character of the following line.
910 C := Getc;
911 Check_Unknown_Line;
913 -- Acquire library version
915 if C /= 'V' then
917 -- The V line missing really indicates trouble, most likely it
918 -- means we don't have an ALI file at all, so here we give a
919 -- fatal error even if we are in Ignore_Errors mode.
921 Fatal_Error;
923 elsif Ignore ('V') then
924 Skip_Line;
926 else
927 Checkc (' ');
928 Skip_Space;
929 Checkc ('"');
931 for J in 1 .. Ver_Len_Max loop
932 C := Getc;
933 exit when C = '"';
934 ALIs.Table (Id).Ver (J) := C;
935 ALIs.Table (Id).Ver_Len := J;
936 end loop;
938 Skip_Eol;
939 end if;
941 C := Getc;
942 Check_Unknown_Line;
944 -- Acquire main program line if present
946 if C = 'M' then
947 if Ignore ('M') then
948 Skip_Line;
950 else
951 Checkc (' ');
952 Skip_Space;
954 C := Getc;
956 if C = 'F' then
957 ALIs.Table (Id).Main_Program := Func;
958 elsif C = 'P' then
959 ALIs.Table (Id).Main_Program := Proc;
960 else
961 P := P - 1;
962 Fatal_Error;
963 end if;
965 Skip_Space;
967 if not At_Eol then
968 if Nextc < 'A' then
969 ALIs.Table (Id).Main_Priority := Get_Nat;
970 end if;
972 Skip_Space;
974 if Nextc = 'T' then
975 P := P + 1;
976 Checkc ('=');
977 ALIs.Table (Id).Time_Slice_Value := Get_Nat;
978 end if;
980 Skip_Space;
982 if Nextc = 'C' then
983 P := P + 1;
984 Checkc ('=');
985 ALIs.Table (Id).Main_CPU := Get_Nat;
986 end if;
988 Skip_Space;
990 Checkc ('W');
991 Checkc ('=');
992 ALIs.Table (Id).WC_Encoding := Getc;
993 end if;
995 Skip_Eol;
996 end if;
998 C := Getc;
999 end if;
1001 -- Acquire argument lines
1003 First_Arg := Args.Last + 1;
1005 A_Loop : loop
1006 Check_Unknown_Line;
1007 exit A_Loop when C /= 'A';
1009 if Ignore ('A') then
1010 Skip_Line;
1012 else
1013 Checkc (' ');
1015 -- Scan out argument
1017 Name_Len := 0;
1018 while not At_Eol loop
1019 Add_Char_To_Name_Buffer (Getc);
1020 end loop;
1022 -- If -fstack-check, record that it occurred. Note that an
1023 -- additional string parameter can be specified, in the form of
1024 -- -fstack-check={no|generic|specific}. "no" means no checking,
1025 -- "generic" means force the use of old-style checking, and
1026 -- "specific" means use the best checking method.
1028 if Name_Len >= 13
1029 and then Name_Buffer (1 .. 13) = "-fstack-check"
1030 and then Name_Buffer (1 .. Name_Len) /= "-fstack-check=no"
1031 then
1032 Stack_Check_Switch_Set := True;
1033 end if;
1035 -- Store the argument
1037 Args.Increment_Last;
1038 Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len));
1040 Skip_Eol;
1041 end if;
1043 C := Getc;
1044 end loop A_Loop;
1046 -- Acquire P line
1048 Check_Unknown_Line;
1050 while C /= 'P' loop
1051 if Ignore_Errors then
1052 if C = EOF then
1053 Fatal_Error;
1054 else
1055 Skip_Line;
1056 C := Nextc;
1057 end if;
1058 else
1059 Fatal_Error;
1060 end if;
1061 end loop;
1063 if Ignore ('P') then
1064 Skip_Line;
1066 -- Process P line
1068 else
1069 NS_Found := False;
1071 while not At_Eol loop
1072 Checkc (' ');
1073 Skip_Space;
1074 C := Getc;
1076 -- Processing for CE
1078 if C = 'C' then
1079 Checkc ('E');
1080 ALIs.Table (Id).Compile_Errors := True;
1082 -- Processing for DB
1084 elsif C = 'D' then
1085 Checkc ('B');
1086 Detect_Blocking := True;
1088 -- Processing for Ex
1090 elsif C = 'E' then
1091 Partition_Elaboration_Policy_Specified := Getc;
1092 ALIs.Table (Id).Partition_Elaboration_Policy :=
1093 Partition_Elaboration_Policy_Specified;
1095 -- Processing for FX
1097 elsif C = 'F' then
1098 C := Getc;
1100 if C = 'X' then
1101 ALIs.Table (Id).Frontend_Exceptions := True;
1102 Frontend_Exceptions_Specified := True;
1103 else
1104 Fatal_Error_Ignore;
1105 end if;
1107 -- Processing for GP
1109 elsif C = 'G' then
1110 Checkc ('P');
1111 GNATprove_Mode_Specified := True;
1112 ALIs.Table (Id).GNATprove_Mode := True;
1114 -- Processing for Lx
1116 elsif C = 'L' then
1117 Locking_Policy_Specified := Getc;
1118 ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
1120 -- Processing for flags starting with N
1122 elsif C = 'N' then
1123 C := Getc;
1125 -- Processing for NO
1127 if C = 'O' then
1128 ALIs.Table (Id).No_Object := True;
1129 No_Object_Specified := True;
1131 -- Processing for NR
1133 elsif C = 'R' then
1134 No_Run_Time_Mode := True;
1135 Configurable_Run_Time_Mode := True;
1137 -- Processing for NS
1139 elsif C = 'S' then
1140 ALIs.Table (Id).Normalize_Scalars := True;
1141 Normalize_Scalars_Specified := True;
1142 NS_Found := True;
1144 -- Invalid switch starting with N
1146 else
1147 Fatal_Error_Ignore;
1148 end if;
1150 -- Processing for OH/OL
1152 elsif C = 'O' then
1153 C := Getc;
1155 if C = 'L' or else C = 'H' then
1156 ALIs.Table (Id).SSO_Default := C;
1157 SSO_Default_Specified := True;
1159 else
1160 Fatal_Error_Ignore;
1161 end if;
1163 -- Processing for Qx
1165 elsif C = 'Q' then
1166 Queuing_Policy_Specified := Getc;
1167 ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
1169 -- Processing for flags starting with S
1171 elsif C = 'S' then
1172 C := Getc;
1174 -- Processing for SL
1176 if C = 'L' then
1177 ALIs.Table (Id).SAL_Interface := True;
1179 -- Processing for SS
1181 elsif C = 'S' then
1182 Opt.Sec_Stack_Used := True;
1184 -- Invalid switch starting with S
1186 else
1187 Fatal_Error_Ignore;
1188 end if;
1190 -- Processing for Tx
1192 elsif C = 'T' then
1193 Task_Dispatching_Policy_Specified := Getc;
1194 ALIs.Table (Id).Task_Dispatching_Policy :=
1195 Task_Dispatching_Policy_Specified;
1197 -- Processing for switch starting with U
1199 elsif C = 'U' then
1200 C := Getc;
1202 -- Processing for UA
1204 if C = 'A' then
1205 Unreserve_All_Interrupts_Specified := True;
1207 -- Processing for UX
1209 elsif C = 'X' then
1210 ALIs.Table (Id).Unit_Exception_Table := True;
1212 -- Invalid switches starting with U
1214 else
1215 Fatal_Error_Ignore;
1216 end if;
1218 -- Processing for ZX
1220 elsif C = 'Z' then
1221 C := Getc;
1223 if C = 'X' then
1224 ALIs.Table (Id).Zero_Cost_Exceptions := True;
1225 Zero_Cost_Exceptions_Specified := True;
1226 else
1227 Fatal_Error_Ignore;
1228 end if;
1230 -- Invalid parameter
1232 else
1233 C := Getc;
1234 Fatal_Error_Ignore;
1235 end if;
1236 end loop;
1238 if not NS_Found then
1239 No_Normalize_Scalars_Specified := True;
1240 end if;
1242 Skip_Eol;
1243 end if;
1245 C := Getc;
1246 Check_Unknown_Line;
1248 -- Loop to skip to first restrictions line
1250 while C /= 'R' loop
1251 if Ignore_Errors then
1252 if C = EOF then
1253 Fatal_Error;
1254 else
1255 Skip_Line;
1256 C := Nextc;
1257 end if;
1258 else
1259 Fatal_Error;
1260 end if;
1261 end loop;
1263 -- Ignore all 'R' lines if that is required
1265 if Ignore ('R') then
1266 while C = 'R' loop
1267 Skip_Line;
1268 C := Getc;
1269 end loop;
1271 -- Here we process the restrictions lines (other than unit name cases)
1273 else
1274 Scan_Restrictions : declare
1275 Save_R : constant Restrictions_Info := Cumulative_Restrictions;
1276 -- Save cumulative restrictions in case we have a fatal error
1278 Bad_R_Line : exception;
1279 -- Signal bad restrictions line (raised on unexpected character)
1281 Typ : Character;
1282 R : Restriction_Id;
1283 N : Natural;
1285 begin
1286 -- Named restriction case
1288 if Nextc = 'N' then
1289 Skip_Line;
1290 C := Getc;
1292 -- Loop through RR and RV lines
1294 while C = 'R' and then Nextc /= ' ' loop
1295 Typ := Getc;
1296 Checkc (' ');
1298 -- Acquire restriction name
1300 Name_Len := 0;
1301 while not At_Eol and then Nextc /= '=' loop
1302 Name_Len := Name_Len + 1;
1303 Name_Buffer (Name_Len) := Getc;
1304 end loop;
1306 -- Now search list of restrictions to find match
1308 declare
1309 RN : String renames Name_Buffer (1 .. Name_Len);
1311 begin
1312 R := Restriction_Id'First;
1313 while R /= Not_A_Restriction_Id loop
1314 if Restriction_Id'Image (R) = RN then
1315 goto R_Found;
1316 end if;
1318 R := Restriction_Id'Succ (R);
1319 end loop;
1321 -- We don't recognize the restriction. This might be
1322 -- thought of as an error, and it really is, but we
1323 -- want to allow building with inconsistent versions
1324 -- of the binder and ali files (see comments at the
1325 -- start of package System.Rident), so we just ignore
1326 -- this situation.
1328 goto Done_With_Restriction_Line;
1329 end;
1331 <<R_Found>>
1333 case R is
1335 -- Boolean restriction case
1337 when All_Boolean_Restrictions =>
1338 case Typ is
1339 when 'V' =>
1340 ALIs.Table (Id).Restrictions.Violated (R) :=
1341 True;
1342 Cumulative_Restrictions.Violated (R) := True;
1344 when 'R' =>
1345 ALIs.Table (Id).Restrictions.Set (R) := True;
1346 Cumulative_Restrictions.Set (R) := True;
1348 when others =>
1349 raise Bad_R_Line;
1350 end case;
1352 -- Parameter restriction case
1354 when All_Parameter_Restrictions =>
1355 if At_Eol or else Nextc /= '=' then
1356 raise Bad_R_Line;
1357 else
1358 Skipc;
1359 end if;
1361 N := Natural (Get_Nat);
1363 case Typ is
1365 -- Restriction set
1367 when 'R' =>
1368 ALIs.Table (Id).Restrictions.Set (R) := True;
1369 ALIs.Table (Id).Restrictions.Value (R) := N;
1371 if Cumulative_Restrictions.Set (R) then
1372 Cumulative_Restrictions.Value (R) :=
1373 Integer'Min
1374 (Cumulative_Restrictions.Value (R), N);
1375 else
1376 Cumulative_Restrictions.Set (R) := True;
1377 Cumulative_Restrictions.Value (R) := N;
1378 end if;
1380 -- Restriction violated
1382 when 'V' =>
1383 ALIs.Table (Id).Restrictions.Violated (R) :=
1384 True;
1385 Cumulative_Restrictions.Violated (R) := True;
1386 ALIs.Table (Id).Restrictions.Count (R) := N;
1388 -- Checked Max_Parameter case
1390 if R in Checked_Max_Parameter_Restrictions then
1391 Cumulative_Restrictions.Count (R) :=
1392 Integer'Max
1393 (Cumulative_Restrictions.Count (R), N);
1395 -- Other checked parameter cases
1397 else
1398 declare
1399 pragma Unsuppress (Overflow_Check);
1401 begin
1402 Cumulative_Restrictions.Count (R) :=
1403 Cumulative_Restrictions.Count (R) + N;
1405 exception
1406 when Constraint_Error =>
1408 -- A constraint error comes from the
1409 -- addition. We reset to the maximum
1410 -- and indicate that the real value
1411 -- is now unknown.
1413 Cumulative_Restrictions.Value (R) :=
1414 Integer'Last;
1415 Cumulative_Restrictions.Unknown (R) :=
1416 True;
1417 end;
1418 end if;
1420 -- Deal with + case
1422 if Nextc = '+' then
1423 Skipc;
1424 ALIs.Table (Id).Restrictions.Unknown (R) :=
1425 True;
1426 Cumulative_Restrictions.Unknown (R) := True;
1427 end if;
1429 -- Other than 'R' or 'V'
1431 when others =>
1432 raise Bad_R_Line;
1433 end case;
1435 if not At_Eol then
1436 raise Bad_R_Line;
1437 end if;
1439 -- Bizarre error case NOT_A_RESTRICTION
1441 when Not_A_Restriction_Id =>
1442 raise Bad_R_Line;
1443 end case;
1445 if not At_Eol then
1446 raise Bad_R_Line;
1447 end if;
1449 <<Done_With_Restriction_Line>>
1450 Skip_Line;
1451 C := Getc;
1452 end loop;
1454 -- Positional restriction case
1456 else
1457 Checkc (' ');
1458 Skip_Space;
1460 -- Acquire information for boolean restrictions
1462 for R in All_Boolean_Restrictions loop
1463 C := Getc;
1465 case C is
1466 when 'v' =>
1467 ALIs.Table (Id).Restrictions.Violated (R) := True;
1468 Cumulative_Restrictions.Violated (R) := True;
1470 when 'r' =>
1471 ALIs.Table (Id).Restrictions.Set (R) := True;
1472 Cumulative_Restrictions.Set (R) := True;
1474 when 'n' =>
1475 null;
1477 when others =>
1478 raise Bad_R_Line;
1479 end case;
1480 end loop;
1482 -- Acquire information for parameter restrictions
1484 for RP in All_Parameter_Restrictions loop
1485 case Getc is
1486 when 'n' =>
1487 null;
1489 when 'r' =>
1490 ALIs.Table (Id).Restrictions.Set (RP) := True;
1492 declare
1493 N : constant Integer := Integer (Get_Nat);
1494 begin
1495 ALIs.Table (Id).Restrictions.Value (RP) := N;
1497 if Cumulative_Restrictions.Set (RP) then
1498 Cumulative_Restrictions.Value (RP) :=
1499 Integer'Min
1500 (Cumulative_Restrictions.Value (RP), N);
1501 else
1502 Cumulative_Restrictions.Set (RP) := True;
1503 Cumulative_Restrictions.Value (RP) := N;
1504 end if;
1505 end;
1507 when others =>
1508 raise Bad_R_Line;
1509 end case;
1511 -- Acquire restrictions violations information
1513 case Getc is
1515 when 'n' =>
1516 null;
1518 when 'v' =>
1519 ALIs.Table (Id).Restrictions.Violated (RP) := True;
1520 Cumulative_Restrictions.Violated (RP) := True;
1522 declare
1523 N : constant Integer := Integer (Get_Nat);
1525 begin
1526 ALIs.Table (Id).Restrictions.Count (RP) := N;
1528 if RP in Checked_Max_Parameter_Restrictions then
1529 Cumulative_Restrictions.Count (RP) :=
1530 Integer'Max
1531 (Cumulative_Restrictions.Count (RP), N);
1533 else
1534 declare
1535 pragma Unsuppress (Overflow_Check);
1537 begin
1538 Cumulative_Restrictions.Count (RP) :=
1539 Cumulative_Restrictions.Count (RP) + N;
1541 exception
1542 when Constraint_Error =>
1544 -- A constraint error comes from the add. We
1545 -- reset to the maximum and indicate that the
1546 -- real value is now unknown.
1548 Cumulative_Restrictions.Value (RP) :=
1549 Integer'Last;
1550 Cumulative_Restrictions.Unknown (RP) := True;
1551 end;
1552 end if;
1554 if Nextc = '+' then
1555 Skipc;
1556 ALIs.Table (Id).Restrictions.Unknown (RP) := True;
1557 Cumulative_Restrictions.Unknown (RP) := True;
1558 end if;
1559 end;
1561 when others =>
1562 raise Bad_R_Line;
1563 end case;
1564 end loop;
1566 if not At_Eol then
1567 raise Bad_R_Line;
1568 else
1569 Skip_Line;
1570 C := Getc;
1571 end if;
1572 end if;
1574 -- Here if error during scanning of restrictions line
1576 exception
1577 when Bad_R_Line =>
1579 -- In Ignore_Errors mode, undo any changes to restrictions
1580 -- from this unit, and continue on, skipping remaining R
1581 -- lines for this unit.
1583 if Ignore_Errors then
1584 Cumulative_Restrictions := Save_R;
1585 ALIs.Table (Id).Restrictions := No_Restrictions;
1587 loop
1588 Skip_Eol;
1589 C := Getc;
1590 exit when C /= 'R';
1591 end loop;
1593 -- In normal mode, this is a fatal error
1595 else
1596 Fatal_Error;
1597 end if;
1598 end Scan_Restrictions;
1599 end if;
1601 -- Acquire additional restrictions (No_Dependence) lines if present
1603 while C = 'R' loop
1604 if Ignore ('R') then
1605 Skip_Line;
1606 else
1607 Skip_Space;
1608 No_Deps.Append ((Id, Get_Name));
1609 Skip_Eol;
1610 end if;
1612 C := Getc;
1613 end loop;
1615 -- Acquire 'I' lines if present
1617 Check_Unknown_Line;
1619 while C = 'I' loop
1620 if Ignore ('I') then
1621 Skip_Line;
1623 else
1624 declare
1625 Int_Num : Nat;
1626 I_State : Character;
1627 Line_No : Nat;
1629 begin
1630 Int_Num := Get_Nat;
1631 Skip_Space;
1632 I_State := Getc;
1633 Line_No := Get_Nat;
1635 Interrupt_States.Append (
1636 (Interrupt_Id => Int_Num,
1637 Interrupt_State => I_State,
1638 IS_Pragma_Line => Line_No));
1640 ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last;
1641 Skip_Eol;
1642 end;
1643 end if;
1645 C := Getc;
1646 end loop;
1648 -- Acquire 'S' lines if present
1650 Check_Unknown_Line;
1652 while C = 'S' loop
1653 if Ignore ('S') then
1654 Skip_Line;
1656 else
1657 declare
1658 Policy : Character;
1659 First_Prio : Nat;
1660 Last_Prio : Nat;
1661 Line_No : Nat;
1663 begin
1664 Checkc (' ');
1665 Skip_Space;
1667 Policy := Getc;
1668 Skip_Space;
1669 First_Prio := Get_Nat;
1670 Last_Prio := Get_Nat;
1671 Line_No := Get_Nat;
1673 Specific_Dispatching.Append (
1674 (Dispatching_Policy => Policy,
1675 First_Priority => First_Prio,
1676 Last_Priority => Last_Prio,
1677 PSD_Pragma_Line => Line_No));
1679 ALIs.Table (Id).Last_Specific_Dispatching :=
1680 Specific_Dispatching.Last;
1682 Skip_Eol;
1683 end;
1684 end if;
1686 C := Getc;
1687 end loop;
1689 -- Loop to acquire unit entries
1691 U_Loop : loop
1692 Check_Unknown_Line;
1693 exit U_Loop when C /= 'U';
1695 -- Note: as per spec, we never ignore U lines
1697 Checkc (' ');
1698 Skip_Space;
1699 Units.Increment_Last;
1701 if ALIs.Table (Id).First_Unit = No_Unit_Id then
1702 ALIs.Table (Id).First_Unit := Units.Last;
1703 end if;
1705 declare
1706 UL : Unit_Record renames Units.Table (Units.Last);
1708 begin
1709 UL.Uname := Get_Unit_Name;
1710 UL.Predefined := Is_Predefined_Unit;
1711 UL.Internal := Is_Internal_Unit;
1712 UL.My_ALI := Id;
1713 UL.Sfile := Get_File_Name (Lower => True);
1714 UL.Pure := False;
1715 UL.Preelab := False;
1716 UL.No_Elab := False;
1717 UL.Shared_Passive := False;
1718 UL.RCI := False;
1719 UL.Remote_Types := False;
1720 UL.Serious_Errors := False;
1721 UL.Has_RACW := False;
1722 UL.Init_Scalars := False;
1723 UL.Is_Generic := False;
1724 UL.Icasing := Mixed_Case;
1725 UL.Kcasing := All_Lower_Case;
1726 UL.Dynamic_Elab := False;
1727 UL.Elaborate_Body := False;
1728 UL.Set_Elab_Entity := False;
1729 UL.Version := "00000000";
1730 UL.First_With := Withs.Last + 1;
1731 UL.First_Arg := First_Arg;
1732 UL.Elab_Position := 0;
1733 UL.SAL_Interface := ALIs.Table (Id).SAL_Interface;
1734 UL.Directly_Scanned := Directly_Scanned;
1735 UL.Body_Needed_For_SAL := False;
1736 UL.Elaborate_Body_Desirable := False;
1737 UL.Optimize_Alignment := 'O';
1738 UL.Has_Finalizer := False;
1740 if Debug_Flag_U then
1741 Write_Str (" ----> reading unit ");
1742 Write_Int (Int (Units.Last));
1743 Write_Str (" ");
1744 Write_Unit_Name (UL.Uname);
1745 Write_Str (" from file ");
1746 Write_Name (UL.Sfile);
1747 Write_Eol;
1748 end if;
1749 end;
1751 -- Check for duplicated unit in different files
1753 declare
1754 Info : constant Int := Get_Name_Table_Int
1755 (Units.Table (Units.Last).Uname);
1756 begin
1757 if Info /= 0
1758 and then Units.Table (Units.Last).Sfile /=
1759 Units.Table (Unit_Id (Info)).Sfile
1760 then
1761 -- If Err is set then ignore duplicate unit name. This is the
1762 -- case of a call from gnatmake, where the situation can arise
1763 -- from substitution of source files. In such situations, the
1764 -- processing in gnatmake will always result in any required
1765 -- recompilations in any case, and if we consider this to be
1766 -- an error we get strange cases (for example when a generic
1767 -- instantiation is replaced by a normal package) where we
1768 -- read the old ali file, decide to recompile, and then decide
1769 -- that the old and new ali files are incompatible.
1771 if Err then
1772 null;
1774 -- If Err is not set, then this is a fatal error. This is
1775 -- the case of being called from the binder, where we must
1776 -- definitely diagnose this as an error.
1778 else
1779 Set_Standard_Error;
1780 Write_Str ("error: duplicate unit name: ");
1781 Write_Eol;
1783 Write_Str ("error: unit """);
1784 Write_Unit_Name (Units.Table (Units.Last).Uname);
1785 Write_Str (""" found in file """);
1786 Write_Name_Decoded (Units.Table (Units.Last).Sfile);
1787 Write_Char ('"');
1788 Write_Eol;
1790 Write_Str ("error: unit """);
1791 Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
1792 Write_Str (""" found in file """);
1793 Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
1794 Write_Char ('"');
1795 Write_Eol;
1797 Exit_Program (E_Fatal);
1798 end if;
1799 end if;
1800 end;
1802 Set_Name_Table_Int
1803 (Units.Table (Units.Last).Uname, Int (Units.Last));
1805 -- Scan out possible version and other parameters
1807 loop
1808 Skip_Space;
1809 exit when At_Eol;
1810 C := Getc;
1812 -- Version field
1814 if C in '0' .. '9' or else C in 'a' .. 'f' then
1815 Units.Table (Units.Last).Version (1) := C;
1817 for J in 2 .. 8 loop
1818 C := Getc;
1819 Units.Table (Units.Last).Version (J) := C;
1820 end loop;
1822 -- BD/BN parameters
1824 elsif C = 'B' then
1825 C := Getc;
1827 if C = 'D' then
1828 Check_At_End_Of_Field;
1829 Units.Table (Units.Last).Elaborate_Body_Desirable := True;
1831 elsif C = 'N' then
1832 Check_At_End_Of_Field;
1833 Units.Table (Units.Last).Body_Needed_For_SAL := True;
1835 else
1836 Fatal_Error_Ignore;
1837 end if;
1839 -- DE parameter (Dynamic elaboration checks)
1841 elsif C = 'D' then
1842 C := Getc;
1844 if C = 'E' then
1845 Check_At_End_Of_Field;
1846 Units.Table (Units.Last).Dynamic_Elab := True;
1847 Dynamic_Elaboration_Checks_Specified := True;
1848 else
1849 Fatal_Error_Ignore;
1850 end if;
1852 -- EB/EE parameters
1854 elsif C = 'E' then
1855 C := Getc;
1857 if C = 'B' then
1858 Units.Table (Units.Last).Elaborate_Body := True;
1859 elsif C = 'E' then
1860 Units.Table (Units.Last).Set_Elab_Entity := True;
1861 else
1862 Fatal_Error_Ignore;
1863 end if;
1865 Check_At_End_Of_Field;
1867 -- GE parameter (generic)
1869 elsif C = 'G' then
1870 C := Getc;
1872 if C = 'E' then
1873 Check_At_End_Of_Field;
1874 Units.Table (Units.Last).Is_Generic := True;
1875 else
1876 Fatal_Error_Ignore;
1877 end if;
1879 -- IL/IS/IU parameters
1881 elsif C = 'I' then
1882 C := Getc;
1884 if C = 'L' then
1885 Units.Table (Units.Last).Icasing := All_Lower_Case;
1886 elsif C = 'S' then
1887 Units.Table (Units.Last).Init_Scalars := True;
1888 Initialize_Scalars_Used := True;
1889 elsif C = 'U' then
1890 Units.Table (Units.Last).Icasing := All_Upper_Case;
1891 else
1892 Fatal_Error_Ignore;
1893 end if;
1895 Check_At_End_Of_Field;
1897 -- KM/KU parameters
1899 elsif C = 'K' then
1900 C := Getc;
1902 if C = 'M' then
1903 Units.Table (Units.Last).Kcasing := Mixed_Case;
1904 elsif C = 'U' then
1905 Units.Table (Units.Last).Kcasing := All_Upper_Case;
1906 else
1907 Fatal_Error_Ignore;
1908 end if;
1910 Check_At_End_Of_Field;
1912 -- NE parameter
1914 elsif C = 'N' then
1915 C := Getc;
1917 if C = 'E' then
1918 Units.Table (Units.Last).No_Elab := True;
1919 Check_At_End_Of_Field;
1920 else
1921 Fatal_Error_Ignore;
1922 end if;
1924 -- PF/PR/PU/PK parameters
1926 elsif C = 'P' then
1927 C := Getc;
1929 if C = 'F' then
1930 Units.Table (Units.Last).Has_Finalizer := True;
1931 elsif C = 'R' then
1932 Units.Table (Units.Last).Preelab := True;
1933 elsif C = 'U' then
1934 Units.Table (Units.Last).Pure := True;
1935 elsif C = 'K' then
1936 Units.Table (Units.Last).Unit_Kind := 'p';
1937 else
1938 Fatal_Error_Ignore;
1939 end if;
1941 Check_At_End_Of_Field;
1943 -- OL/OO/OS/OT parameters
1945 elsif C = 'O' then
1946 C := Getc;
1948 if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then
1949 Units.Table (Units.Last).Optimize_Alignment := C;
1950 else
1951 Fatal_Error_Ignore;
1952 end if;
1954 Check_At_End_Of_Field;
1956 -- RC/RT parameters
1958 elsif C = 'R' then
1959 C := Getc;
1961 if C = 'C' then
1962 Units.Table (Units.Last).RCI := True;
1963 elsif C = 'T' then
1964 Units.Table (Units.Last).Remote_Types := True;
1965 elsif C = 'A' then
1966 Units.Table (Units.Last).Has_RACW := True;
1967 else
1968 Fatal_Error_Ignore;
1969 end if;
1971 Check_At_End_Of_Field;
1973 -- SE/SP/SU parameters
1975 elsif C = 'S' then
1976 C := Getc;
1978 if C = 'E' then
1979 Units.Table (Units.Last).Serious_Errors := True;
1980 elsif C = 'P' then
1981 Units.Table (Units.Last).Shared_Passive := True;
1982 elsif C = 'U' then
1983 Units.Table (Units.Last).Unit_Kind := 's';
1984 else
1985 Fatal_Error_Ignore;
1986 end if;
1988 Check_At_End_Of_Field;
1990 else
1991 C := Getc;
1992 Fatal_Error_Ignore;
1993 end if;
1994 end loop;
1996 Skip_Eol;
1998 C := Getc;
2000 -- Scan out With lines for this unit
2002 With_Loop : loop
2003 Check_Unknown_Line;
2004 exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z';
2006 if Ignore ('W') then
2007 Skip_Line;
2009 else
2010 Checkc (' ');
2011 Skip_Space;
2012 Withs.Increment_Last;
2013 Withs.Table (Withs.Last).Uname := Get_Unit_Name;
2014 Withs.Table (Withs.Last).Elaborate := False;
2015 Withs.Table (Withs.Last).Elaborate_All := False;
2016 Withs.Table (Withs.Last).Elab_Desirable := False;
2017 Withs.Table (Withs.Last).Elab_All_Desirable := False;
2018 Withs.Table (Withs.Last).SAL_Interface := False;
2019 Withs.Table (Withs.Last).Limited_With := (C = 'Y');
2020 Withs.Table (Withs.Last).Implicit_With_From_Instantiation
2021 := (C = 'Z');
2023 -- Generic case with no object file available
2025 if At_Eol then
2026 Withs.Table (Withs.Last).Sfile := No_File;
2027 Withs.Table (Withs.Last).Afile := No_File;
2029 -- Normal case
2031 else
2032 Withs.Table (Withs.Last).Sfile := Get_File_Name
2033 (Lower => True);
2034 Withs.Table (Withs.Last).Afile := Get_File_Name
2035 (Lower => True);
2037 -- Scan out possible E, EA, ED, and AD parameters
2039 while not At_Eol loop
2040 Skip_Space;
2042 if Nextc = 'A' then
2043 P := P + 1;
2044 Checkc ('D');
2045 Check_At_End_Of_Field;
2047 -- Store AD indication unless ignore required
2049 if not Ignore_ED then
2050 Withs.Table (Withs.Last).Elab_All_Desirable := True;
2051 end if;
2053 elsif Nextc = 'E' then
2054 P := P + 1;
2056 if At_End_Of_Field then
2057 Withs.Table (Withs.Last).Elaborate := True;
2059 elsif Nextc = 'A' then
2060 P := P + 1;
2061 Check_At_End_Of_Field;
2062 Withs.Table (Withs.Last).Elaborate_All := True;
2064 else
2065 Checkc ('D');
2066 Check_At_End_Of_Field;
2068 -- Store ED indication unless ignore required
2070 if not Ignore_ED then
2071 Withs.Table (Withs.Last).Elab_Desirable :=
2072 True;
2073 end if;
2074 end if;
2076 else
2077 Fatal_Error;
2078 end if;
2079 end loop;
2080 end if;
2082 Skip_Eol;
2083 end if;
2085 C := Getc;
2086 end loop With_Loop;
2088 Units.Table (Units.Last).Last_With := Withs.Last;
2089 Units.Table (Units.Last).Last_Arg := Args.Last;
2091 -- If there are linker options lines present, scan them
2093 Name_Len := 0;
2095 Linker_Options_Loop : loop
2096 Check_Unknown_Line;
2097 exit Linker_Options_Loop when C /= 'L';
2099 if Ignore ('L') then
2100 Skip_Line;
2102 else
2103 Checkc (' ');
2104 Skip_Space;
2105 Checkc ('"');
2107 loop
2108 C := Getc;
2110 if C < Character'Val (16#20#)
2111 or else C > Character'Val (16#7E#)
2112 then
2113 Fatal_Error_Ignore;
2115 elsif C = '{' then
2116 C := Character'Val (0);
2118 declare
2119 V : Natural;
2121 begin
2122 V := 0;
2123 for J in 1 .. 2 loop
2124 C := Getc;
2126 if C in '0' .. '9' then
2127 V := V * 16 +
2128 Character'Pos (C) -
2129 Character'Pos ('0');
2131 elsif C in 'A' .. 'F' then
2132 V := V * 16 +
2133 Character'Pos (C) -
2134 Character'Pos ('A') +
2137 else
2138 Fatal_Error_Ignore;
2139 end if;
2140 end loop;
2142 Checkc ('}');
2143 Add_Char_To_Name_Buffer (Character'Val (V));
2144 end;
2146 else
2147 if C = '"' then
2148 exit when Nextc /= '"';
2149 C := Getc;
2150 end if;
2152 Add_Char_To_Name_Buffer (C);
2153 end if;
2154 end loop;
2156 Add_Char_To_Name_Buffer (NUL);
2157 Skip_Eol;
2158 end if;
2160 C := Getc;
2161 end loop Linker_Options_Loop;
2163 -- Store the linker options entry if one was found
2165 if Name_Len /= 0 then
2166 Linker_Options.Increment_Last;
2168 Linker_Options.Table (Linker_Options.Last).Name :=
2169 Name_Enter;
2171 Linker_Options.Table (Linker_Options.Last).Unit :=
2172 Units.Last;
2174 Linker_Options.Table (Linker_Options.Last).Internal_File :=
2175 Is_Internal_File_Name (F);
2177 Linker_Options.Table (Linker_Options.Last).Original_Pos :=
2178 Linker_Options.Last;
2179 end if;
2181 -- If there are notes present, scan them
2183 Notes_Loop : loop
2184 Check_Unknown_Line;
2185 exit Notes_Loop when C /= 'N';
2187 if Ignore ('N') then
2188 Skip_Line;
2190 else
2191 Checkc (' ');
2193 Notes.Increment_Last;
2194 Notes.Table (Notes.Last).Pragma_Type := Getc;
2195 Notes.Table (Notes.Last).Pragma_Line := Get_Nat;
2196 Checkc (':');
2197 Notes.Table (Notes.Last).Pragma_Col := Get_Nat;
2199 if not At_Eol and then Nextc = ':' then
2200 Checkc (':');
2201 Notes.Table (Notes.Last).Pragma_Source_File :=
2202 Get_File_Name (Lower => True);
2203 else
2204 Notes.Table (Notes.Last).Pragma_Source_File :=
2205 Units.Table (Units.Last).Sfile;
2206 end if;
2208 if At_Eol then
2209 Notes.Table (Notes.Last).Pragma_Args := No_Name;
2211 else
2212 -- Note: can't use Get_Name here as the remainder of the
2213 -- line is unstructured text whose syntax depends on the
2214 -- particular pragma used.
2216 Checkc (' ');
2218 Name_Len := 0;
2219 while not At_Eol loop
2220 Add_Char_To_Name_Buffer (Getc);
2221 end loop;
2222 end if;
2224 Skip_Eol;
2225 end if;
2227 C := Getc;
2228 end loop Notes_Loop;
2229 end loop U_Loop;
2231 -- End loop through units for one ALI file
2233 ALIs.Table (Id).Last_Unit := Units.Last;
2234 ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile;
2236 -- Set types of the units (there can be at most 2 of them)
2238 if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then
2239 Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body;
2240 Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec;
2242 else
2243 -- Deal with body only and spec only cases, note that the reason we
2244 -- do our own checking of the name (rather than using Is_Body_Name)
2245 -- is that Uname drags in far too much compiler junk.
2247 Get_Name_String (Units.Table (Units.Last).Uname);
2249 if Name_Buffer (Name_Len) = 'b' then
2250 Units.Table (Units.Last).Utype := Is_Body_Only;
2251 else
2252 Units.Table (Units.Last).Utype := Is_Spec_Only;
2253 end if;
2254 end if;
2256 -- Scan out external version references and put in hash table
2258 E_Loop : loop
2259 Check_Unknown_Line;
2260 exit E_Loop when C /= 'E';
2262 if Ignore ('E') then
2263 Skip_Line;
2265 else
2266 Checkc (' ');
2267 Skip_Space;
2269 Name_Len := 0;
2270 Name_Len := 0;
2271 loop
2272 C := Getc;
2274 if C < ' ' then
2275 Fatal_Error;
2276 end if;
2278 exit when At_End_Of_Field;
2279 Add_Char_To_Name_Buffer (C);
2280 end loop;
2282 Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
2283 Skip_Eol;
2284 end if;
2286 C := Getc;
2287 end loop E_Loop;
2289 -- Scan out source dependency lines for this ALI file
2291 ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
2293 D_Loop : loop
2294 Check_Unknown_Line;
2295 exit D_Loop when C /= 'D';
2297 if Ignore ('D') then
2298 Skip_Line;
2300 else
2301 Checkc (' ');
2302 Skip_Space;
2303 Sdep.Increment_Last;
2305 -- In the following call, Lower is not set to True, this is either
2306 -- a bug, or it deserves a special comment as to why this is so???
2308 -- The file/path name may be quoted
2310 Sdep.Table (Sdep.Last).Sfile :=
2311 Get_File_Name (May_Be_Quoted => True);
2313 Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
2314 Sdep.Table (Sdep.Last).Dummy_Entry :=
2315 (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
2317 -- Acquire checksum value
2319 Skip_Space;
2321 declare
2322 Ctr : Natural;
2323 Chk : Word;
2325 begin
2326 Ctr := 0;
2327 Chk := 0;
2329 loop
2330 exit when At_Eol or else Ctr = 8;
2332 if Nextc in '0' .. '9' then
2333 Chk := Chk * 16 +
2334 Character'Pos (Nextc) - Character'Pos ('0');
2336 elsif Nextc in 'a' .. 'f' then
2337 Chk := Chk * 16 +
2338 Character'Pos (Nextc) - Character'Pos ('a') + 10;
2340 else
2341 exit;
2342 end if;
2344 Ctr := Ctr + 1;
2345 P := P + 1;
2346 end loop;
2348 if Ctr = 8 and then At_End_Of_Field then
2349 Sdep.Table (Sdep.Last).Checksum := Chk;
2350 else
2351 Fatal_Error;
2352 end if;
2353 end;
2355 -- Acquire (sub)unit and reference file name entries
2357 Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
2358 Sdep.Table (Sdep.Last).Unit_Name := No_Name;
2359 Sdep.Table (Sdep.Last).Rfile :=
2360 Sdep.Table (Sdep.Last).Sfile;
2361 Sdep.Table (Sdep.Last).Start_Line := 1;
2363 if not At_Eol then
2364 Skip_Space;
2366 -- Here for (sub)unit name
2368 if Nextc not in '0' .. '9' then
2369 Name_Len := 0;
2370 while not At_End_Of_Field loop
2371 Add_Char_To_Name_Buffer (Getc);
2372 end loop;
2374 -- Set the (sub)unit name. Note that we use Name_Find rather
2375 -- than Name_Enter here as the subunit name may already
2376 -- have been put in the name table by the Project Manager.
2378 if Name_Len <= 2
2379 or else Name_Buffer (Name_Len - 1) /= '%'
2380 then
2381 Sdep.Table (Sdep.Last).Subunit_Name := Name_Find;
2382 else
2383 Name_Len := Name_Len - 2;
2384 Sdep.Table (Sdep.Last).Unit_Name := Name_Find;
2385 end if;
2387 Skip_Space;
2388 end if;
2390 -- Here for reference file name entry
2392 if Nextc in '0' .. '9' then
2393 Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
2394 Checkc (':');
2396 Name_Len := 0;
2398 while not At_End_Of_Field loop
2399 Add_Char_To_Name_Buffer (Getc);
2400 end loop;
2402 Sdep.Table (Sdep.Last).Rfile := Name_Enter;
2403 end if;
2404 end if;
2406 Skip_Eol;
2407 end if;
2409 C := Getc;
2410 end loop D_Loop;
2412 ALIs.Table (Id).Last_Sdep := Sdep.Last;
2414 -- We must at this stage be at an Xref line or the end of file
2416 if C = EOF then
2417 return Id;
2418 end if;
2420 Check_Unknown_Line;
2422 if C /= 'X' then
2423 Fatal_Error;
2424 end if;
2426 -- If we are ignoring Xref sections we are done (we ignore all
2427 -- remaining lines since only xref related lines follow X).
2429 if Ignore ('X') and then not Debug_Flag_X then
2430 return Id;
2431 end if;
2433 -- Loop through Xref sections
2435 X_Loop : loop
2436 Check_Unknown_Line;
2437 exit X_Loop when C /= 'X';
2439 -- Make new entry in section table
2441 Xref_Section.Increment_Last;
2443 Read_Refs_For_One_File : declare
2444 XS : Xref_Section_Record renames
2445 Xref_Section.Table (Xref_Section.Last);
2447 Current_File_Num : Sdep_Id;
2448 -- Keeps track of the current file number (changed by nn|)
2450 begin
2451 XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
2452 XS.File_Name := Get_File_Name;
2453 XS.First_Entity := Xref_Entity.Last + 1;
2455 Current_File_Num := XS.File_Num;
2457 Skip_Space;
2459 Skip_Eol;
2460 C := Nextc;
2462 -- Loop through Xref entities
2464 while C /= 'X' and then C /= EOF loop
2465 Xref_Entity.Increment_Last;
2467 Read_Refs_For_One_Entity : declare
2468 XE : Xref_Entity_Record renames
2469 Xref_Entity.Table (Xref_Entity.Last);
2470 N : Nat;
2472 procedure Read_Instantiation_Reference;
2473 -- Acquire instantiation reference. Caller has checked
2474 -- that current character is '[' and on return the cursor
2475 -- is skipped past the corresponding closing ']'.
2477 ----------------------------------
2478 -- Read_Instantiation_Reference --
2479 ----------------------------------
2481 procedure Read_Instantiation_Reference is
2482 Local_File_Num : Sdep_Id := Current_File_Num;
2484 begin
2485 Xref.Increment_Last;
2487 declare
2488 XR : Xref_Record renames Xref.Table (Xref.Last);
2490 begin
2491 P := P + 1; -- skip [
2492 N := Get_Nat;
2494 if Nextc = '|' then
2495 XR.File_Num :=
2496 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2497 Local_File_Num := XR.File_Num;
2498 P := P + 1;
2499 N := Get_Nat;
2501 else
2502 XR.File_Num := Local_File_Num;
2503 end if;
2505 XR.Line := N;
2506 XR.Rtype := ' ';
2507 XR.Col := 0;
2509 -- Recursive call for next reference
2511 if Nextc = '[' then
2512 pragma Warnings (Off); -- kill recursion warning
2513 Read_Instantiation_Reference;
2514 pragma Warnings (On);
2515 end if;
2517 -- Skip closing bracket after recursive call
2519 P := P + 1;
2520 end;
2521 end Read_Instantiation_Reference;
2523 -- Start of processing for Read_Refs_For_One_Entity
2525 begin
2526 XE.Line := Get_Nat;
2527 XE.Etype := Getc;
2528 XE.Col := Get_Nat;
2530 case Getc is
2531 when '*' =>
2532 XE.Visibility := Global;
2533 when '+' =>
2534 XE.Visibility := Static;
2535 when others =>
2536 XE.Visibility := Other;
2537 end case;
2539 XE.Entity := Get_Name;
2541 -- Handle the information about generic instantiations
2543 if Nextc = '[' then
2544 Skipc; -- Opening '['
2545 N := Get_Nat;
2547 if Nextc /= '|' then
2548 XE.Iref_File_Num := Current_File_Num;
2549 XE.Iref_Line := N;
2550 else
2551 XE.Iref_File_Num :=
2552 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2553 Skipc;
2554 XE.Iref_Line := Get_Nat;
2555 end if;
2557 if Getc /= ']' then
2558 Fatal_Error;
2559 end if;
2561 else
2562 XE.Iref_File_Num := No_Sdep_Id;
2563 XE.Iref_Line := 0;
2564 end if;
2566 Current_File_Num := XS.File_Num;
2568 -- Renaming reference is present
2570 if Nextc = '=' then
2571 P := P + 1;
2572 XE.Rref_Line := Get_Nat;
2574 if Getc /= ':' then
2575 Fatal_Error;
2576 end if;
2578 XE.Rref_Col := Get_Nat;
2580 -- No renaming reference present
2582 else
2583 XE.Rref_Line := 0;
2584 XE.Rref_Col := 0;
2585 end if;
2587 Skip_Space;
2589 XE.Oref_File_Num := No_Sdep_Id;
2590 XE.Tref_File_Num := No_Sdep_Id;
2591 XE.Tref := Tref_None;
2592 XE.First_Xref := Xref.Last + 1;
2594 -- Loop to check for additional info present
2596 loop
2597 declare
2598 Ref : Tref_Kind;
2599 File : Sdep_Id;
2600 Line : Nat;
2601 Typ : Character;
2602 Col : Nat;
2603 Std : Name_Id;
2605 begin
2606 Get_Typeref
2607 (Current_File_Num, Ref, File, Line, Typ, Col, Std);
2608 exit when Ref = Tref_None;
2610 -- Do we have an overriding procedure?
2612 if Ref = Tref_Derived and then Typ = 'p' then
2613 XE.Oref_File_Num := File;
2614 XE.Oref_Line := Line;
2615 XE.Oref_Col := Col;
2617 -- Arrays never override anything, and <> points to
2618 -- the index types instead
2620 elsif Ref = Tref_Derived and then XE.Etype = 'A' then
2622 -- Index types are stored in the list of references
2624 Xref.Increment_Last;
2626 declare
2627 XR : Xref_Record renames Xref.Table (Xref.Last);
2628 begin
2629 XR.File_Num := File;
2630 XR.Line := Line;
2631 XR.Rtype := Array_Index_Reference;
2632 XR.Col := Col;
2633 XR.Name := Std;
2634 end;
2636 -- Interfaces are stored in the list of references,
2637 -- although the parent type itself is stored in XE.
2638 -- The first interface (when there are only
2639 -- interfaces) is stored in XE.Tref*)
2641 elsif Ref = Tref_Derived
2642 and then Typ = 'R'
2643 and then XE.Tref_File_Num /= No_Sdep_Id
2644 then
2645 Xref.Increment_Last;
2647 declare
2648 XR : Xref_Record renames Xref.Table (Xref.Last);
2649 begin
2650 XR.File_Num := File;
2651 XR.Line := Line;
2652 XR.Rtype := Interface_Reference;
2653 XR.Col := Col;
2654 XR.Name := Std;
2655 end;
2657 else
2658 XE.Tref := Ref;
2659 XE.Tref_File_Num := File;
2660 XE.Tref_Line := Line;
2661 XE.Tref_Type := Typ;
2662 XE.Tref_Col := Col;
2663 XE.Tref_Standard_Entity := Std;
2664 end if;
2665 end;
2666 end loop;
2668 -- Loop through cross-references for this entity
2670 loop
2671 Skip_Space;
2673 if At_Eol then
2674 Skip_Eol;
2675 exit when Nextc /= '.';
2676 P := P + 1;
2677 end if;
2679 Xref.Increment_Last;
2681 declare
2682 XR : Xref_Record renames Xref.Table (Xref.Last);
2684 begin
2685 N := Get_Nat;
2687 if Nextc = '|' then
2688 XR.File_Num :=
2689 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2690 Current_File_Num := XR.File_Num;
2691 P := P + 1;
2692 N := Get_Nat;
2693 else
2694 XR.File_Num := Current_File_Num;
2695 end if;
2697 XR.Line := N;
2698 XR.Rtype := Getc;
2700 -- Imported entities reference as in:
2701 -- 494b<c,__gnat_copy_attribs>25
2703 if Nextc = '<' then
2704 Skipc;
2705 XR.Imported_Lang := Get_Name;
2707 pragma Assert (Nextc = ',');
2708 Skipc;
2710 XR.Imported_Name := Get_Name;
2712 pragma Assert (Nextc = '>');
2713 Skipc;
2715 else
2716 XR.Imported_Lang := No_Name;
2717 XR.Imported_Name := No_Name;
2718 end if;
2720 XR.Col := Get_Nat;
2722 if Nextc = '[' then
2723 Read_Instantiation_Reference;
2724 end if;
2725 end;
2726 end loop;
2728 -- Record last cross-reference
2730 XE.Last_Xref := Xref.Last;
2731 C := Nextc;
2733 exception
2734 when Bad_ALI_Format =>
2736 -- If ignoring errors, then we skip a line with an
2737 -- unexpected error, and try to continue subsequent
2738 -- xref lines.
2740 if Ignore_Errors then
2741 Xref_Entity.Decrement_Last;
2742 Skip_Line;
2743 C := Nextc;
2745 -- Otherwise, we reraise the fatal exception
2747 else
2748 raise;
2749 end if;
2750 end Read_Refs_For_One_Entity;
2751 end loop;
2753 -- Record last entity
2755 XS.Last_Entity := Xref_Entity.Last;
2757 end Read_Refs_For_One_File;
2759 C := Getc;
2760 end loop X_Loop;
2762 -- Here after dealing with xref sections
2764 -- Ignore remaining lines, which belong to an additional section of the
2765 -- ALI file not considered here (like SCO or SPARK information).
2767 Check_Unknown_Line;
2769 return Id;
2771 exception
2772 when Bad_ALI_Format =>
2773 return No_ALI_Id;
2774 end Scan_ALI;
2776 ---------
2777 -- SEq --
2778 ---------
2780 function SEq (F1, F2 : String_Ptr) return Boolean is
2781 begin
2782 return F1.all = F2.all;
2783 end SEq;
2785 -----------
2786 -- SHash --
2787 -----------
2789 function SHash (S : String_Ptr) return Vindex is
2790 H : Word;
2792 begin
2793 H := 0;
2794 for J in S.all'Range loop
2795 H := H * 2 + Character'Pos (S (J));
2796 end loop;
2798 return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));
2799 end SHash;
2801 end ALI;