1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
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. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Butil
; use Butil
;
28 with Debug
; use Debug
;
29 with Fname
; use Fname
;
30 with Namet
; use Namet
;
32 with Osint
; use Osint
;
33 with Output
; use Output
;
38 -- Make control characters visible
44 procedure Initialize_ALI
is
46 -- When (re)initializing ALI data structures the ALI user expects to
47 -- get a fresh set of data structures. Thus we first need to erase the
48 -- marks put in the name table by the previous set of ALI routine calls.
49 -- These two loops are empty and harmless the first time in.
51 for J
in ALIs
.First
.. ALIs
.Last
loop
52 Set_Name_Table_Info
(ALIs
.Table
(J
).Afile
, 0);
55 for J
in Units
.First
.. Units
.Last
loop
56 Set_Name_Table_Info
(Units
.Table
(J
).Uname
, 0);
59 -- Free argument table strings
61 for J
in Args
.First
.. Args
.Last
loop
62 Free
(Args
.Table
(J
));
65 -- Initialize all tables
77 -- Add dummy zero'th item in Linker_Options for the sort function
79 Linker_Options
.Increment_Last
;
81 -- Initialize global variables recording cumulative options in all
82 -- ALI files that are read for a given processing run in gnatbind.
84 Dynamic_Elaboration_Checks_Specified
:= False;
85 Float_Format_Specified
:= ' ';
86 Locking_Policy_Specified
:= ' ';
87 No_Normalize_Scalars_Specified
:= False;
88 No_Object_Specified
:= False;
89 Normalize_Scalars_Specified
:= False;
90 Queuing_Policy_Specified
:= ' ';
91 Static_Elaboration_Model_Used
:= False;
92 Task_Dispatching_Policy_Specified
:= ' ';
93 Unreserve_All_Interrupts_Specified
:= False;
94 Zero_Cost_Exceptions_Specified
:= False;
107 Read_Xref
: Boolean := False;
108 Read_Lines
: String := "";
109 Ignore_Lines
: String := "X")
112 P
: Text_Ptr
:= T
'First;
113 Line
: Logical_Line_Number
:= 1;
119 Ignore
: array (Character range 'A' .. 'Z') of Boolean;
120 -- Ignore (X) is set to True if lines starting with X are to
121 -- be ignored by Scan_ALI and skipped, and False if the lines
122 -- are to be read and processed.
124 Bad_ALI_Format
: exception;
125 -- Exception raised by Fatal_Error if Err is True
127 function At_Eol
return Boolean;
128 -- Test if at end of line
130 function At_End_Of_Field
return Boolean;
131 -- Test if at end of line, or if at blank or horizontal tab
133 procedure Check_At_End_Of_Field
;
134 -- Check if we are at end of field, fatal error if not
136 procedure Checkc
(C
: Character);
137 -- Check next character is C. If so bump past it, if not fatal error
139 procedure Fatal_Error
;
140 -- Generate fatal error message for badly formatted ALI file if
141 -- Err is false, or raise Bad_ALI_Format if Err is True.
143 function Getc
return Character;
144 -- Get next character, bumping P past the character obtained
146 function Get_Name
(Lower
: Boolean := False;
147 Ignore_Spaces
: Boolean := False) return Name_Id
;
148 -- Skip blanks, then scan out a name (name is left in Name_Buffer with
149 -- length in Name_Len, as well as being returned in Name_Id form).
150 -- If Lower is set to True then the Name_Buffer will be converted to
151 -- all lower case, for systems where file names are not case sensitive.
152 -- This ensures that gnatbind works correctly regardless of the case
153 -- of the file name on all systems. The name is terminated by a either
154 -- white space (when Ignore_Spaces is False) or a typeref bracket or
155 -- an equal sign except for the special case of an operator name
156 -- starting with a double quite which is terminated by another double
159 function Get_Nat
return Nat
;
160 -- Skip blanks, then scan out an unsigned integer value in Nat range.
162 function Get_Stamp
return Time_Stamp_Type
;
163 -- Skip blanks, then scan out a time stamp
165 function Nextc
return Character;
166 -- Return current character without modifying pointer P
169 -- Skip past spaces, then skip past end of line (fatal error if not
170 -- at end of line). Also skips past any following blank lines.
173 -- Skip rest of current line and any following blank lines.
175 procedure Skip_Space
;
176 -- Skip past white space (blanks or horizontal tab)
178 ---------------------
179 -- At_End_Of_Field --
180 ---------------------
182 function At_End_Of_Field
return Boolean is
191 function At_Eol
return Boolean is
193 return Nextc
= EOF
or else Nextc
= CR
or else Nextc
= LF
;
196 ---------------------------
197 -- Check_At_End_Of_Field --
198 ---------------------------
200 procedure Check_At_End_Of_Field
is
202 if not At_End_Of_Field
then
205 end Check_At_End_Of_Field
;
211 procedure Checkc
(C
: Character) is
224 procedure Fatal_Error
is
229 procedure Wchar
(C
: Character);
230 -- Write a single character, replacing horizontal tab by spaces
232 procedure Wchar
(C
: Character) is
237 exit when Col
mod 8 = 0;
246 -- Start of processing for Fatal_Error
250 raise Bad_ALI_Format
;
254 Write_Str
("fatal error: file ");
256 Write_Str
(" is incorrectly formatted");
259 ("make sure you are using consistent versions of gcc/gnatbind");
262 -- Find start of line
267 and then T
(Ptr1
- 1) /= CR
268 and then T
(Ptr1
- 1) /= LF
273 Write_Int
(Int
(Line
));
288 and then T
(Ptr2
) /= CR
289 and then T
(Ptr2
) /= LF
301 if T
(Ptr1
) = HT
then
313 Exit_Program
(E_Fatal
);
320 function Get_Name
(Lower
: Boolean := False;
321 Ignore_Spaces
: Boolean := False) return Name_Id
is
331 Name_Len
:= Name_Len
+ 1;
332 Name_Buffer
(Name_Len
) := Getc
;
334 exit when At_End_Of_Field
and not Ignore_Spaces
;
336 if Name_Buffer
(1) = '"' then
337 exit when Name_Len
> 1 and then Name_Buffer
(Name_Len
) = '"';
340 exit when (At_End_Of_Field
and not Ignore_Spaces
)
341 or else Nextc
= '(' or else Nextc
= ')'
342 or else Nextc
= '{' or else Nextc
= '}'
343 or else Nextc
= '<' or else Nextc
= '>'
348 -- Convert file name to all lower case if file names are not case
349 -- sensitive. This ensures that we handle names in the canonical
350 -- lower case format, regardless of the actual case.
352 if Lower
and not File_Names_Case_Sensitive
then
353 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
363 function Get_Nat
return Nat
is
372 V
:= V
* 10 + (Character'Pos (Getc
) - Character'Pos ('0'));
373 exit when At_End_Of_Field
;
374 exit when Nextc
< '0' or Nextc
> '9';
384 function Get_Stamp
return Time_Stamp_Type
is
395 -- Following reads old style time stamp missing first two digits
397 if Nextc
in '7' .. '9' then
402 -- Normal case of full year in time stamp
408 for J
in Start
.. T
'Last loop
419 function Getc
return Character is
433 function Nextc
return Character is
442 procedure Skip_Eol
is
446 if not At_Eol
then Fatal_Error
; end if;
448 -- Loop to skip past blank lines (first time through skips this EOL)
450 while Nextc
< ' ' and then Nextc
/= EOF
loop
463 procedure Skip_Line
is
465 while not At_Eol
loop
476 procedure Skip_Space
is
478 while Nextc
= ' ' or else Nextc
= HT
loop
483 -- Start of processing for Scan_ALI
486 -- Acquire lines to be ignored
489 Ignore
:= ('U' |
'W' |
'D' |
'X' => False, others => True);
491 -- Read_Lines parameter given
493 elsif Read_Lines
/= "" then
494 Ignore
:= ('U' => False, others => True);
496 for J
in Read_Lines
'Range loop
497 Ignore
(Read_Lines
(J
)) := False;
500 -- Process Ignore_Lines parameter
503 Ignore
:= (others => False);
505 for J
in Ignore_Lines
'Range loop
506 pragma Assert
(Ignore_Lines
(J
) /= 'U');
507 Ignore
(Ignore_Lines
(J
)) := True;
511 -- Setup ALI Table entry with appropriate defaults
515 Set_Name_Table_Info
(F
, Int
(Id
));
519 Compile_Errors
=> False,
520 First_Interrupt_State
=> Interrupt_States
.Last
+ 1,
521 First_Sdep
=> No_Sdep_Id
,
522 First_Unit
=> No_Unit_Id
,
524 Last_Interrupt_State
=> Interrupt_States
.Last
,
525 Last_Sdep
=> No_Sdep_Id
,
526 Last_Unit
=> No_Unit_Id
,
527 Locking_Policy
=> ' ',
529 Main_Program
=> None
,
531 Normalize_Scalars
=> False,
532 Ofile_Full_Name
=> Full_Object_File_Name
,
533 Queuing_Policy
=> ' ',
534 Restrictions
=> (others => ' '),
536 Task_Dispatching_Policy
=> ' ',
537 Time_Slice_Value
=> -1,
539 Unit_Exception_Table
=> False,
540 Ver
=> (others => ' '),
543 Zero_Cost_Exceptions
=> False);
545 -- Now we acquire the input lines from the ALI file. Note that the
546 -- convention in the following code is that as we enter each section,
547 -- C is set to contain the first character of the following line.
551 -- Acquire library version
556 elsif Ignore
('V') then
564 for J
in 1 .. Ver_Len_Max
loop
567 ALIs
.Table
(Id
).Ver
(J
) := C
;
568 ALIs
.Table
(Id
).Ver_Len
:= J
;
576 -- Acquire main program line if present
589 ALIs
.Table
(Id
).Main_Program
:= Func
;
591 ALIs
.Table
(Id
).Main_Program
:= Proc
;
601 ALIs
.Table
(Id
).Main_Priority
:= Get_Nat
;
609 ALIs
.Table
(Id
).Time_Slice_Value
:= Get_Nat
;
616 ALIs
.Table
(Id
).WC_Encoding
:= Getc
;
625 -- Acquire argument lines
627 First_Arg
:= Args
.Last
+ 1;
629 Arg_Loop
: while C
= 'A' loop
637 while not At_Eol
loop
638 Name_Len
:= Name_Len
+ 1;
639 Name_Buffer
(Name_Len
) := Getc
;
643 Args
.Table
(Args
.Last
) := new String'(Name_Buffer (1 .. Name_Len));
656 elsif Ignore ('P
') then
662 while not At_Eol loop
671 ALIs.Table (Id).Compile_Errors := True;
673 -- Processing for FD/FG/FI
676 Float_Format_Specified := Getc;
677 ALIs.Table (Id).Float_Format := Float_Format_Specified;
682 Locking_Policy_Specified := Getc;
683 ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
685 -- Processing for flags starting with N
693 ALIs.Table (Id).No_Object := True;
694 No_Object_Specified := True;
699 No_Run_Time_Mode := True;
700 Configurable_Run_Time_Mode := True;
705 ALIs.Table (Id).Normalize_Scalars := True;
706 Normalize_Scalars_Specified := True;
716 Queuing_Policy_Specified := Getc;
717 ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
723 ALIs.Table (Id).Interface := True;
728 Task_Dispatching_Policy_Specified := Getc;
729 ALIs.Table (Id).Task_Dispatching_Policy :=
730 Task_Dispatching_Policy_Specified;
736 Unreserve_All_Interrupts_Specified := True;
743 ALIs.Table (Id).Unit_Exception_Table := True;
750 ALIs.Table (Id).Zero_Cost_Exceptions := True;
751 Zero_Cost_Exceptions_Specified := True;
759 No_Normalize_Scalars_Specified := True;
767 -- Acquire restrictions line
772 elsif Ignore ('R
') then
779 for J in All_Restrictions loop
781 ALIs.Table (Id).Restrictions (J) := C;
785 Restrictions (J) := 'v
';
788 if Restrictions (J) = 'n
' then
789 Restrictions (J) := 'r
';
805 -- Acquire 'I
' lines if present
823 Interrupt_States.Append (
824 (Interrupt_Id => Int_Num,
825 Interrupt_State => I_State,
826 IS_Pragma_Line => Line_No));
828 ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last;
836 -- Loop to acquire unit entries
838 Unit_Loop : while C = 'U
' loop
840 -- Note: as per spec, we never ignore U lines
844 Units.Increment_Last;
846 if ALIs.Table (Id).First_Unit = No_Unit_Id then
847 ALIs.Table (Id).First_Unit := Units.Last;
850 Units.Table (Units.Last).Uname := Get_Name;
851 Units.Table (Units.Last).Predefined := Is_Predefined_Unit;
852 Units.Table (Units.Last).Internal := Is_Internal_Unit;
853 Units.Table (Units.Last).My_ALI := Id;
854 Units.Table (Units.Last).Sfile := Get_Name (Lower => True);
855 Units.Table (Units.Last).Pure := False;
856 Units.Table (Units.Last).Preelab := False;
857 Units.Table (Units.Last).No_Elab := False;
858 Units.Table (Units.Last).Shared_Passive := False;
859 Units.Table (Units.Last).RCI := False;
860 Units.Table (Units.Last).Remote_Types := False;
861 Units.Table (Units.Last).Has_RACW := False;
862 Units.Table (Units.Last).Init_Scalars := False;
863 Units.Table (Units.Last).Is_Generic := False;
864 Units.Table (Units.Last).Icasing := Mixed_Case;
865 Units.Table (Units.Last).Kcasing := All_Lower_Case;
866 Units.Table (Units.Last).Dynamic_Elab := False;
867 Units.Table (Units.Last).Elaborate_Body := False;
868 Units.Table (Units.Last).Set_Elab_Entity := False;
869 Units.Table (Units.Last).Version := "00000000";
870 Units.Table (Units.Last).First_With := Withs.Last + 1;
871 Units.Table (Units.Last).First_Arg := First_Arg;
872 Units.Table (Units.Last).Elab_Position := 0;
873 Units.Table (Units.Last).Interface := ALIs.Table (Id).Interface;
876 Write_Str (" ----> reading unit ");
877 Write_Int (Int (Units.Last));
879 Write_Unit_Name (Units.Table (Units.Last).Uname);
880 Write_Str (" from file ");
881 Write_Name (Units.Table (Units.Last).Sfile);
885 -- Check for duplicated unit in different files
888 Info : constant Int := Get_Name_Table_Info
889 (Units.Table (Units.Last).Uname);
892 and then Units.Table (Units.Last).Sfile /=
893 Units.Table (Unit_Id (Info)).Sfile
895 -- If Err is set then ignore duplicate unit name. This is the
896 -- case of a call from gnatmake, where the situation can arise
897 -- from substitution of source files. In such situations, the
898 -- processing in gnatmake will always result in any required
899 -- recompilations in any case, and if we consider this to be
900 -- an error we get strange cases (for example when a generic
901 -- instantiation is replaced by a normal package) where we
902 -- read the old ali file, decide to recompile, and then decide
903 -- that the old and new ali files are incompatible.
908 -- If Err is not set, then this is a fatal error. This is
909 -- the case of being called from the binder, where we must
910 -- definitely diagnose this as an error.
914 Write_Str ("error: duplicate unit name: ");
917 Write_Str ("error: unit """);
918 Write_Unit_Name (Units.Table (Units.Last).Uname);
919 Write_Str (""" found in file """);
920 Write_Name_Decoded (Units.Table (Units.Last).Sfile);
924 Write_Str ("error
: unit
""");
925 Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
926 Write_Str (""" found
in file
""");
927 Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
931 Exit_Program (E_Fatal);
937 (Units.Table (Units.Last).Uname, Int (Units.Last));
939 -- Scan out possible version and other parameters
948 if C in '0' .. '9' or else C in 'a
' .. 'f
' then
949 Units.Table (Units.Last).Version (1) := C;
953 Units.Table (Units.Last).Version (J) := C;
956 -- BN parameter (Body needed)
960 Check_At_End_Of_Field;
961 Units.Table (Units.Last).Body_Needed_For_SAL := True;
963 -- DE parameter (Dynamic elaboration checks
967 Check_At_End_Of_Field;
968 Units.Table (Units.Last).Dynamic_Elab := True;
969 Dynamic_Elaboration_Checks_Specified := True;
977 Units.Table (Units.Last).Elaborate_Body := True;
980 Units.Table (Units.Last).Set_Elab_Entity := True;
986 Check_At_End_Of_Field;
988 -- GE parameter (generic)
992 Check_At_End_Of_Field;
993 Units.Table (Units.Last).Is_Generic := True;
995 -- IL/IS/IU parameters
1001 Units.Table (Units.Last).Icasing := All_Lower_Case;
1004 Units.Table (Units.Last).Init_Scalars := True;
1005 Initialize_Scalars_Used := True;
1008 Units.Table (Units.Last).Icasing := All_Upper_Case;
1014 Check_At_End_Of_Field;
1022 Units.Table (Units.Last).Kcasing := Mixed_Case;
1025 Units.Table (Units.Last).Kcasing := All_Upper_Case;
1031 Check_At_End_Of_Field;
1037 Units.Table (Units.Last).No_Elab := True;
1038 Check_At_End_Of_Field;
1040 -- PR/PU/PK parameters
1045 -- PR parameter (preelaborate)
1048 Units.Table (Units.Last).Preelab := True;
1050 -- PU parameter (pure)
1053 Units.Table (Units.Last).Pure := True;
1055 -- PK indicates unit is package
1058 Units.Table (Units.Last).Unit_Kind := 'p
';
1064 Check_At_End_Of_Field;
1071 -- RC parameter (remote call interface)
1074 Units.Table (Units.Last).RCI := True;
1076 -- RT parameter (remote types)
1079 Units.Table (Units.Last).Remote_Types := True;
1081 -- RA parameter (remote access to class wide type)
1084 Units.Table (Units.Last).Has_RACW := True;
1090 Check_At_End_Of_Field;
1095 -- SP parameter (shared passive)
1098 Units.Table (Units.Last).Shared_Passive := True;
1100 -- SU parameter indicates unit is subprogram
1103 Units.Table (Units.Last).Unit_Kind := 's
';
1109 Check_At_End_Of_Field;
1118 -- Check if static elaboration model used
1120 if not Units.Table (Units.Last).Dynamic_Elab
1121 and then not Units.Table (Units.Last).Internal
1123 Static_Elaboration_Model_Used := True;
1128 -- Scan out With lines for this unit
1130 With_Loop : while C = 'W
' loop
1131 if Ignore ('W
') then
1137 Withs.Increment_Last;
1138 Withs.Table (Withs.Last).Uname := Get_Name;
1139 Withs.Table (Withs.Last).Elaborate := False;
1140 Withs.Table (Withs.Last).Elaborate_All := False;
1141 Withs.Table (Withs.Last).Elab_All_Desirable := False;
1142 Withs.Table (Withs.Last).Interface := False;
1144 -- Generic case with no object file available
1147 Withs.Table (Withs.Last).Sfile := No_File;
1148 Withs.Table (Withs.Last).Afile := No_File;
1153 Withs.Table (Withs.Last).Sfile := Get_Name (Lower => True);
1154 Withs.Table (Withs.Last).Afile := Get_Name;
1156 -- Scan out possible E, EA, and NE parameters
1158 while not At_Eol loop
1164 if At_End_Of_Field then
1165 Withs.Table (Withs.Last).Elaborate := True;
1167 elsif Nextc = 'A
' then
1169 Check_At_End_Of_Field;
1170 Withs.Table (Withs.Last).Elaborate_All := True;
1174 Check_At_End_Of_Field;
1176 -- Store ED indication unless ignore required
1178 if not Ignore_ED then
1179 Withs.Table (Withs.Last).Elab_All_Desirable :=
1193 Units.Table (Units.Last).Last_With := Withs.Last;
1194 Units.Table (Units.Last).Last_Arg := Args.Last;
1196 -- If there are linker options lines present, scan them
1200 Linker_Options_Loop : while C = 'L
' loop
1202 if Ignore ('L
') then
1213 if C < Character'Val (16#20#)
1214 or else C > Character'Val (16#7E#)
1219 C := Character'Val (0);
1226 for J in 1 .. 2 loop
1229 if C in '0' .. '9' then
1232 Character'Pos ('0');
1234 elsif C in 'A' .. 'F' then
1237 Character'Pos ('A') +
1246 Add_Char_To_Name_Buffer (Character'Val (V));
1251 exit when Nextc /= '"';
1255 Add_Char_To_Name_Buffer (C);
1259 Add_Char_To_Name_Buffer (nul);
1264 end loop Linker_Options_Loop;
1266 -- Store the linker options entry if one was found
1268 if Name_Len /= 0 then
1269 Linker_Options.Increment_Last;
1271 Linker_Options.Table (Linker_Options.Last).Name :=
1274 Linker_Options.Table (Linker_Options.Last).Unit :=
1277 Linker_Options.Table (Linker_Options.Last).Internal_File :=
1278 Is_Internal_File_Name (F);
1280 Linker_Options.Table (Linker_Options.Last).Original_Pos :=
1281 Linker_Options.Last;
1285 -- End loop through units for one ALI file
1287 ALIs.Table (Id).Last_Unit := Units.Last;
1288 ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile;
1290 -- Set types of the units (there can be at most 2 of them)
1292 if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then
1293 Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body;
1294 Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec;
1297 -- Deal with body only and spec only cases, note that the reason we
1298 -- do our own checking of the name (rather than using Is_Body_Name)
1299 -- is that Uname drags in far too much compiler junk!
1301 Get_Name_String (Units.Table (Units.Last).Uname);
1303 if Name_Buffer (Name_Len) = 'b' then
1304 Units.Table (Units.Last).Utype := Is_Body_Only;
1306 Units.Table (Units.Last).Utype := Is_Spec_Only;
1310 -- Scan out external version references and put in hash table
1313 if Ignore ('E') then
1329 exit when At_End_Of_Field;
1330 Add_Char_To_Name_Buffer (C);
1333 Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
1340 -- Scan out source dependency lines for this ALI file
1342 ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
1345 if Ignore ('D') then
1351 Sdep.Increment_Last;
1352 Sdep.Table (Sdep.Last).Sfile := Get_Name (Lower => True);
1353 Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
1354 Sdep.Table (Sdep.Last).Dummy_Entry :=
1355 (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
1357 -- Acquire checksum value
1370 exit when At_Eol or else Ctr = 8;
1372 if Nextc in '0' .. '9' then
1374 Character'Pos (Nextc) - Character'Pos ('0');
1376 elsif Nextc in 'a' .. 'f' then
1378 Character'Pos (Nextc) - Character'Pos ('a') + 10;
1388 if Ctr = 8 and then At_End_Of_Field then
1389 Sdep.Table (Sdep.Last).Checksum := Chk;
1395 -- Acquire subunit and reference file name entries
1397 Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
1398 Sdep.Table (Sdep.Last).Rfile :=
1399 Sdep.Table (Sdep.Last).Sfile;
1400 Sdep.Table (Sdep.Last).Start_Line := 1;
1405 -- Here for subunit name
1407 if Nextc not in '0' .. '9' then
1410 while not At_End_Of_Field loop
1411 Name_Len := Name_Len + 1;
1412 Name_Buffer (Name_Len) := Getc;
1415 Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter;
1419 -- Here for reference file name entry
1421 if Nextc in '0' .. '9' then
1422 Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
1427 while not At_End_Of_Field loop
1428 Name_Len := Name_Len + 1;
1429 Name_Buffer (Name_Len) := Getc;
1432 Sdep.Table (Sdep.Last).Rfile := Name_Enter;
1442 ALIs.Table (Id).Last_Sdep := Sdep.Last;
1444 -- We must at this stage be at an Xref line or the end of file
1446 if C /= EOF and then C /= 'X' then
1450 -- If we are ignoring Xref sections we are done (we ignore all
1451 -- remaining lines since only xref related lines follow X).
1453 if Ignore ('X') and then not Debug_Flag_X then
1457 -- Loop through Xref sections
1461 -- Make new entry in section table
1463 Xref_Section.Increment_Last;
1465 Read_Refs_For_One_File : declare
1466 XS : Xref_Section_Record renames
1467 Xref_Section.Table (Xref_Section.Last);
1469 Current_File_Num : Sdep_Id;
1470 -- Keeps track of the current file number (changed by nn|)
1473 XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
1474 XS.File_Name := Get_Name;
1475 XS.First_Entity := Xref_Entity.Last + 1;
1477 Current_File_Num := XS.File_Num;
1484 -- Loop through Xref entities
1486 while C /= 'X' and then C /= EOF loop
1487 Xref_Entity.Increment_Last;
1489 Read_Refs_For_One_Entity : declare
1491 XE : Xref_Entity_Record renames
1492 Xref_Entity.Table (Xref_Entity.Last);
1496 procedure Read_Instantiation_Reference;
1497 -- Acquire instantiation reference. Caller has checked
1498 -- that current character is '[' and on return the cursor
1499 -- is skipped past the corresponding closing ']'.
1501 ----------------------------------
1502 -- Read_Instantiation_Reference --
1503 ----------------------------------
1505 procedure Read_Instantiation_Reference is
1507 Xref.Increment_Last;
1510 XR : Xref_Record renames Xref.Table (Xref.Last);
1513 P := P + 1; -- skip [
1518 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
1519 Current_File_Num := XR.File_Num;
1524 XR.File_Num := Current_File_Num;
1531 -- Recursive call for next reference
1534 pragma Warnings (Off); -- kill recursion warning
1535 Read_Instantiation_Reference;
1536 pragma Warnings (On);
1539 -- Skip closing bracket after recursive call
1543 end Read_Instantiation_Reference;
1545 -- Start of processing for Read_Refs_For_One_Entity
1551 XE.Lib := (Getc = '*');
1552 XE.Entity := Get_Name;
1554 Current_File_Num := XS.File_Num;
1556 -- Renaming reference is present
1560 XE.Rref_Line := Get_Nat;
1566 XE.Rref_Col := Get_Nat;
1568 -- No renaming reference present
1577 -- See if type reference present
1580 when '<' => XE.Tref := Tref_Derived;
1581 when '(' => XE.Tref := Tref_Access;
1582 when '{' => XE.Tref := Tref_Type;
1583 when others => XE.Tref := Tref_None;
1586 -- Case of typeref field present
1588 if XE.Tref /= Tref_None then
1589 P := P + 1; -- skip opening bracket
1591 if Nextc in 'a' .. 'z' then
1592 XE.Tref_File_Num := No_Sdep_Id;
1594 XE.Tref_Type := ' ';
1596 XE.Tref_Standard_Entity :=
1597 Get_Name (Ignore_Spaces => True);
1604 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
1609 XE.Tref_File_Num := Current_File_Num;
1613 XE.Tref_Type := Getc;
1614 XE.Tref_Col := Get_Nat;
1615 XE.Tref_Standard_Entity := No_Name;
1618 -- ??? Temporary workaround for nested generics case:
1619 -- 4i4 Directories{1|4I9[4|6[3|3]]}
1623 Nested_Brackets : Natural := 0;
1630 Nested_Brackets := Nested_Brackets + 1;
1632 Nested_Brackets := Nested_Brackets - 1;
1634 if Nested_Brackets = 0 then
1643 P := P + 1; -- skip closing bracket
1646 -- No typeref entry present
1649 XE.Tref_File_Num := No_Sdep_Id;
1651 XE.Tref_Type := ' ';
1653 XE.Tref_Standard_Entity := No_Name;
1656 XE.First_Xref := Xref.Last + 1;
1658 -- Loop through cross-references for this entity
1665 exit when Nextc /= '.';
1669 Xref.Increment_Last;
1672 XR : Xref_Record renames Xref.Table (Xref.Last);
1679 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
1680 Current_File_Num := XR.File_Num;
1685 XR.File_Num := Current_File_Num;
1691 -- Imported entities reference as in:
1692 -- 494b<c,__gnat_copy_attribs>25
1693 -- ??? Simply skipped for now
1696 while Getc /= '>' loop
1704 Read_Instantiation_Reference;
1709 -- Record last cross-reference
1711 XE.Last_Xref := Xref.Last;
1714 end Read_Refs_For_One_Entity;
1717 -- Record last entity
1719 XS.Last_Entity := Xref_Entity.Last;
1721 end Read_Refs_For_One_File;
1726 -- Here after dealing with xref sections
1728 if C /= EOF and then C /= 'X' then
1735 when Bad_ALI_Format =>
1744 function SEq (F1, F2 : String_Ptr) return Boolean is
1746 return F1.all = F2.all;
1753 function SHash (S : String_Ptr) return Vindex is
1758 for J in S.all'Range loop
1759 H := H * 2 + Character'Pos (S (J));
1762 return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));