1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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 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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Butil; use Butil;
27 with Debug; use Debug;
28 with Fname; use Fname;
30 with Osint; use Osint;
31 with Output; use Output;
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
51 'L' => True, -- linker option
52 'E' => True, -- external
53 'D' => True, -- dependency
55 'S' => True, -- specific dispatching
62 procedure Initialize_ALI is
64 -- When (re)initializing ALI data structures the ALI user expects to
65 -- get a fresh set of data structures. Thus we first need to erase the
66 -- marks put in the name table by the previous set of ALI routine calls.
67 -- These two loops are empty and harmless the first time in.
69 for J in ALIs.First .. ALIs.Last loop
70 Set_Name_Table_Info (ALIs.Table (J).Afile, 0);
73 for J in Units.First .. Units.Last loop
74 Set_Name_Table_Info (Units.Table (J).Uname, 0);
77 -- Free argument table strings
79 for J in Args.First .. Args.Last loop
80 Free (Args.Table (J));
83 -- Initialize all tables
96 -- Add dummy zero'th item in Linker_Options for the sort function
98 Linker_Options.Increment_Last;
100 -- Initialize global variables recording cumulative options in all
101 -- ALI files that are read for a given processing run in gnatbind.
103 Dynamic_Elaboration_Checks_Specified := False;
104 Float_Format_Specified := ' ';
105 Locking_Policy_Specified := ' ';
106 No_Normalize_Scalars_Specified := False;
107 No_Object_Specified := False;
108 Normalize_Scalars_Specified := False;
109 Queuing_Policy_Specified := ' ';
110 Static_Elaboration_Model_Used := False;
111 Task_Dispatching_Policy_Specified := ' ';
112 Unreserve_All_Interrupts_Specified := False;
113 Zero_Cost_Exceptions_Specified := False;
125 Read_Xref : Boolean := False;
126 Read_Lines : String := "";
127 Ignore_Lines : String := "X";
128 Ignore_Errors : Boolean := False) return ALI_Id
130 P : Text_Ptr := T'First;
131 Line : Logical_Line_Number := 1;
137 Ignore : array (Character range 'A' .. 'Z') of Boolean;
138 -- Ignore (X) is set to True if lines starting with X are to
139 -- be ignored by Scan_ALI and skipped, and False if the lines
140 -- are to be read and processed.
142 Bad_ALI_Format : exception;
143 -- Exception raised by Fatal_Error if Err is True
145 function At_Eol return Boolean;
146 -- Test if at end of line
148 function At_End_Of_Field return Boolean;
149 -- Test if at end of line, or if at blank or horizontal tab
151 procedure Check_At_End_Of_Field;
152 -- Check if we are at end of field, fatal error if not
154 procedure Checkc (C : Character);
155 -- Check next character is C. If so bump past it, if not fatal error
157 procedure Check_Unknown_Line;
158 -- If Ignore_Errors mode, then checks C to make sure that it is not
159 -- an unknown ALI line type characters, and if so, skips lines
160 -- until the first character of the line is one of these characters,
161 -- at which point it does a Getc to put that character in C. The
162 -- call has no effect if C is already an appropriate character.
163 -- If not in Ignore_Errors mode, a fatal error is signalled if the
164 -- line is unknown. Note that if C is an EOL on entry, the line is
165 -- skipped (it is assumed that blank lines are never significant).
166 -- If C is EOF on entry, the call has no effect (it is assumed that
167 -- the caller will properly handle this case).
169 procedure Fatal_Error;
170 -- Generate fatal error message for badly formatted ALI file if
171 -- Err is false, or raise Bad_ALI_Format if Err is True.
173 procedure Fatal_Error_Ignore;
174 pragma Inline (Fatal_Error_Ignore);
175 -- In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error
177 function Getc return Character;
178 -- Get next character, bumping P past the character obtained
180 function Get_File_Name (Lower : Boolean := False) return File_Name_Type;
181 -- Skip blanks, then scan out a file name (name is left in Name_Buffer
182 -- with length in Name_Len, as well as returning a File_Name_Type value.
183 -- If lower is false, the case is unchanged, if Lower is True then the
184 -- result is forced to all lower case for systems where file names are
185 -- not case sensitive. This ensures that gnatbind works correctly
186 -- regardless of the case of the file name on all systems. The scan
187 -- is terminated by a end of line, space or horizontal tab. Any other
188 -- special characters are included in the returned name.
191 (Ignore_Spaces : Boolean := False;
192 Ignore_Special : Boolean := False)return Name_Id;
193 -- Skip blanks, then scan out a name (name is left in Name_Buffer with
194 -- length in Name_Len, as well as being returned in Name_Id form).
195 -- If Lower is set to True then the Name_Buffer will be converted to
196 -- all lower case, for systems where file names are not case sensitive.
197 -- This ensures that gnatbind works correctly regardless of the case
198 -- of the file name on all systems. The termination condition depends
199 -- on the settings of Ignore_Spaces and Ignore_Special:
201 -- If Ignore_Spaces is False (normal case), then scan is terminated
202 -- by the normal end of field condition (EOL, space, horizontal tab)
204 -- If Ignore_Special is False (normal case), the scan is terminated by
205 -- a typeref bracket or an equal sign except for the special case of
206 -- an operator name starting with a double quite which is terminated
207 -- by another double quote.
209 -- It is an error to set both Ignore_Spaces and Ignore_Special to True.
210 -- This function handles wide characters properly.
212 function Get_Nat return Nat;
213 -- Skip blanks, then scan out an unsigned integer value in Nat range
214 -- raises ALI_Reading_Error if the encoutered type is not natural.
216 function Get_Stamp return Time_Stamp_Type;
217 -- Skip blanks, then scan out a time stamp
219 function Get_Unit_Name return Unit_Name_Type;
220 -- Skip blanks, then scan out a file name (name is left in Name_Buffer
221 -- with length in Name_Len, as well as returning a Unit_Name_Type value.
222 -- The case is unchanged and terminated by a normal end of field.
224 function Nextc return Character;
225 -- Return current character without modifying pointer P
227 procedure Get_Typeref
228 (Current_File_Num : Sdep_Id;
230 File_Num : out Sdep_Id;
232 Ref_Type : out Character;
234 Standard_Entity : out Name_Id);
235 -- Parse the definition of a typeref (<...>, {...} or (...))
238 -- Skip past spaces, then skip past end of line (fatal error if not
239 -- at end of line). Also skips past any following blank lines.
242 -- Skip rest of current line and any following blank lines
244 procedure Skip_Space;
245 -- Skip past white space (blanks or horizontal tab)
248 -- Skip past next character, does not affect value in C. This call
249 -- is like calling Getc and ignoring the returned result.
251 ---------------------
252 -- At_End_Of_Field --
253 ---------------------
255 function At_End_Of_Field return Boolean is
264 function At_Eol return Boolean is
266 return Nextc = EOF or else Nextc = CR or else Nextc = LF;
269 ---------------------------
270 -- Check_At_End_Of_Field --
271 ---------------------------
273 procedure Check_At_End_Of_Field is
275 if not At_End_Of_Field then
276 if Ignore_Errors then
277 while Nextc > ' ' loop
284 end Check_At_End_Of_Field;
286 ------------------------
287 -- Check_Unknown_Line --
288 ------------------------
290 procedure Check_Unknown_Line is
292 while C not in 'A' .. 'Z'
293 or else not Known_ALI_Lines (C)
295 if C = CR or else C = LF then
302 elsif Ignore_Errors then
310 end Check_Unknown_Line;
316 procedure Checkc (C : Character) is
320 elsif Ignore_Errors then
331 procedure Fatal_Error is
336 procedure Wchar (C : Character);
337 -- Write a single character, replacing horizontal tab by spaces
339 procedure Wchar (C : Character) is
344 exit when Col mod 8 = 0;
353 -- Start of processing for Fatal_Error
357 raise Bad_ALI_Format;
361 Write_Str ("fatal error: file ");
363 Write_Str (" is incorrectly formatted");
366 Write_Str ("make sure you are using consistent versions " &
368 -- Split the following line so that it can easily be transformed for
369 -- e.g. JVM/.NET back-ends where the compiler has a different name.
375 -- Find start of line
379 and then T (Ptr1 - 1) /= CR
380 and then T (Ptr1 - 1) /= LF
385 Write_Int (Int (Line));
400 and then T (Ptr2) /= CR
401 and then T (Ptr2) /= LF
413 if T (Ptr1) = HT then
425 Exit_Program (E_Fatal);
428 ------------------------
429 -- Fatal_Error_Ignore --
430 ------------------------
432 procedure Fatal_Error_Ignore is
434 if not Ignore_Errors then
437 end Fatal_Error_Ignore;
443 function Get_File_Name
444 (Lower : Boolean := False) return File_Name_Type
449 F := Get_Name (Ignore_Special => True);
451 -- Convert file name to all lower case if file names are not case
452 -- sensitive. This ensures that we handle names in the canonical
453 -- lower case format, regardless of the actual case.
455 if Lower and not File_Names_Case_Sensitive then
456 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
459 return File_Name_Type (F);
468 (Ignore_Spaces : Boolean := False;
469 Ignore_Special : Boolean := False) return Name_Id
476 if Ignore_Errors then
484 Name_Len := Name_Len + 1;
485 Name_Buffer (Name_Len) := Getc;
487 exit when At_End_Of_Field and not Ignore_Spaces;
489 if not Ignore_Special then
490 if Name_Buffer (1) = '"' then
491 exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';
494 -- Terminate on parens or angle brackets or equal sign
496 exit when Nextc = '(' or else Nextc = ')'
497 or else Nextc = '{' or else Nextc = '}'
498 or else Nextc = '<' or else Nextc = '>'
501 -- Terminate if left bracket not part of wide char sequence
502 -- Note that we only recognize brackets notation so far ???
504 exit when Nextc = '[' and then T (P + 1) /= '"';
506 -- Terminate if right bracket not part of wide char sequence
508 exit when Nextc = ']' and then T (P - 1) /= '"';
520 function Get_Unit_Name return Unit_Name_Type is
522 return Unit_Name_Type (Get_Name);
529 function Get_Nat return Nat is
535 -- Check if we are on a number. In the case of bas ALI files, this
538 if not (Nextc in '0' .. '9') then
544 V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0'));
546 exit when At_End_Of_Field;
547 exit when Nextc < '0' or Nextc > '9';
557 function Get_Stamp return Time_Stamp_Type is
565 if Ignore_Errors then
566 return Dummy_Time_Stamp;
572 -- Following reads old style time stamp missing first two digits
574 if Nextc in '7' .. '9' then
579 -- Normal case of full year in time stamp
585 for J in Start .. T'Last loop
596 procedure Get_Typeref
597 (Current_File_Num : Sdep_Id;
599 File_Num : out Sdep_Id;
601 Ref_Type : out Character;
603 Standard_Entity : out Name_Id)
608 when '<' => Ref := Tref_Derived;
609 when '(' => Ref := Tref_Access;
610 when '{' => Ref := Tref_Type;
611 when others => Ref := Tref_None;
614 -- Case of typeref field present
616 if Ref /= Tref_None then
617 P := P + 1; -- skip opening bracket
619 if Nextc in 'a' .. 'z' then
620 File_Num := No_Sdep_Id;
624 Standard_Entity := Get_Name (Ignore_Spaces => True);
629 File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
633 File_Num := Current_File_Num;
639 Standard_Entity := No_Name;
642 -- ??? Temporary workaround for nested generics case:
643 -- 4i4 Directories{1|4I9[4|6[3|3]]}
647 Nested_Brackets : Natural := 0;
653 Nested_Brackets := Nested_Brackets + 1;
655 Nested_Brackets := Nested_Brackets - 1;
657 if Nested_Brackets = 0 then
666 P := P + 1; -- skip closing bracket
669 -- No typeref entry present
672 File_Num := No_Sdep_Id;
676 Standard_Entity := No_Name;
684 function Getc return Character is
698 function Nextc return Character is
707 procedure Skip_Eol is
712 if Ignore_Errors then
713 while not At_Eol loop
721 -- Loop to skip past blank lines (first time through skips this EOL)
723 while Nextc < ' ' and then Nextc /= EOF loop
736 procedure Skip_Line is
738 while not At_Eol loop
749 procedure Skip_Space is
751 while Nextc = ' ' or else Nextc = HT loop
767 -- Start of processing for Scan_ALI
770 First_Sdep_Entry := Sdep.Last + 1;
772 -- Acquire lines to be ignored
775 Ignore := ('U' | 'W' | 'D' | 'X' => False, others => True);
777 -- Read_Lines parameter given
779 elsif Read_Lines /= "" then
780 Ignore := ('U' => False, others => True);
782 for J in Read_Lines'Range loop
783 Ignore (Read_Lines (J)) := False;
786 -- Process Ignore_Lines parameter
789 Ignore := (others => False);
791 for J in Ignore_Lines'Range loop
792 pragma Assert (Ignore_Lines (J) /= 'U');
793 Ignore (Ignore_Lines (J)) := True;
797 -- Setup ALI Table entry with appropriate defaults
801 Set_Name_Table_Info (F, Int (Id));
805 Compile_Errors => False,
806 First_Interrupt_State => Interrupt_States.Last + 1,
807 First_Sdep => No_Sdep_Id,
808 First_Specific_Dispatching => Specific_Dispatching.Last + 1,
809 First_Unit => No_Unit_Id,
811 Last_Interrupt_State => Interrupt_States.Last,
812 Last_Sdep => No_Sdep_Id,
813 Last_Specific_Dispatching => Specific_Dispatching.Last,
814 Last_Unit => No_Unit_Id,
815 Locking_Policy => ' ',
817 Main_Program => None,
819 Normalize_Scalars => False,
820 Ofile_Full_Name => Full_Object_File_Name,
821 Queuing_Policy => ' ',
822 Restrictions => No_Restrictions,
823 SAL_Interface => False,
825 Task_Dispatching_Policy => ' ',
826 Time_Slice_Value => -1,
828 Unit_Exception_Table => False,
829 Ver => (others => ' '),
831 Zero_Cost_Exceptions => False);
833 -- Now we acquire the input lines from the ALI file. Note that the
834 -- convention in the following code is that as we enter each section,
835 -- C is set to contain the first character of the following line.
840 -- Acquire library version
844 -- The V line missing really indicates trouble, most likely it
845 -- means we don't have an ALI file at all, so here we give a
846 -- fatal error even if we are in Ignore_Errors mode.
850 elsif Ignore ('V') then
858 for J in 1 .. Ver_Len_Max loop
861 ALIs.Table (Id).Ver (J) := C;
862 ALIs.Table (Id).Ver_Len := J;
871 -- Acquire main program line if present
884 ALIs.Table (Id).Main_Program := Func;
886 ALIs.Table (Id).Main_Program := Proc;
896 ALIs.Table (Id).Main_Priority := Get_Nat;
904 ALIs.Table (Id).Time_Slice_Value := Get_Nat;
911 ALIs.Table (Id).WC_Encoding := Getc;
920 -- Acquire argument lines
922 First_Arg := Args.Last + 1;
926 exit A_Loop when C /= 'A';
935 while not At_Eol loop
936 Name_Len := Name_Len + 1;
937 Name_Buffer (Name_Len) := Getc;
941 Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len));
954 if Ignore_Errors then
974 while not At_Eol loop
983 ALIs.Table (Id).Compile_Errors := True;
989 Detect_Blocking := True;
991 -- Processing for FD/FG/FI
994 Float_Format_Specified := Getc;
995 ALIs.Table (Id).Float_Format := Float_Format_Specified;
1000 Locking_Policy_Specified := Getc;
1001 ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
1003 -- Processing for flags starting with N
1008 -- Processing for NO
1011 ALIs.Table (Id).No_Object := True;
1012 No_Object_Specified := True;
1014 -- Processing for NR
1017 No_Run_Time_Mode := True;
1018 Configurable_Run_Time_Mode := True;
1020 -- Processing for NS
1023 ALIs.Table (Id).Normalize_Scalars := True;
1024 Normalize_Scalars_Specified := True;
1027 -- Invalid switch starting with N
1033 -- Processing for Qx
1036 Queuing_Policy_Specified := Getc;
1037 ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
1039 -- Processing for flags starting with S
1044 -- Processing for SL
1047 ALIs.Table (Id).SAL_Interface := True;
1049 -- Processing for SS
1052 Opt.Sec_Stack_Used := True;
1054 -- Invalid switch starting with S
1060 -- Processing for Tx
1063 Task_Dispatching_Policy_Specified := Getc;
1064 ALIs.Table (Id).Task_Dispatching_Policy :=
1065 Task_Dispatching_Policy_Specified;
1067 -- Processing for switch starting with U
1072 -- Processing for UA
1075 Unreserve_All_Interrupts_Specified := True;
1077 -- Processing for UX
1080 ALIs.Table (Id).Unit_Exception_Table := True;
1082 -- Invalid switches starting with U
1088 -- Processing for ZX
1094 ALIs.Table (Id).Zero_Cost_Exceptions := True;
1095 Zero_Cost_Exceptions_Specified := True;
1100 -- Invalid parameter
1108 if not NS_Found then
1109 No_Normalize_Scalars_Specified := True;
1118 -- Acquire first restrictions line
1121 if Ignore_Errors then
1133 if Ignore ('R') then
1136 -- Process restrictions line
1139 Scan_Restrictions : declare
1140 Save_R : constant Restrictions_Info := Cumulative_Restrictions;
1141 -- Save cumulative restrictions in case we have a fatal error
1143 Bad_R_Line : exception;
1144 -- Signal bad restrictions line (raised on unexpected character)
1150 -- Acquire information for boolean restrictions
1152 for R in All_Boolean_Restrictions loop
1157 ALIs.Table (Id).Restrictions.Violated (R) := True;
1158 Cumulative_Restrictions.Violated (R) := True;
1161 ALIs.Table (Id).Restrictions.Set (R) := True;
1162 Cumulative_Restrictions.Set (R) := True;
1172 -- Acquire information for parameter restrictions
1174 for RP in All_Parameter_Restrictions loop
1176 -- Acquire restrictions pragma information
1183 ALIs.Table (Id).Restrictions.Set (RP) := True;
1186 N : constant Integer := Integer (Get_Nat);
1188 ALIs.Table (Id).Restrictions.Value (RP) := N;
1190 if Cumulative_Restrictions.Set (RP) then
1191 Cumulative_Restrictions.Value (RP) :=
1193 (Cumulative_Restrictions.Value (RP), N);
1195 Cumulative_Restrictions.Set (RP) := True;
1196 Cumulative_Restrictions.Value (RP) := N;
1204 -- Acquire restrictions violations information
1211 ALIs.Table (Id).Restrictions.Violated (RP) := True;
1212 Cumulative_Restrictions.Violated (RP) := True;
1215 N : constant Integer := Integer (Get_Nat);
1216 pragma Unsuppress (Overflow_Check);
1219 ALIs.Table (Id).Restrictions.Count (RP) := N;
1221 if RP in Checked_Max_Parameter_Restrictions then
1222 Cumulative_Restrictions.Count (RP) :=
1224 (Cumulative_Restrictions.Count (RP), N);
1226 Cumulative_Restrictions.Count (RP) :=
1227 Cumulative_Restrictions.Count (RP) + N;
1231 when Constraint_Error =>
1233 -- A constraint error comes from the addition in
1234 -- the else branch. We reset to the maximum and
1235 -- indicate that the real value is now unknown.
1237 Cumulative_Restrictions.Value (RP) := Integer'Last;
1238 Cumulative_Restrictions.Unknown (RP) := True;
1243 ALIs.Table (Id).Restrictions.Unknown (RP) := True;
1244 Cumulative_Restrictions.Unknown (RP) := True;
1254 -- Here if error during scanning of restrictions line
1259 -- In Ignore_Errors mode, undo any changes to restrictions
1260 -- from this unit, and continue on.
1262 if Ignore_Errors then
1263 Cumulative_Restrictions := Save_R;
1264 ALIs.Table (Id).Restrictions := No_Restrictions;
1267 -- In normal mode, this is a fatal error
1273 end Scan_Restrictions;
1276 -- Acquire additional restrictions (No_Dependence) lines if present
1280 if Ignore ('R') then
1284 No_Deps.Append ((Id, Get_Name));
1291 -- Acquire 'I' lines if present
1296 if Ignore ('I') then
1302 I_State : Character;
1311 Interrupt_States.Append (
1312 (Interrupt_Id => Int_Num,
1313 Interrupt_State => I_State,
1314 IS_Pragma_Line => Line_No));
1316 ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last;
1324 -- Acquire 'S' lines if present
1329 if Ignore ('S') then
1345 First_Prio := Get_Nat;
1346 Last_Prio := Get_Nat;
1349 Specific_Dispatching.Append (
1350 (Dispatching_Policy => Policy,
1351 First_Priority => First_Prio,
1352 Last_Priority => Last_Prio,
1353 PSD_Pragma_Line => Line_No));
1355 ALIs.Table (Id).Last_Specific_Dispatching :=
1356 Specific_Dispatching.Last;
1365 -- Loop to acquire unit entries
1369 exit U_Loop when C /= 'U';
1371 -- Note: as per spec, we never ignore U lines
1375 Units.Increment_Last;
1377 if ALIs.Table (Id).First_Unit = No_Unit_Id then
1378 ALIs.Table (Id).First_Unit := Units.Last;
1382 UL : Unit_Record renames Units.Table (Units.Last);
1385 UL.Uname := Get_Unit_Name;
1386 UL.Predefined := Is_Predefined_Unit;
1387 UL.Internal := Is_Internal_Unit;
1389 UL.Sfile := Get_File_Name (Lower => True);
1391 UL.Preelab := False;
1392 UL.No_Elab := False;
1393 UL.Shared_Passive := False;
1395 UL.Remote_Types := False;
1396 UL.Has_RACW := False;
1397 UL.Init_Scalars := False;
1398 UL.Is_Generic := False;
1399 UL.Icasing := Mixed_Case;
1400 UL.Kcasing := All_Lower_Case;
1401 UL.Dynamic_Elab := False;
1402 UL.Elaborate_Body := False;
1403 UL.Set_Elab_Entity := False;
1404 UL.Version := "00000000";
1405 UL.First_With := Withs.Last + 1;
1406 UL.First_Arg := First_Arg;
1407 UL.Elab_Position := 0;
1408 UL.SAL_Interface := ALIs.Table (Id).SAL_Interface;
1409 UL.Body_Needed_For_SAL := False;
1410 UL.Elaborate_Body_Desirable := False;
1412 if Debug_Flag_U then
1413 Write_Str (" ----> reading unit ");
1414 Write_Int (Int (Units.Last));
1416 Write_Unit_Name (UL.Uname);
1417 Write_Str (" from file ");
1418 Write_Name (UL.Sfile);
1423 -- Check for duplicated unit in different files
1426 Info : constant Int := Get_Name_Table_Info
1427 (Units.Table (Units.Last).Uname);
1430 and then Units.Table (Units.Last).Sfile /=
1431 Units.Table (Unit_Id (Info)).Sfile
1433 -- If Err is set then ignore duplicate unit name. This is the
1434 -- case of a call from gnatmake, where the situation can arise
1435 -- from substitution of source files. In such situations, the
1436 -- processing in gnatmake will always result in any required
1437 -- recompilations in any case, and if we consider this to be
1438 -- an error we get strange cases (for example when a generic
1439 -- instantiation is replaced by a normal package) where we
1440 -- read the old ali file, decide to recompile, and then decide
1441 -- that the old and new ali files are incompatible.
1446 -- If Err is not set, then this is a fatal error. This is
1447 -- the case of being called from the binder, where we must
1448 -- definitely diagnose this as an error.
1452 Write_Str ("error: duplicate unit name: ");
1455 Write_Str ("error: unit """);
1456 Write_Unit_Name (Units.Table (Units.Last).Uname);
1457 Write_Str (""" found in file """);
1458 Write_Name_Decoded (Units.Table (Units.Last).Sfile);
1462 Write_Str ("error: unit """);
1463 Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
1464 Write_Str (""" found in file """);
1465 Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
1469 Exit_Program (E_Fatal);
1475 (Units.Table (Units.Last).Uname, Int (Units.Last));
1477 -- Scan out possible version and other parameters
1486 if C in '0' .. '9' or else C in 'a' .. 'f' then
1487 Units.Table (Units.Last).Version (1) := C;
1489 for J in 2 .. 8 loop
1491 Units.Table (Units.Last).Version (J) := C;
1500 Check_At_End_Of_Field;
1501 Units.Table (Units.Last).Elaborate_Body_Desirable := True;
1504 Check_At_End_Of_Field;
1505 Units.Table (Units.Last).Body_Needed_For_SAL := True;
1511 -- DE parameter (Dynamic elaboration checks)
1517 Check_At_End_Of_Field;
1518 Units.Table (Units.Last).Dynamic_Elab := True;
1519 Dynamic_Elaboration_Checks_Specified := True;
1530 Units.Table (Units.Last).Elaborate_Body := True;
1532 Units.Table (Units.Last).Set_Elab_Entity := True;
1537 Check_At_End_Of_Field;
1539 -- GE parameter (generic)
1545 Check_At_End_Of_Field;
1546 Units.Table (Units.Last).Is_Generic := True;
1551 -- IL/IS/IU parameters
1557 Units.Table (Units.Last).Icasing := All_Lower_Case;
1559 Units.Table (Units.Last).Init_Scalars := True;
1560 Initialize_Scalars_Used := True;
1562 Units.Table (Units.Last).Icasing := All_Upper_Case;
1567 Check_At_End_Of_Field;
1575 Units.Table (Units.Last).Kcasing := Mixed_Case;
1577 Units.Table (Units.Last).Kcasing := All_Upper_Case;
1582 Check_At_End_Of_Field;
1590 Units.Table (Units.Last).No_Elab := True;
1591 Check_At_End_Of_Field;
1596 -- PR/PU/PK parameters
1602 Units.Table (Units.Last).Preelab := True;
1604 Units.Table (Units.Last).Pure := True;
1606 Units.Table (Units.Last).Unit_Kind := 'p';
1611 Check_At_End_Of_Field;
1619 Units.Table (Units.Last).RCI := True;
1621 Units.Table (Units.Last).Remote_Types := True;
1623 Units.Table (Units.Last).Has_RACW := True;
1628 Check_At_End_Of_Field;
1634 Units.Table (Units.Last).Shared_Passive := True;
1636 Units.Table (Units.Last).Unit_Kind := 's';
1641 Check_At_End_Of_Field;
1651 -- Check if static elaboration model used
1653 if not Units.Table (Units.Last).Dynamic_Elab
1654 and then not Units.Table (Units.Last).Internal
1656 Static_Elaboration_Model_Used := True;
1661 -- Scan out With lines for this unit
1665 exit With_Loop when C /= 'W';
1667 if Ignore ('W') then
1673 Withs.Increment_Last;
1674 Withs.Table (Withs.Last).Uname := Get_Unit_Name;
1675 Withs.Table (Withs.Last).Elaborate := False;
1676 Withs.Table (Withs.Last).Elaborate_All := False;
1677 Withs.Table (Withs.Last).Elab_Desirable := False;
1678 Withs.Table (Withs.Last).Elab_All_Desirable := False;
1679 Withs.Table (Withs.Last).SAL_Interface := False;
1681 -- Generic case with no object file available
1684 Withs.Table (Withs.Last).Sfile := No_File;
1685 Withs.Table (Withs.Last).Afile := No_File;
1690 Withs.Table (Withs.Last).Sfile := Get_File_Name
1692 Withs.Table (Withs.Last).Afile := Get_File_Name
1695 -- Scan out possible E, EA, ED, and AD parameters
1697 while not At_Eol loop
1703 Check_At_End_Of_Field;
1705 -- Store AD indication unless ignore required
1707 if not Ignore_ED then
1708 Withs.Table (Withs.Last).Elab_All_Desirable :=
1712 elsif Nextc = 'E' then
1715 if At_End_Of_Field then
1716 Withs.Table (Withs.Last).Elaborate := True;
1718 elsif Nextc = 'A' then
1720 Check_At_End_Of_Field;
1721 Withs.Table (Withs.Last).Elaborate_All := True;
1725 Check_At_End_Of_Field;
1727 -- Store ED indication unless ignore required
1729 if not Ignore_ED then
1730 Withs.Table (Withs.Last).Elab_Desirable :=
1747 Units.Table (Units.Last).Last_With := Withs.Last;
1748 Units.Table (Units.Last).Last_Arg := Args.Last;
1750 -- If there are linker options lines present, scan them
1754 Linker_Options_Loop : loop
1756 exit Linker_Options_Loop when C /= 'L';
1758 if Ignore ('L') then
1769 if C < Character'Val (16#20#)
1770 or else C > Character'Val (16#7E#)
1775 C := Character'Val (0);
1782 for J in 1 .. 2 loop
1785 if C in '0' .. '9' then
1788 Character'Pos ('0');
1790 elsif C in 'A' .. 'F' then
1793 Character'Pos ('A') +
1802 Add_Char_To_Name_Buffer (Character'Val (V));
1807 exit when Nextc /= '"';
1811 Add_Char_To_Name_Buffer (C);
1815 Add_Char_To_Name_Buffer (nul);
1820 end loop Linker_Options_Loop;
1822 -- Store the linker options entry if one was found
1824 if Name_Len /= 0 then
1825 Linker_Options.Increment_Last;
1827 Linker_Options.Table (Linker_Options.Last).Name :=
1830 Linker_Options.Table (Linker_Options.Last).Unit :=
1833 Linker_Options.Table (Linker_Options.Last).Internal_File :=
1834 Is_Internal_File_Name (F);
1836 Linker_Options.Table (Linker_Options.Last).Original_Pos :=
1837 Linker_Options.Last;
1841 -- End loop through units for one ALI file
1843 ALIs.Table (Id).Last_Unit := Units.Last;
1844 ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile;
1846 -- Set types of the units (there can be at most 2 of them)
1848 if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then
1849 Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body;
1850 Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec;
1853 -- Deal with body only and spec only cases, note that the reason we
1854 -- do our own checking of the name (rather than using Is_Body_Name)
1855 -- is that Uname drags in far too much compiler junk!
1857 Get_Name_String (Units.Table (Units.Last).Uname);
1859 if Name_Buffer (Name_Len) = 'b' then
1860 Units.Table (Units.Last).Utype := Is_Body_Only;
1862 Units.Table (Units.Last).Utype := Is_Spec_Only;
1866 -- Scan out external version references and put in hash table
1870 exit E_Loop when C /= 'E';
1872 if Ignore ('E') then
1888 exit when At_End_Of_Field;
1889 Add_Char_To_Name_Buffer (C);
1892 Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
1899 -- Scan out source dependency lines for this ALI file
1901 ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
1905 exit D_Loop when C /= 'D';
1907 if Ignore ('D') then
1913 Sdep.Increment_Last;
1915 -- In the following call, Lower is not set to True, this is either
1916 -- a bug, or it deserves a special comment as to why this is so???
1918 Sdep.Table (Sdep.Last).Sfile := Get_File_Name;
1920 Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
1921 Sdep.Table (Sdep.Last).Dummy_Entry :=
1922 (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
1924 -- Acquire checksum value
1937 exit when At_Eol or else Ctr = 8;
1939 if Nextc in '0' .. '9' then
1941 Character'Pos (Nextc) - Character'Pos ('0');
1943 elsif Nextc in 'a' .. 'f' then
1945 Character'Pos (Nextc) - Character'Pos ('a') + 10;
1955 if Ctr = 8 and then At_End_Of_Field then
1956 Sdep.Table (Sdep.Last).Checksum := Chk;
1962 -- Acquire subunit and reference file name entries
1964 Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
1965 Sdep.Table (Sdep.Last).Rfile :=
1966 Sdep.Table (Sdep.Last).Sfile;
1967 Sdep.Table (Sdep.Last).Start_Line := 1;
1972 -- Here for subunit name
1974 if Nextc not in '0' .. '9' then
1977 while not At_End_Of_Field loop
1978 Name_Len := Name_Len + 1;
1979 Name_Buffer (Name_Len) := Getc;
1982 Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter;
1986 -- Here for reference file name entry
1988 if Nextc in '0' .. '9' then
1989 Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
1994 while not At_End_Of_Field loop
1995 Name_Len := Name_Len + 1;
1996 Name_Buffer (Name_Len) := Getc;
1999 Sdep.Table (Sdep.Last).Rfile := Name_Enter;
2009 ALIs.Table (Id).Last_Sdep := Sdep.Last;
2011 -- We must at this stage be at an Xref line or the end of file
2023 -- If we are ignoring Xref sections we are done (we ignore all
2024 -- remaining lines since only xref related lines follow X).
2026 if Ignore ('X') and then not Debug_Flag_X then
2030 -- Loop through Xref sections
2034 exit X_Loop when C /= 'X';
2036 -- Make new entry in section table
2038 Xref_Section.Increment_Last;
2040 Read_Refs_For_One_File : declare
2041 XS : Xref_Section_Record renames
2042 Xref_Section.Table (Xref_Section.Last);
2044 Current_File_Num : Sdep_Id;
2045 -- Keeps track of the current file number (changed by nn|)
2048 XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
2049 XS.File_Name := Get_File_Name;
2050 XS.First_Entity := Xref_Entity.Last + 1;
2052 Current_File_Num := XS.File_Num;
2059 -- Loop through Xref entities
2061 while C /= 'X' and then C /= EOF loop
2062 Xref_Entity.Increment_Last;
2064 Read_Refs_For_One_Entity : declare
2065 XE : Xref_Entity_Record renames
2066 Xref_Entity.Table (Xref_Entity.Last);
2069 procedure Read_Instantiation_Reference;
2070 -- Acquire instantiation reference. Caller has checked
2071 -- that current character is '[' and on return the cursor
2072 -- is skipped past the corresponding closing ']'.
2074 ----------------------------------
2075 -- Read_Instantiation_Reference --
2076 ----------------------------------
2078 procedure Read_Instantiation_Reference is
2079 Local_File_Num : Sdep_Id := Current_File_Num;
2082 Xref.Increment_Last;
2085 XR : Xref_Record renames Xref.Table (Xref.Last);
2088 P := P + 1; -- skip [
2093 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2094 Local_File_Num := XR.File_Num;
2099 XR.File_Num := Local_File_Num;
2106 -- Recursive call for next reference
2109 pragma Warnings (Off); -- kill recursion warning
2110 Read_Instantiation_Reference;
2111 pragma Warnings (On);
2114 -- Skip closing bracket after recursive call
2118 end Read_Instantiation_Reference;
2120 -- Start of processing for Read_Refs_For_One_Entity
2126 XE.Lib := (Getc = '*');
2127 XE.Entity := Get_Name;
2129 -- Handle the information about generic instantiations
2132 Skipc; -- Opening '['
2135 if Nextc /= '|' then
2136 XE.Iref_File_Num := Current_File_Num;
2140 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2142 XE.Iref_Line := Get_Nat;
2150 XE.Iref_File_Num := No_Sdep_Id;
2154 Current_File_Num := XS.File_Num;
2156 -- Renaming reference is present
2160 XE.Rref_Line := Get_Nat;
2166 XE.Rref_Col := Get_Nat;
2168 -- No renaming reference present
2177 -- See if type reference present
2180 (Current_File_Num, XE.Tref, XE.Tref_File_Num, XE.Tref_Line,
2181 XE.Tref_Type, XE.Tref_Col, XE.Tref_Standard_Entity);
2183 -- Do we have an overriding procedure, instead ?
2184 if XE.Tref_Type = 'p' then
2185 XE.Oref_File_Num := XE.Tref_File_Num;
2186 XE.Oref_Line := XE.Tref_Line;
2187 XE.Oref_Col := XE.Tref_Col;
2188 XE.Tref_File_Num := No_Sdep_Id;
2189 XE.Tref := Tref_None;
2191 -- We might have additional information about the
2192 -- overloaded subprograms
2196 Standard_Entity : Name_Id;
2200 Ref, XE.Oref_File_Num,
2201 XE.Oref_Line, Typ, XE.Oref_Col, Standard_Entity);
2205 XE.First_Xref := Xref.Last + 1;
2207 -- Loop through cross-references for this entity
2214 exit when Nextc /= '.';
2218 Xref.Increment_Last;
2221 XR : Xref_Record renames Xref.Table (Xref.Last);
2228 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2229 Current_File_Num := XR.File_Num;
2233 XR.File_Num := Current_File_Num;
2239 -- Imported entities reference as in:
2240 -- 494b<c,__gnat_copy_attribs>25
2241 -- ??? Simply skipped for now
2244 while Getc /= '>' loop
2252 Read_Instantiation_Reference;
2257 -- Record last cross-reference
2259 XE.Last_Xref := Xref.Last;
2263 when Bad_ALI_Format =>
2265 -- If ignoring errors, then we skip a line with an
2266 -- unexpected error, and try to continue subsequent
2269 if Ignore_Errors then
2270 Xref_Entity.Decrement_Last;
2274 -- Otherwise, we reraise the fatal exception
2279 end Read_Refs_For_One_Entity;
2282 -- Record last entity
2284 XS.Last_Entity := Xref_Entity.Last;
2286 end Read_Refs_For_One_File;
2291 -- Here after dealing with xref sections
2293 if C /= EOF and then C /= 'X' then
2300 when Bad_ALI_Format =>
2308 function SEq (F1, F2 : String_Ptr) return Boolean is
2310 return F1.all = F2.all;
2317 function SHash (S : String_Ptr) return Vindex is
2322 for J in S.all'Range loop
2323 H := H * 2 + Character'Pos (S (J));
2326 return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));