PR target/16201
[official-gcc.git] / gcc / ada / ali.adb
blob0f1820555719dbe20174bef8c47e7ae4d2141da6
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- A L I --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2004 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 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
27 with Butil; use Butil;
28 with Debug; use Debug;
29 with Fname; use Fname;
30 with Namet; use Namet;
31 with Opt; use Opt;
32 with Osint; use Osint;
33 with Output; use Output;
35 package body ALI is
37 use ASCII;
38 -- Make control characters visible
40 -- The following variable records which characters currently are
41 -- used as line type markers in the ALI file. This is used in
42 -- Scan_ALI to detect (or skip) invalid lines.
44 Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean :=
45 ('V' => True, -- version
46 'M' => True, -- main program
47 'A' => True, -- argument
48 'P' => True, -- program
49 'R' => True, -- restriction
50 'I' => True, -- interrupt
51 'U' => True, -- unit
52 'W' => True, -- with
53 'L' => True, -- linker option
54 'E' => True, -- external
55 'D' => True, -- dependency
56 'X' => True, -- xref
57 others => False);
59 --------------------
60 -- Initialize_ALI --
61 --------------------
63 procedure Initialize_ALI is
64 begin
65 -- When (re)initializing ALI data structures the ALI user expects to
66 -- get a fresh set of data structures. Thus we first need to erase the
67 -- marks put in the name table by the previous set of ALI routine calls.
68 -- These two loops are empty and harmless the first time in.
70 for J in ALIs.First .. ALIs.Last loop
71 Set_Name_Table_Info (ALIs.Table (J).Afile, 0);
72 end loop;
74 for J in Units.First .. Units.Last loop
75 Set_Name_Table_Info (Units.Table (J).Uname, 0);
76 end loop;
78 -- Free argument table strings
80 for J in Args.First .. Args.Last loop
81 Free (Args.Table (J));
82 end loop;
84 -- Initialize all tables
86 ALIs.Init;
87 No_Deps.Init;
88 Units.Init;
89 Withs.Init;
90 Sdep.Init;
91 Linker_Options.Init;
92 Xref_Section.Init;
93 Xref_Entity.Init;
94 Xref.Init;
95 Version_Ref.Reset;
97 -- Add dummy zero'th item in Linker_Options for the sort function
99 Linker_Options.Increment_Last;
101 -- Initialize global variables recording cumulative options in all
102 -- ALI files that are read for a given processing run in gnatbind.
104 Dynamic_Elaboration_Checks_Specified := False;
105 Float_Format_Specified := ' ';
106 Locking_Policy_Specified := ' ';
107 No_Normalize_Scalars_Specified := False;
108 No_Object_Specified := False;
109 Normalize_Scalars_Specified := False;
110 Queuing_Policy_Specified := ' ';
111 Static_Elaboration_Model_Used := False;
112 Task_Dispatching_Policy_Specified := ' ';
113 Unreserve_All_Interrupts_Specified := False;
114 Zero_Cost_Exceptions_Specified := False;
115 end Initialize_ALI;
117 --------------
118 -- Scan_ALI --
119 --------------
121 function Scan_ALI
122 (F : File_Name_Type;
123 T : Text_Buffer_Ptr;
124 Ignore_ED : Boolean;
125 Err : Boolean;
126 Read_Xref : Boolean := False;
127 Read_Lines : String := "";
128 Ignore_Lines : String := "X";
129 Ignore_Errors : Boolean := False) return ALI_Id
131 P : Text_Ptr := T'First;
132 Line : Logical_Line_Number := 1;
133 Id : ALI_Id;
134 C : Character;
135 NS_Found : Boolean;
136 First_Arg : Arg_Id;
138 Ignore : array (Character range 'A' .. 'Z') of Boolean;
139 -- Ignore (X) is set to True if lines starting with X are to
140 -- be ignored by Scan_ALI and skipped, and False if the lines
141 -- are to be read and processed.
143 Restrictions_Initial : Rident.Restrictions_Info;
144 pragma Warnings (Off, Restrictions_Initial);
145 -- This variable, which should really be a constant (but that's not
146 -- allowed by the language) is used only for initialization, and the
147 -- reason we are declaring it is to get the default initialization
148 -- set for the object.
150 Bad_ALI_Format : exception;
151 -- Exception raised by Fatal_Error if Err is True
153 function At_Eol return Boolean;
154 -- Test if at end of line
156 function At_End_Of_Field return Boolean;
157 -- Test if at end of line, or if at blank or horizontal tab
159 procedure Check_At_End_Of_Field;
160 -- Check if we are at end of field, fatal error if not
162 procedure Checkc (C : Character);
163 -- Check next character is C. If so bump past it, if not fatal error
165 procedure Check_Unknown_Line;
166 -- If Ignore_Errors mode, then checks C to make sure that it is not
167 -- an unknown ALI line type characters, and if so, skips lines
168 -- until the first character of the line is one of these characters,
169 -- at which point it does a Getc to put that character in C. The
170 -- call has no effect if C is already an appropriate character.
171 -- If not in Ignore_Errors mode, a fatal error is signalled if the
172 -- line is unknown. Note that if C is an EOL on entry, the line is
173 -- skipped (it is assumed that blank lines are never significant).
174 -- If C is EOF on entry, the call has no effect (it is assumed that
175 -- the caller will properly handle this case).
177 procedure Fatal_Error;
178 -- Generate fatal error message for badly formatted ALI file if
179 -- Err is false, or raise Bad_ALI_Format if Err is True.
181 procedure Fatal_Error_Ignore;
182 pragma Inline (Fatal_Error_Ignore);
183 -- In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error
185 function Getc return Character;
186 -- Get next character, bumping P past the character obtained
188 function Get_Name
189 (Lower : Boolean := False;
190 Ignore_Spaces : Boolean := False) return Name_Id;
191 -- Skip blanks, then scan out a name (name is left in Name_Buffer with
192 -- length in Name_Len, as well as being returned in Name_Id form).
193 -- If Lower is set to True then the Name_Buffer will be converted to
194 -- all lower case, for systems where file names are not case sensitive.
195 -- This ensures that gnatbind works correctly regardless of the case
196 -- of the file name on all systems. The name is terminated by a either
197 -- white space (when Ignore_Spaces is False) or a typeref bracket or
198 -- an equal sign except for the special case of an operator name
199 -- starting with a double quite which is terminated by another double
200 -- quote.
202 function Get_Nat return Nat;
203 -- Skip blanks, then scan out an unsigned integer value in Nat range
205 function Get_Stamp return Time_Stamp_Type;
206 -- Skip blanks, then scan out a time stamp
208 function Nextc return Character;
209 -- Return current character without modifying pointer P
211 procedure Skip_Eol;
212 -- Skip past spaces, then skip past end of line (fatal error if not
213 -- at end of line). Also skips past any following blank lines.
215 procedure Skip_Line;
216 -- Skip rest of current line and any following blank lines
218 procedure Skip_Space;
219 -- Skip past white space (blanks or horizontal tab)
221 procedure Skipc;
222 -- Skip past next character, does not affect value in C. This call
223 -- is like calling Getc and ignoring the returned result.
225 ---------------------
226 -- At_End_Of_Field --
227 ---------------------
229 function At_End_Of_Field return Boolean is
230 begin
231 return Nextc <= ' ';
232 end At_End_Of_Field;
234 ------------
235 -- At_Eol --
236 ------------
238 function At_Eol return Boolean is
239 begin
240 return Nextc = EOF or else Nextc = CR or else Nextc = LF;
241 end At_Eol;
243 ---------------------------
244 -- Check_At_End_Of_Field --
245 ---------------------------
247 procedure Check_At_End_Of_Field is
248 begin
249 if not At_End_Of_Field then
250 if Ignore_Errors then
251 while Nextc > ' ' loop
252 P := P + 1;
253 end loop;
254 else
255 Fatal_Error;
256 end if;
257 end if;
258 end Check_At_End_Of_Field;
260 ------------
261 -- Checkc --
262 ------------
264 procedure Checkc (C : Character) is
265 begin
266 if Nextc = C then
267 P := P + 1;
268 elsif Ignore_Errors then
269 P := P + 1;
270 else
271 Fatal_Error;
272 end if;
273 end Checkc;
275 ------------------------
276 -- Check_Unknown_Line --
277 ------------------------
279 procedure Check_Unknown_Line is
280 begin
281 while C not in 'A' .. 'Z'
282 or else not Known_ALI_Lines (C)
283 loop
284 if C = CR or else C = LF then
285 Skip_Line;
286 C := Nextc;
288 elsif C = EOF then
289 return;
291 elsif Ignore_Errors then
292 Skip_Line;
293 C := Getc;
295 else
296 Fatal_Error;
297 end if;
298 end loop;
299 end Check_Unknown_Line;
301 -----------------
302 -- Fatal_Error --
303 -----------------
305 procedure Fatal_Error is
306 Ptr1 : Text_Ptr;
307 Ptr2 : Text_Ptr;
308 Col : Int;
310 procedure Wchar (C : Character);
311 -- Write a single character, replacing horizontal tab by spaces
313 procedure Wchar (C : Character) is
314 begin
315 if C = HT then
316 loop
317 Wchar (' ');
318 exit when Col mod 8 = 0;
319 end loop;
321 else
322 Write_Char (C);
323 Col := Col + 1;
324 end if;
325 end Wchar;
327 -- Start of processing for Fatal_Error
329 begin
330 if Err then
331 raise Bad_ALI_Format;
332 end if;
334 Set_Standard_Error;
335 Write_Str ("fatal error: file ");
336 Write_Name (F);
337 Write_Str (" is incorrectly formatted");
338 Write_Eol;
339 Write_Str
340 ("make sure you are using consistent versions of gcc/gnatbind");
341 Write_Eol;
343 -- Find start of line
345 Ptr1 := P;
347 while Ptr1 > T'First
348 and then T (Ptr1 - 1) /= CR
349 and then T (Ptr1 - 1) /= LF
350 loop
351 Ptr1 := Ptr1 - 1;
352 end loop;
354 Write_Int (Int (Line));
355 Write_Str (". ");
357 if Line < 100 then
358 Write_Char (' ');
359 end if;
361 if Line < 10 then
362 Write_Char (' ');
363 end if;
365 Col := 0;
366 Ptr2 := Ptr1;
368 while Ptr2 < T'Last
369 and then T (Ptr2) /= CR
370 and then T (Ptr2) /= LF
371 loop
372 Wchar (T (Ptr2));
373 Ptr2 := Ptr2 + 1;
374 end loop;
376 Write_Eol;
378 Write_Str (" ");
379 Col := 0;
381 while Ptr1 < P loop
382 if T (Ptr1) = HT then
383 Wchar (HT);
384 else
385 Wchar (' ');
386 end if;
388 Ptr1 := Ptr1 + 1;
389 end loop;
391 Wchar ('|');
392 Write_Eol;
394 Exit_Program (E_Fatal);
395 end Fatal_Error;
397 ------------------------
398 -- Fatal_Error_Ignore --
399 ------------------------
401 procedure Fatal_Error_Ignore is
402 begin
403 if not Ignore_Errors then
404 Fatal_Error;
405 end if;
406 end Fatal_Error_Ignore;
408 --------------
409 -- Get_Name --
410 --------------
412 function Get_Name
413 (Lower : Boolean := False;
414 Ignore_Spaces : Boolean := False) return Name_Id
416 begin
417 Name_Len := 0;
418 Skip_Space;
420 if At_Eol then
421 if Ignore_Errors then
422 return Error_Name;
423 else
424 Fatal_Error;
425 end if;
426 end if;
428 loop
429 Name_Len := Name_Len + 1;
430 Name_Buffer (Name_Len) := Getc;
432 exit when At_End_Of_Field and not Ignore_Spaces;
434 if Name_Buffer (1) = '"' then
435 exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';
437 else
438 exit when (At_End_Of_Field and not Ignore_Spaces)
439 or else Nextc = '(' or else Nextc = ')'
440 or else Nextc = '{' or else Nextc = '}'
441 or else Nextc = '<' or else Nextc = '>'
442 or else Nextc = '=';
443 end if;
444 end loop;
446 -- Convert file name to all lower case if file names are not case
447 -- sensitive. This ensures that we handle names in the canonical
448 -- lower case format, regardless of the actual case.
450 if Lower and not File_Names_Case_Sensitive then
451 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
452 end if;
454 return Name_Find;
455 end Get_Name;
457 -------------
458 -- Get_Nat --
459 -------------
461 function Get_Nat return Nat is
462 V : Nat;
464 begin
465 Skip_Space;
467 V := 0;
468 loop
469 V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0'));
470 exit when At_End_Of_Field;
471 exit when Nextc < '0' or Nextc > '9';
472 end loop;
474 return V;
475 end Get_Nat;
477 ---------------
478 -- Get_Stamp --
479 ---------------
481 function Get_Stamp return Time_Stamp_Type is
482 T : Time_Stamp_Type;
483 Start : Integer;
485 begin
486 Skip_Space;
488 if At_Eol then
489 if Ignore_Errors then
490 return Dummy_Time_Stamp;
491 else
492 Fatal_Error;
493 end if;
494 end if;
496 -- Following reads old style time stamp missing first two digits
498 if Nextc in '7' .. '9' then
499 T (1) := '1';
500 T (2) := '9';
501 Start := 3;
503 -- Normal case of full year in time stamp
505 else
506 Start := 1;
507 end if;
509 for J in Start .. T'Last loop
510 T (J) := Getc;
511 end loop;
513 return T;
514 end Get_Stamp;
516 ----------
517 -- Getc --
518 ----------
520 function Getc return Character is
521 begin
522 if P = T'Last then
523 return EOF;
524 else
525 P := P + 1;
526 return T (P - 1);
527 end if;
528 end Getc;
530 -----------
531 -- Nextc --
532 -----------
534 function Nextc return Character is
535 begin
536 return T (P);
537 end Nextc;
539 --------------
540 -- Skip_Eol --
541 --------------
543 procedure Skip_Eol is
544 begin
545 Skip_Space;
547 if not At_Eol then
548 if Ignore_Errors then
549 while not At_Eol loop
550 P := P + 1;
551 end loop;
552 else
553 Fatal_Error;
554 end if;
555 end if;
557 -- Loop to skip past blank lines (first time through skips this EOL)
559 while Nextc < ' ' and then Nextc /= EOF loop
560 if Nextc = LF then
561 Line := Line + 1;
562 end if;
564 P := P + 1;
565 end loop;
566 end Skip_Eol;
568 ---------------
569 -- Skip_Line --
570 ---------------
572 procedure Skip_Line is
573 begin
574 while not At_Eol loop
575 P := P + 1;
576 end loop;
578 Skip_Eol;
579 end Skip_Line;
581 ----------------
582 -- Skip_Space --
583 ----------------
585 procedure Skip_Space is
586 begin
587 while Nextc = ' ' or else Nextc = HT loop
588 P := P + 1;
589 end loop;
590 end Skip_Space;
592 -----------
593 -- Skipc --
594 -----------
596 procedure Skipc is
597 begin
598 if P /= T'Last then
599 P := P + 1;
600 end if;
601 end Skipc;
603 -- Start of processing for Scan_ALI
605 begin
606 First_Sdep_Entry := Sdep.Last + 1;
608 -- Acquire lines to be ignored
610 if Read_Xref then
611 Ignore := ('U' | 'W' | 'D' | 'X' => False, others => True);
613 -- Read_Lines parameter given
615 elsif Read_Lines /= "" then
616 Ignore := ('U' => False, others => True);
618 for J in Read_Lines'Range loop
619 Ignore (Read_Lines (J)) := False;
620 end loop;
622 -- Process Ignore_Lines parameter
624 else
625 Ignore := (others => False);
627 for J in Ignore_Lines'Range loop
628 pragma Assert (Ignore_Lines (J) /= 'U');
629 Ignore (Ignore_Lines (J)) := True;
630 end loop;
631 end if;
633 -- Setup ALI Table entry with appropriate defaults
635 ALIs.Increment_Last;
636 Id := ALIs.Last;
637 Set_Name_Table_Info (F, Int (Id));
639 ALIs.Table (Id) := (
640 Afile => F,
641 Compile_Errors => False,
642 First_Interrupt_State => Interrupt_States.Last + 1,
643 First_Sdep => No_Sdep_Id,
644 First_Unit => No_Unit_Id,
645 Float_Format => 'I',
646 Last_Interrupt_State => Interrupt_States.Last,
647 Last_Sdep => No_Sdep_Id,
648 Last_Unit => No_Unit_Id,
649 Locking_Policy => ' ',
650 Main_Priority => -1,
651 Main_Program => None,
652 No_Object => False,
653 Normalize_Scalars => False,
654 Ofile_Full_Name => Full_Object_File_Name,
655 Queuing_Policy => ' ',
656 Restrictions => Restrictions_Initial,
657 Sfile => No_Name,
658 Task_Dispatching_Policy => ' ',
659 Time_Slice_Value => -1,
660 WC_Encoding => '8',
661 Unit_Exception_Table => False,
662 Ver => (others => ' '),
663 Ver_Len => 0,
664 Interface => False,
665 Zero_Cost_Exceptions => False);
667 -- Now we acquire the input lines from the ALI file. Note that the
668 -- convention in the following code is that as we enter each section,
669 -- C is set to contain the first character of the following line.
671 C := Getc;
672 Check_Unknown_Line;
674 -- Acquire library version
676 if C /= 'V' then
678 -- The V line missing really indicates trouble, most likely it
679 -- means we don't have an ALI file at all, so here we give a
680 -- fatal error even if we are in Ignore_Errors mode.
682 Fatal_Error;
684 elsif Ignore ('V') then
685 Skip_Line;
687 else
688 Checkc (' ');
689 Skip_Space;
690 Checkc ('"');
692 for J in 1 .. Ver_Len_Max loop
693 C := Getc;
694 exit when C = '"';
695 ALIs.Table (Id).Ver (J) := C;
696 ALIs.Table (Id).Ver_Len := J;
697 end loop;
699 Skip_Eol;
700 end if;
702 C := Getc;
703 Check_Unknown_Line;
705 -- Acquire main program line if present
707 if C = 'M' then
708 if Ignore ('M') then
709 Skip_Line;
711 else
712 Checkc (' ');
713 Skip_Space;
715 C := Getc;
717 if C = 'F' then
718 ALIs.Table (Id).Main_Program := Func;
719 elsif C = 'P' then
720 ALIs.Table (Id).Main_Program := Proc;
721 else
722 P := P - 1;
723 Fatal_Error;
724 end if;
726 Skip_Space;
728 if not At_Eol then
729 if Nextc < 'A' then
730 ALIs.Table (Id).Main_Priority := Get_Nat;
731 end if;
733 Skip_Space;
735 if Nextc = 'T' then
736 P := P + 1;
737 Checkc ('=');
738 ALIs.Table (Id).Time_Slice_Value := Get_Nat;
739 end if;
741 Skip_Space;
743 Checkc ('W');
744 Checkc ('=');
745 ALIs.Table (Id).WC_Encoding := Getc;
746 end if;
748 Skip_Eol;
749 end if;
751 C := Getc;
752 end if;
754 -- Acquire argument lines
756 First_Arg := Args.Last + 1;
758 A_Loop : loop
759 Check_Unknown_Line;
760 exit A_Loop when C /= 'A';
762 if Ignore ('A') then
763 Skip_Line;
765 else
766 Checkc (' ');
767 Name_Len := 0;
769 while not At_Eol loop
770 Name_Len := Name_Len + 1;
771 Name_Buffer (Name_Len) := Getc;
772 end loop;
774 Args.Increment_Last;
775 Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len));
777 Skip_Eol;
778 end if;
780 C := Getc;
781 end loop A_Loop;
783 -- Acquire P line
785 Check_Unknown_Line;
787 while C /= 'P' loop
788 if Ignore_Errors then
789 if C = EOF then
790 Fatal_Error;
791 else
792 Skip_Line;
793 C := Nextc;
794 end if;
795 else
796 Fatal_Error;
797 end if;
798 end loop;
800 if Ignore ('P') then
801 Skip_Line;
803 -- Process P line
805 else
806 NS_Found := False;
808 while not At_Eol loop
809 Checkc (' ');
810 Skip_Space;
811 C := Getc;
813 -- Processing for CE
815 if C = 'C' then
816 Checkc ('E');
817 ALIs.Table (Id).Compile_Errors := True;
819 -- Processing for DB
821 elsif C = 'D' then
822 Checkc ('B');
823 Detect_Blocking := True;
825 -- Processing for FD/FG/FI
827 elsif C = 'F' then
828 Float_Format_Specified := Getc;
829 ALIs.Table (Id).Float_Format := Float_Format_Specified;
831 -- Processing for Lx
833 elsif C = 'L' then
834 Locking_Policy_Specified := Getc;
835 ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
837 -- Processing for flags starting with N
839 elsif C = 'N' then
840 C := Getc;
842 -- Processing for NO
844 if C = 'O' then
845 ALIs.Table (Id).No_Object := True;
846 No_Object_Specified := True;
848 -- Processing for NR
850 elsif C = 'R' then
851 No_Run_Time_Mode := True;
852 Configurable_Run_Time_Mode := True;
854 -- Processing for NS
856 elsif C = 'S' then
857 ALIs.Table (Id).Normalize_Scalars := True;
858 Normalize_Scalars_Specified := True;
859 NS_Found := True;
861 -- Invalid switch starting with N
863 else
864 Fatal_Error_Ignore;
865 end if;
867 -- Processing for Qx
869 elsif C = 'Q' then
870 Queuing_Policy_Specified := Getc;
871 ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
873 -- Processing for flags starting with S
875 elsif C = 'S' then
876 C := Getc;
878 -- Processing for SL
880 if C = 'L' then
881 ALIs.Table (Id).Interface := True;
883 -- Processing for SS
885 elsif C = 'S' then
886 Opt.Sec_Stack_Used := True;
888 -- Invalid switch starting with S
890 else
891 Fatal_Error_Ignore;
892 end if;
894 -- Processing for Tx
896 elsif C = 'T' then
897 Task_Dispatching_Policy_Specified := Getc;
898 ALIs.Table (Id).Task_Dispatching_Policy :=
899 Task_Dispatching_Policy_Specified;
901 -- Processing for switch starting with U
903 elsif C = 'U' then
904 C := Getc;
906 -- Processing for UA
908 if C = 'A' then
909 Unreserve_All_Interrupts_Specified := True;
911 -- Processing for UX
913 elsif C = 'X' then
914 ALIs.Table (Id).Unit_Exception_Table := True;
916 -- Invalid switches starting with U
918 else
919 Fatal_Error_Ignore;
920 end if;
922 -- Processing for ZX
924 elsif C = 'Z' then
925 C := Getc;
927 if C = 'X' then
928 ALIs.Table (Id).Zero_Cost_Exceptions := True;
929 Zero_Cost_Exceptions_Specified := True;
930 else
931 Fatal_Error_Ignore;
932 end if;
934 -- Invalid parameter
936 else
937 C := Getc;
938 Fatal_Error_Ignore;
939 end if;
940 end loop;
942 if not NS_Found then
943 No_Normalize_Scalars_Specified := True;
944 end if;
946 Skip_Eol;
947 end if;
949 C := Getc;
950 Check_Unknown_Line;
952 -- Acquire first restrictions line
954 while C /= 'R' loop
955 if Ignore_Errors then
956 if C = EOF then
957 Fatal_Error;
958 else
959 Skip_Line;
960 C := Nextc;
961 end if;
962 else
963 Fatal_Error;
964 end if;
965 end loop;
967 if Ignore ('R') then
968 Skip_Line;
970 -- Process restrictions line
972 else
973 Scan_Restrictions : declare
974 Save_R : constant Restrictions_Info := Cumulative_Restrictions;
975 -- Save cumulative restrictions in case we have a fatal error
977 Bad_R_Line : exception;
978 -- Signal bad restrictions line (raised on unexpected character)
980 begin
981 Checkc (' ');
982 Skip_Space;
984 -- Acquire information for boolean restrictions
986 for R in All_Boolean_Restrictions loop
987 C := Getc;
989 case C is
990 when 'v' =>
991 ALIs.Table (Id).Restrictions.Violated (R) := True;
992 Cumulative_Restrictions.Violated (R) := True;
994 when 'r' =>
995 ALIs.Table (Id).Restrictions.Set (R) := True;
996 Cumulative_Restrictions.Set (R) := True;
998 when 'n' =>
999 null;
1001 when others =>
1002 raise Bad_R_Line;
1003 end case;
1004 end loop;
1006 -- Acquire information for parameter restrictions
1008 for RP in All_Parameter_Restrictions loop
1010 -- Acquire restrictions pragma information
1012 case Getc is
1013 when 'n' =>
1014 null;
1016 when 'r' =>
1017 ALIs.Table (Id).Restrictions.Set (RP) := True;
1019 declare
1020 N : constant Integer := Integer (Get_Nat);
1021 begin
1022 ALIs.Table (Id).Restrictions.Value (RP) := N;
1024 if Cumulative_Restrictions.Set (RP) then
1025 Cumulative_Restrictions.Value (RP) :=
1026 Integer'Min
1027 (Cumulative_Restrictions.Value (RP), N);
1028 else
1029 Cumulative_Restrictions.Set (RP) := True;
1030 Cumulative_Restrictions.Value (RP) := N;
1031 end if;
1032 end;
1034 when others =>
1035 raise Bad_R_Line;
1036 end case;
1038 -- Acquire restrictions violations information
1040 case Getc is
1041 when 'n' =>
1042 null;
1044 when 'v' =>
1045 ALIs.Table (Id).Restrictions.Violated (RP) := True;
1046 Cumulative_Restrictions.Violated (RP) := True;
1048 declare
1049 N : constant Integer := Integer (Get_Nat);
1050 pragma Unsuppress (Overflow_Check);
1052 begin
1053 ALIs.Table (Id).Restrictions.Count (RP) := N;
1055 if RP in Checked_Max_Parameter_Restrictions then
1056 Cumulative_Restrictions.Count (RP) :=
1057 Integer'Max
1058 (Cumulative_Restrictions.Count (RP), N);
1059 else
1060 Cumulative_Restrictions.Count (RP) :=
1061 Cumulative_Restrictions.Count (RP) + N;
1062 end if;
1064 exception
1065 when Constraint_Error =>
1067 -- A constraint error comes from the addition in
1068 -- the else branch. We reset to the maximum and
1069 -- indicate that the real value is now unknown.
1071 Cumulative_Restrictions.Value (RP) := Integer'Last;
1072 Cumulative_Restrictions.Unknown (RP) := True;
1073 end;
1075 if Nextc = '+' then
1076 Skipc;
1077 ALIs.Table (Id).Restrictions.Unknown (RP) := True;
1078 Cumulative_Restrictions.Unknown (RP) := True;
1079 end if;
1081 when others =>
1082 raise Bad_R_Line;
1083 end case;
1084 end loop;
1086 Skip_Eol;
1088 -- Here if error during scanning of restrictions line
1090 exception
1091 when Bad_R_Line =>
1093 -- In Ignore_Errors mode, undo any changes to restrictions
1094 -- from this unit, and continue on.
1096 if Ignore_Errors then
1097 Cumulative_Restrictions := Save_R;
1098 ALIs.Table (Id).Restrictions := Restrictions_Initial;
1099 Skip_Eol;
1101 -- In normal mode, this is a fatal error
1103 else
1104 Fatal_Error;
1105 end if;
1107 end Scan_Restrictions;
1108 end if;
1110 -- Acquire additional restrictions (No_Dependence) lines if present
1112 C := Getc;
1113 while C = 'R' loop
1114 if Ignore ('R') then
1115 Skip_Line;
1116 else
1117 Skip_Space;
1118 No_Deps.Append ((Id, Get_Name));
1119 end if;
1121 Skip_Eol;
1122 C := Getc;
1123 end loop;
1125 -- Acquire 'I' lines if present
1127 Check_Unknown_Line;
1129 while C = 'I' loop
1130 if Ignore ('I') then
1131 Skip_Line;
1133 else
1134 declare
1135 Int_Num : Nat;
1136 I_State : Character;
1137 Line_No : Nat;
1139 begin
1140 Int_Num := Get_Nat;
1141 Skip_Space;
1142 I_State := Getc;
1143 Line_No := Get_Nat;
1145 Interrupt_States.Append (
1146 (Interrupt_Id => Int_Num,
1147 Interrupt_State => I_State,
1148 IS_Pragma_Line => Line_No));
1150 ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last;
1151 Skip_Eol;
1152 end;
1153 end if;
1155 C := Getc;
1156 end loop;
1158 -- Loop to acquire unit entries
1160 U_Loop : loop
1161 Check_Unknown_Line;
1162 exit U_Loop when C /= 'U';
1164 -- Note: as per spec, we never ignore U lines
1166 Checkc (' ');
1167 Skip_Space;
1168 Units.Increment_Last;
1170 if ALIs.Table (Id).First_Unit = No_Unit_Id then
1171 ALIs.Table (Id).First_Unit := Units.Last;
1172 end if;
1174 Units.Table (Units.Last).Uname := Get_Name;
1175 Units.Table (Units.Last).Predefined := Is_Predefined_Unit;
1176 Units.Table (Units.Last).Internal := Is_Internal_Unit;
1177 Units.Table (Units.Last).My_ALI := Id;
1178 Units.Table (Units.Last).Sfile := Get_Name (Lower => True);
1179 Units.Table (Units.Last).Pure := False;
1180 Units.Table (Units.Last).Preelab := False;
1181 Units.Table (Units.Last).No_Elab := False;
1182 Units.Table (Units.Last).Shared_Passive := False;
1183 Units.Table (Units.Last).RCI := False;
1184 Units.Table (Units.Last).Remote_Types := False;
1185 Units.Table (Units.Last).Has_RACW := False;
1186 Units.Table (Units.Last).Init_Scalars := False;
1187 Units.Table (Units.Last).Is_Generic := False;
1188 Units.Table (Units.Last).Icasing := Mixed_Case;
1189 Units.Table (Units.Last).Kcasing := All_Lower_Case;
1190 Units.Table (Units.Last).Dynamic_Elab := False;
1191 Units.Table (Units.Last).Elaborate_Body := False;
1192 Units.Table (Units.Last).Set_Elab_Entity := False;
1193 Units.Table (Units.Last).Version := "00000000";
1194 Units.Table (Units.Last).First_With := Withs.Last + 1;
1195 Units.Table (Units.Last).First_Arg := First_Arg;
1196 Units.Table (Units.Last).Elab_Position := 0;
1197 Units.Table (Units.Last).Interface := ALIs.Table (Id).Interface;
1198 Units.Table (Units.Last).Body_Needed_For_SAL := False;
1200 if Debug_Flag_U then
1201 Write_Str (" ----> reading unit ");
1202 Write_Int (Int (Units.Last));
1203 Write_Str (" ");
1204 Write_Unit_Name (Units.Table (Units.Last).Uname);
1205 Write_Str (" from file ");
1206 Write_Name (Units.Table (Units.Last).Sfile);
1207 Write_Eol;
1208 end if;
1210 -- Check for duplicated unit in different files
1212 declare
1213 Info : constant Int := Get_Name_Table_Info
1214 (Units.Table (Units.Last).Uname);
1215 begin
1216 if Info /= 0
1217 and then Units.Table (Units.Last).Sfile /=
1218 Units.Table (Unit_Id (Info)).Sfile
1219 then
1220 -- If Err is set then ignore duplicate unit name. This is the
1221 -- case of a call from gnatmake, where the situation can arise
1222 -- from substitution of source files. In such situations, the
1223 -- processing in gnatmake will always result in any required
1224 -- recompilations in any case, and if we consider this to be
1225 -- an error we get strange cases (for example when a generic
1226 -- instantiation is replaced by a normal package) where we
1227 -- read the old ali file, decide to recompile, and then decide
1228 -- that the old and new ali files are incompatible.
1230 if Err then
1231 null;
1233 -- If Err is not set, then this is a fatal error. This is
1234 -- the case of being called from the binder, where we must
1235 -- definitely diagnose this as an error.
1237 else
1238 Set_Standard_Error;
1239 Write_Str ("error: duplicate unit name: ");
1240 Write_Eol;
1242 Write_Str ("error: unit """);
1243 Write_Unit_Name (Units.Table (Units.Last).Uname);
1244 Write_Str (""" found in file """);
1245 Write_Name_Decoded (Units.Table (Units.Last).Sfile);
1246 Write_Char ('"');
1247 Write_Eol;
1249 Write_Str ("error: unit """);
1250 Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
1251 Write_Str (""" found in file """);
1252 Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
1253 Write_Char ('"');
1254 Write_Eol;
1256 Exit_Program (E_Fatal);
1257 end if;
1258 end if;
1259 end;
1261 Set_Name_Table_Info
1262 (Units.Table (Units.Last).Uname, Int (Units.Last));
1264 -- Scan out possible version and other parameters
1266 loop
1267 Skip_Space;
1268 exit when At_Eol;
1269 C := Getc;
1271 -- Version field
1273 if C in '0' .. '9' or else C in 'a' .. 'f' then
1274 Units.Table (Units.Last).Version (1) := C;
1276 for J in 2 .. 8 loop
1277 C := Getc;
1278 Units.Table (Units.Last).Version (J) := C;
1279 end loop;
1281 -- BN parameter (Body needed)
1283 elsif C = 'B' then
1284 C := Getc;
1286 if C = 'N' then
1287 Check_At_End_Of_Field;
1288 Units.Table (Units.Last).Body_Needed_For_SAL := True;
1289 else
1290 Fatal_Error_Ignore;
1291 end if;
1294 -- DE parameter (Dynamic elaboration checks)
1296 elsif C = 'D' then
1297 C := Getc;
1299 if C = 'E' then
1300 Check_At_End_Of_Field;
1301 Units.Table (Units.Last).Dynamic_Elab := True;
1302 Dynamic_Elaboration_Checks_Specified := True;
1303 else
1304 Fatal_Error_Ignore;
1305 end if;
1307 -- EB/EE parameters
1309 elsif C = 'E' then
1310 C := Getc;
1312 if C = 'B' then
1313 Units.Table (Units.Last).Elaborate_Body := True;
1314 elsif C = 'E' then
1315 Units.Table (Units.Last).Set_Elab_Entity := True;
1316 else
1317 Fatal_Error_Ignore;
1318 end if;
1320 Check_At_End_Of_Field;
1322 -- GE parameter (generic)
1324 elsif C = 'G' then
1325 C := Getc;
1327 if C = 'E' then
1328 Check_At_End_Of_Field;
1329 Units.Table (Units.Last).Is_Generic := True;
1330 else
1331 Fatal_Error_Ignore;
1332 end if;
1334 -- IL/IS/IU parameters
1336 elsif C = 'I' then
1337 C := Getc;
1339 if C = 'L' then
1340 Units.Table (Units.Last).Icasing := All_Lower_Case;
1341 elsif C = 'S' then
1342 Units.Table (Units.Last).Init_Scalars := True;
1343 Initialize_Scalars_Used := True;
1344 elsif C = 'U' then
1345 Units.Table (Units.Last).Icasing := All_Upper_Case;
1346 else
1347 Fatal_Error_Ignore;
1348 end if;
1350 Check_At_End_Of_Field;
1352 -- KM/KU parameters
1354 elsif C = 'K' then
1355 C := Getc;
1357 if C = 'M' then
1358 Units.Table (Units.Last).Kcasing := Mixed_Case;
1359 elsif C = 'U' then
1360 Units.Table (Units.Last).Kcasing := All_Upper_Case;
1361 else
1362 Fatal_Error_Ignore;
1363 end if;
1365 Check_At_End_Of_Field;
1367 -- NE parameter
1369 elsif C = 'N' then
1370 C := Getc;
1372 if C = 'E' then
1373 Units.Table (Units.Last).No_Elab := True;
1374 Check_At_End_Of_Field;
1375 else
1376 Fatal_Error_Ignore;
1377 end if;
1380 -- PR/PU/PK parameters
1382 elsif C = 'P' then
1383 C := Getc;
1385 if C = 'R' then
1386 Units.Table (Units.Last).Preelab := True;
1387 elsif C = 'U' then
1388 Units.Table (Units.Last).Pure := True;
1389 elsif C = 'K' then
1390 Units.Table (Units.Last).Unit_Kind := 'p';
1391 else
1392 Fatal_Error_Ignore;
1393 end if;
1395 Check_At_End_Of_Field;
1397 -- RC/RT parameters
1399 elsif C = 'R' then
1400 C := Getc;
1402 if C = 'C' then
1403 Units.Table (Units.Last).RCI := True;
1404 elsif C = 'T' then
1405 Units.Table (Units.Last).Remote_Types := True;
1406 elsif C = 'A' then
1407 Units.Table (Units.Last).Has_RACW := True;
1408 else
1409 Fatal_Error_Ignore;
1410 end if;
1412 Check_At_End_Of_Field;
1414 elsif C = 'S' then
1415 C := Getc;
1417 if C = 'P' then
1418 Units.Table (Units.Last).Shared_Passive := True;
1419 elsif C = 'U' then
1420 Units.Table (Units.Last).Unit_Kind := 's';
1421 else
1422 Fatal_Error_Ignore;
1423 end if;
1425 Check_At_End_Of_Field;
1427 else
1428 C := Getc;
1429 Fatal_Error_Ignore;
1430 end if;
1431 end loop;
1433 Skip_Eol;
1435 -- Check if static elaboration model used
1437 if not Units.Table (Units.Last).Dynamic_Elab
1438 and then not Units.Table (Units.Last).Internal
1439 then
1440 Static_Elaboration_Model_Used := True;
1441 end if;
1443 C := Getc;
1445 -- Scan out With lines for this unit
1447 With_Loop : loop
1448 Check_Unknown_Line;
1449 exit With_Loop when C /= 'W';
1451 if Ignore ('W') then
1452 Skip_Line;
1454 else
1455 Checkc (' ');
1456 Skip_Space;
1457 Withs.Increment_Last;
1458 Withs.Table (Withs.Last).Uname := Get_Name;
1459 Withs.Table (Withs.Last).Elaborate := False;
1460 Withs.Table (Withs.Last).Elaborate_All := False;
1461 Withs.Table (Withs.Last).Elab_All_Desirable := False;
1462 Withs.Table (Withs.Last).Interface := False;
1464 -- Generic case with no object file available
1466 if At_Eol then
1467 Withs.Table (Withs.Last).Sfile := No_File;
1468 Withs.Table (Withs.Last).Afile := No_File;
1470 -- Normal case
1472 else
1473 Withs.Table (Withs.Last).Sfile := Get_Name (Lower => True);
1474 Withs.Table (Withs.Last).Afile := Get_Name;
1476 -- Scan out possible E, EA, and NE parameters
1478 while not At_Eol loop
1479 Skip_Space;
1481 if Nextc = 'E' then
1482 P := P + 1;
1484 if At_End_Of_Field then
1485 Withs.Table (Withs.Last).Elaborate := True;
1487 elsif Nextc = 'A' then
1488 P := P + 1;
1489 Check_At_End_Of_Field;
1490 Withs.Table (Withs.Last).Elaborate_All := True;
1492 else
1493 Checkc ('D');
1494 Check_At_End_Of_Field;
1496 -- Store ED indication unless ignore required
1498 if not Ignore_ED then
1499 Withs.Table (Withs.Last).Elab_All_Desirable :=
1500 True;
1501 end if;
1502 end if;
1503 end if;
1504 end loop;
1505 end if;
1507 Skip_Eol;
1508 end if;
1510 C := Getc;
1511 end loop With_Loop;
1513 Units.Table (Units.Last).Last_With := Withs.Last;
1514 Units.Table (Units.Last).Last_Arg := Args.Last;
1516 -- If there are linker options lines present, scan them
1518 Name_Len := 0;
1520 Linker_Options_Loop : loop
1521 Check_Unknown_Line;
1522 exit Linker_Options_Loop when C /= 'L';
1524 if Ignore ('L') then
1525 Skip_Line;
1527 else
1528 Checkc (' ');
1529 Skip_Space;
1530 Checkc ('"');
1532 loop
1533 C := Getc;
1535 if C < Character'Val (16#20#)
1536 or else C > Character'Val (16#7E#)
1537 then
1538 Fatal_Error_Ignore;
1540 elsif C = '{' then
1541 C := Character'Val (0);
1543 declare
1544 V : Natural;
1546 begin
1547 V := 0;
1548 for J in 1 .. 2 loop
1549 C := Getc;
1551 if C in '0' .. '9' then
1552 V := V * 16 +
1553 Character'Pos (C) -
1554 Character'Pos ('0');
1556 elsif C in 'A' .. 'F' then
1557 V := V * 16 +
1558 Character'Pos (C) -
1559 Character'Pos ('A') +
1562 else
1563 Fatal_Error_Ignore;
1564 end if;
1565 end loop;
1567 Checkc ('}');
1568 Add_Char_To_Name_Buffer (Character'Val (V));
1569 end;
1571 else
1572 if C = '"' then
1573 exit when Nextc /= '"';
1574 C := Getc;
1575 end if;
1577 Add_Char_To_Name_Buffer (C);
1578 end if;
1579 end loop;
1581 Add_Char_To_Name_Buffer (nul);
1582 Skip_Eol;
1583 end if;
1585 C := Getc;
1586 end loop Linker_Options_Loop;
1588 -- Store the linker options entry if one was found
1590 if Name_Len /= 0 then
1591 Linker_Options.Increment_Last;
1593 Linker_Options.Table (Linker_Options.Last).Name :=
1594 Name_Enter;
1596 Linker_Options.Table (Linker_Options.Last).Unit :=
1597 Units.Last;
1599 Linker_Options.Table (Linker_Options.Last).Internal_File :=
1600 Is_Internal_File_Name (F);
1602 Linker_Options.Table (Linker_Options.Last).Original_Pos :=
1603 Linker_Options.Last;
1604 end if;
1605 end loop U_Loop;
1607 -- End loop through units for one ALI file
1609 ALIs.Table (Id).Last_Unit := Units.Last;
1610 ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile;
1612 -- Set types of the units (there can be at most 2 of them)
1614 if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then
1615 Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body;
1616 Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec;
1618 else
1619 -- Deal with body only and spec only cases, note that the reason we
1620 -- do our own checking of the name (rather than using Is_Body_Name)
1621 -- is that Uname drags in far too much compiler junk!
1623 Get_Name_String (Units.Table (Units.Last).Uname);
1625 if Name_Buffer (Name_Len) = 'b' then
1626 Units.Table (Units.Last).Utype := Is_Body_Only;
1627 else
1628 Units.Table (Units.Last).Utype := Is_Spec_Only;
1629 end if;
1630 end if;
1632 -- Scan out external version references and put in hash table
1634 E_Loop : loop
1635 Check_Unknown_Line;
1636 exit E_Loop when C /= 'E';
1638 if Ignore ('E') then
1639 Skip_Line;
1641 else
1642 Checkc (' ');
1643 Skip_Space;
1645 Name_Len := 0;
1646 Name_Len := 0;
1647 loop
1648 C := Getc;
1650 if C < ' ' then
1651 Fatal_Error;
1652 end if;
1654 exit when At_End_Of_Field;
1655 Add_Char_To_Name_Buffer (C);
1656 end loop;
1658 Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
1659 Skip_Eol;
1660 end if;
1662 C := Getc;
1663 end loop E_Loop;
1665 -- Scan out source dependency lines for this ALI file
1667 ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
1669 D_Loop : loop
1670 Check_Unknown_Line;
1671 exit D_Loop when C /= 'D';
1673 if Ignore ('D') then
1674 Skip_Line;
1676 else
1677 Checkc (' ');
1678 Skip_Space;
1679 Sdep.Increment_Last;
1680 Sdep.Table (Sdep.Last).Sfile := Get_Name (Lower => True);
1681 Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
1682 Sdep.Table (Sdep.Last).Dummy_Entry :=
1683 (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
1685 -- Acquire checksum value
1687 Skip_Space;
1689 declare
1690 Ctr : Natural;
1691 Chk : Word;
1693 begin
1694 Ctr := 0;
1695 Chk := 0;
1697 loop
1698 exit when At_Eol or else Ctr = 8;
1700 if Nextc in '0' .. '9' then
1701 Chk := Chk * 16 +
1702 Character'Pos (Nextc) - Character'Pos ('0');
1704 elsif Nextc in 'a' .. 'f' then
1705 Chk := Chk * 16 +
1706 Character'Pos (Nextc) - Character'Pos ('a') + 10;
1708 else
1709 exit;
1710 end if;
1712 Ctr := Ctr + 1;
1713 P := P + 1;
1714 end loop;
1716 if Ctr = 8 and then At_End_Of_Field then
1717 Sdep.Table (Sdep.Last).Checksum := Chk;
1718 else
1719 Fatal_Error;
1720 end if;
1721 end;
1723 -- Acquire subunit and reference file name entries
1725 Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
1726 Sdep.Table (Sdep.Last).Rfile :=
1727 Sdep.Table (Sdep.Last).Sfile;
1728 Sdep.Table (Sdep.Last).Start_Line := 1;
1730 if not At_Eol then
1731 Skip_Space;
1733 -- Here for subunit name
1735 if Nextc not in '0' .. '9' then
1736 Name_Len := 0;
1738 while not At_End_Of_Field loop
1739 Name_Len := Name_Len + 1;
1740 Name_Buffer (Name_Len) := Getc;
1741 end loop;
1743 Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter;
1744 Skip_Space;
1745 end if;
1747 -- Here for reference file name entry
1749 if Nextc in '0' .. '9' then
1750 Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
1751 Checkc (':');
1753 Name_Len := 0;
1755 while not At_End_Of_Field loop
1756 Name_Len := Name_Len + 1;
1757 Name_Buffer (Name_Len) := Getc;
1758 end loop;
1760 Sdep.Table (Sdep.Last).Rfile := Name_Enter;
1761 end if;
1762 end if;
1764 Skip_Eol;
1765 end if;
1767 C := Getc;
1768 end loop D_Loop;
1770 ALIs.Table (Id).Last_Sdep := Sdep.Last;
1772 -- We must at this stage be at an Xref line or the end of file
1774 if C = EOF then
1775 return Id;
1776 end if;
1778 Check_Unknown_Line;
1780 if C /= 'X' then
1781 Fatal_Error;
1782 end if;
1784 -- If we are ignoring Xref sections we are done (we ignore all
1785 -- remaining lines since only xref related lines follow X).
1787 if Ignore ('X') and then not Debug_Flag_X then
1788 return Id;
1789 end if;
1791 -- Loop through Xref sections
1793 X_Loop : loop
1794 Check_Unknown_Line;
1795 exit X_Loop when C /= 'X';
1797 -- Make new entry in section table
1799 Xref_Section.Increment_Last;
1801 Read_Refs_For_One_File : declare
1802 XS : Xref_Section_Record renames
1803 Xref_Section.Table (Xref_Section.Last);
1805 Current_File_Num : Sdep_Id;
1806 -- Keeps track of the current file number (changed by nn|)
1808 begin
1809 XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
1810 XS.File_Name := Get_Name;
1811 XS.First_Entity := Xref_Entity.Last + 1;
1813 Current_File_Num := XS.File_Num;
1815 Skip_Space;
1817 Skip_Eol;
1818 C := Nextc;
1820 -- Loop through Xref entities
1822 while C /= 'X' and then C /= EOF loop
1823 Xref_Entity.Increment_Last;
1825 Read_Refs_For_One_Entity : declare
1826 XE : Xref_Entity_Record renames
1827 Xref_Entity.Table (Xref_Entity.Last);
1828 N : Nat;
1830 procedure Read_Instantiation_Reference;
1831 -- Acquire instantiation reference. Caller has checked
1832 -- that current character is '[' and on return the cursor
1833 -- is skipped past the corresponding closing ']'.
1835 ----------------------------------
1836 -- Read_Instantiation_Reference --
1837 ----------------------------------
1839 procedure Read_Instantiation_Reference is
1840 Local_File_Num : Sdep_Id := Current_File_Num;
1842 begin
1843 Xref.Increment_Last;
1845 declare
1846 XR : Xref_Record renames Xref.Table (Xref.Last);
1848 begin
1849 P := P + 1; -- skip [
1850 N := Get_Nat;
1852 if Nextc = '|' then
1853 XR.File_Num :=
1854 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
1855 Local_File_Num := XR.File_Num;
1856 P := P + 1;
1857 N := Get_Nat;
1859 else
1860 XR.File_Num := Local_File_Num;
1861 end if;
1863 XR.Line := N;
1864 XR.Rtype := ' ';
1865 XR.Col := 0;
1867 -- Recursive call for next reference
1869 if Nextc = '[' then
1870 pragma Warnings (Off); -- kill recursion warning
1871 Read_Instantiation_Reference;
1872 pragma Warnings (On);
1873 end if;
1875 -- Skip closing bracket after recursive call
1877 P := P + 1;
1878 end;
1879 end Read_Instantiation_Reference;
1881 -- Start of processing for Read_Refs_For_One_Entity
1883 begin
1884 XE.Line := Get_Nat;
1885 XE.Etype := Getc;
1886 XE.Col := Get_Nat;
1887 XE.Lib := (Getc = '*');
1888 XE.Entity := Get_Name;
1890 Current_File_Num := XS.File_Num;
1892 -- Renaming reference is present
1894 if Nextc = '=' then
1895 P := P + 1;
1896 XE.Rref_Line := Get_Nat;
1898 if Getc /= ':' then
1899 Fatal_Error;
1900 end if;
1902 XE.Rref_Col := Get_Nat;
1904 -- No renaming reference present
1906 else
1907 XE.Rref_Line := 0;
1908 XE.Rref_Col := 0;
1909 end if;
1911 Skip_Space;
1913 -- See if type reference present
1915 case Nextc is
1916 when '<' => XE.Tref := Tref_Derived;
1917 when '(' => XE.Tref := Tref_Access;
1918 when '{' => XE.Tref := Tref_Type;
1919 when others => XE.Tref := Tref_None;
1920 end case;
1922 -- Case of typeref field present
1924 if XE.Tref /= Tref_None then
1925 P := P + 1; -- skip opening bracket
1927 if Nextc in 'a' .. 'z' then
1928 XE.Tref_File_Num := No_Sdep_Id;
1929 XE.Tref_Line := 0;
1930 XE.Tref_Type := ' ';
1931 XE.Tref_Col := 0;
1932 XE.Tref_Standard_Entity :=
1933 Get_Name (Ignore_Spaces => True);
1935 else
1936 N := Get_Nat;
1938 if Nextc = '|' then
1939 XE.Tref_File_Num :=
1940 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
1941 P := P + 1;
1942 N := Get_Nat;
1944 else
1945 XE.Tref_File_Num := Current_File_Num;
1946 end if;
1948 XE.Tref_Line := N;
1949 XE.Tref_Type := Getc;
1950 XE.Tref_Col := Get_Nat;
1951 XE.Tref_Standard_Entity := No_Name;
1952 end if;
1954 -- ??? Temporary workaround for nested generics case:
1955 -- 4i4 Directories{1|4I9[4|6[3|3]]}
1956 -- See C918-002
1958 declare
1959 Nested_Brackets : Natural := 0;
1961 begin
1962 loop
1963 case Nextc is
1964 when '[' =>
1965 Nested_Brackets := Nested_Brackets + 1;
1966 when ']' =>
1967 Nested_Brackets := Nested_Brackets - 1;
1968 when others =>
1969 if Nested_Brackets = 0 then
1970 exit;
1971 end if;
1972 end case;
1974 Skipc;
1975 end loop;
1976 end;
1978 P := P + 1; -- skip closing bracket
1979 Skip_Space;
1981 -- No typeref entry present
1983 else
1984 XE.Tref_File_Num := No_Sdep_Id;
1985 XE.Tref_Line := 0;
1986 XE.Tref_Type := ' ';
1987 XE.Tref_Col := 0;
1988 XE.Tref_Standard_Entity := No_Name;
1989 end if;
1991 XE.First_Xref := Xref.Last + 1;
1993 -- Loop through cross-references for this entity
1995 loop
1996 Skip_Space;
1998 if At_Eol then
1999 Skip_Eol;
2000 exit when Nextc /= '.';
2001 P := P + 1;
2002 end if;
2004 Xref.Increment_Last;
2006 declare
2007 XR : Xref_Record renames Xref.Table (Xref.Last);
2009 begin
2010 N := Get_Nat;
2012 if Nextc = '|' then
2013 XR.File_Num :=
2014 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2015 Current_File_Num := XR.File_Num;
2016 P := P + 1;
2017 N := Get_Nat;
2018 else
2019 XR.File_Num := Current_File_Num;
2020 end if;
2022 XR.Line := N;
2023 XR.Rtype := Getc;
2025 -- Imported entities reference as in:
2026 -- 494b<c,__gnat_copy_attribs>25
2027 -- ??? Simply skipped for now
2029 if Nextc = '<' then
2030 while Getc /= '>' loop
2031 null;
2032 end loop;
2033 end if;
2035 XR.Col := Get_Nat;
2037 if Nextc = '[' then
2038 Read_Instantiation_Reference;
2039 end if;
2040 end;
2041 end loop;
2043 -- Record last cross-reference
2045 XE.Last_Xref := Xref.Last;
2046 C := Nextc;
2047 end Read_Refs_For_One_Entity;
2048 end loop;
2050 -- Record last entity
2052 XS.Last_Entity := Xref_Entity.Last;
2054 end Read_Refs_For_One_File;
2056 C := Getc;
2057 end loop X_Loop;
2059 -- Here after dealing with xref sections
2061 if C /= EOF and then C /= 'X' then
2062 Fatal_Error;
2063 end if;
2065 return Id;
2067 exception
2068 when Bad_ALI_Format =>
2069 return No_ALI_Id;
2071 end Scan_ALI;
2073 ---------
2074 -- SEq --
2075 ---------
2077 function SEq (F1, F2 : String_Ptr) return Boolean is
2078 begin
2079 return F1.all = F2.all;
2080 end SEq;
2082 -----------
2083 -- SHash --
2084 -----------
2086 function SHash (S : String_Ptr) return Vindex is
2087 H : Word;
2089 begin
2090 H := 0;
2091 for J in S.all'Range loop
2092 H := H * 2 + Character'Pos (S (J));
2093 end loop;
2095 return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));
2096 end SHash;
2098 end ALI;