1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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
56 'Y' => True, -- limited_with
63 procedure Initialize_ALI
is
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);
74 for J
in Units
.First
.. Units
.Last
loop
75 Set_Name_Table_Info
(Units
.Table
(J
).Uname
, 0);
78 -- Free argument table strings
80 for J
in Args
.First
.. Args
.Last
loop
81 Free
(Args
.Table
(J
));
84 -- Initialize all tables
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;
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;
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 Bad_ALI_Format
: exception;
144 -- Exception raised by Fatal_Error if Err is True
146 function At_Eol
return Boolean;
147 -- Test if at end of line
149 function At_End_Of_Field
return Boolean;
150 -- Test if at end of line, or if at blank or horizontal tab
152 procedure Check_At_End_Of_Field
;
153 -- Check if we are at end of field, fatal error if not
155 procedure Checkc
(C
: Character);
156 -- Check next character is C. If so bump past it, if not fatal error
158 procedure Check_Unknown_Line
;
159 -- If Ignore_Errors mode, then checks C to make sure that it is not
160 -- an unknown ALI line type characters, and if so, skips lines
161 -- until the first character of the line is one of these characters,
162 -- at which point it does a Getc to put that character in C. The
163 -- call has no effect if C is already an appropriate character.
164 -- If not in Ignore_Errors mode, a fatal error is signalled if the
165 -- line is unknown. Note that if C is an EOL on entry, the line is
166 -- skipped (it is assumed that blank lines are never significant).
167 -- If C is EOF on entry, the call has no effect (it is assumed that
168 -- the caller will properly handle this case).
170 procedure Fatal_Error
;
171 -- Generate fatal error message for badly formatted ALI file if
172 -- Err is false, or raise Bad_ALI_Format if Err is True.
174 procedure Fatal_Error_Ignore
;
175 pragma Inline
(Fatal_Error_Ignore
);
176 -- In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error
178 function Getc
return Character;
179 -- Get next character, bumping P past the character obtained
181 function Get_File_Name
(Lower
: Boolean := False) return File_Name_Type
;
182 -- Skip blanks, then scan out a file name (name is left in Name_Buffer
183 -- with length in Name_Len, as well as returning a File_Name_Type value.
184 -- If lower is false, the case is unchanged, if Lower is True then the
185 -- result is forced to all lower case for systems where file names are
186 -- not case sensitive. This ensures that gnatbind works correctly
187 -- regardless of the case of the file name on all systems. The scan
188 -- is terminated by a end of line, space or horizontal tab. Any other
189 -- special characters are included in the returned name.
192 (Ignore_Spaces
: Boolean := False;
193 Ignore_Special
: Boolean := False)return Name_Id
;
194 -- Skip blanks, then scan out a name (name is left in Name_Buffer with
195 -- length in Name_Len, as well as being returned in Name_Id form).
196 -- If Lower is set to True then the Name_Buffer will be converted to
197 -- all lower case, for systems where file names are not case sensitive.
198 -- This ensures that gnatbind works correctly regardless of the case
199 -- of the file name on all systems. The termination condition depends
200 -- on the settings of Ignore_Spaces and Ignore_Special:
202 -- If Ignore_Spaces is False (normal case), then scan is terminated
203 -- by the normal end of field condition (EOL, space, horizontal tab)
205 -- If Ignore_Special is False (normal case), the scan is terminated by
206 -- a typeref bracket or an equal sign except for the special case of
207 -- an operator name starting with a double quite which is terminated
208 -- by another double quote.
210 -- It is an error to set both Ignore_Spaces and Ignore_Special to True.
211 -- This function handles wide characters properly.
213 function Get_Nat
return Nat
;
214 -- Skip blanks, then scan out an unsigned integer value in Nat range
215 -- raises ALI_Reading_Error if the encoutered type is not natural.
217 function Get_Stamp
return Time_Stamp_Type
;
218 -- Skip blanks, then scan out a time stamp
220 function Get_Unit_Name
return Unit_Name_Type
;
221 -- Skip blanks, then scan out a file name (name is left in Name_Buffer
222 -- with length in Name_Len, as well as returning a Unit_Name_Type value.
223 -- The case is unchanged and terminated by a normal end of field.
225 function Nextc
return Character;
226 -- Return current character without modifying pointer P
228 procedure Get_Typeref
229 (Current_File_Num
: Sdep_Id
;
231 File_Num
: out Sdep_Id
;
233 Ref_Type
: out Character;
235 Standard_Entity
: out Name_Id
);
236 -- Parse the definition of a typeref (<...>, {...} or (...))
239 -- Skip past spaces, then skip past end of line (fatal error if not
240 -- at end of line). Also skips past any following blank lines.
243 -- Skip rest of current line and any following blank lines
245 procedure Skip_Space
;
246 -- Skip past white space (blanks or horizontal tab)
249 -- Skip past next character, does not affect value in C. This call
250 -- is like calling Getc and ignoring the returned result.
252 ---------------------
253 -- At_End_Of_Field --
254 ---------------------
256 function At_End_Of_Field
return Boolean is
265 function At_Eol
return Boolean is
267 return Nextc
= EOF
or else Nextc
= CR
or else Nextc
= LF
;
270 ---------------------------
271 -- Check_At_End_Of_Field --
272 ---------------------------
274 procedure Check_At_End_Of_Field
is
276 if not At_End_Of_Field
then
277 if Ignore_Errors
then
278 while Nextc
> ' ' loop
285 end Check_At_End_Of_Field
;
287 ------------------------
288 -- Check_Unknown_Line --
289 ------------------------
291 procedure Check_Unknown_Line
is
293 while C
not in 'A' .. 'Z'
294 or else not Known_ALI_Lines
(C
)
296 if C
= CR
or else C
= LF
then
303 elsif Ignore_Errors
then
311 end Check_Unknown_Line
;
317 procedure Checkc
(C
: Character) is
321 elsif Ignore_Errors
then
332 procedure Fatal_Error
is
337 procedure Wchar
(C
: Character);
338 -- Write a single character, replacing horizontal tab by spaces
340 procedure Wchar
(C
: Character) is
345 exit when Col
mod 8 = 0;
354 -- Start of processing for Fatal_Error
358 raise Bad_ALI_Format
;
362 Write_Str
("fatal error: file ");
364 Write_Str
(" is incorrectly formatted");
367 Write_Str
("make sure you are using consistent versions " &
369 -- Split the following line so that it can easily be transformed for
370 -- e.g. JVM/.NET back-ends where the compiler has a different name.
376 -- Find start of line
380 and then T
(Ptr1
- 1) /= CR
381 and then T
(Ptr1
- 1) /= LF
386 Write_Int
(Int
(Line
));
401 and then T
(Ptr2
) /= CR
402 and then T
(Ptr2
) /= LF
414 if T
(Ptr1
) = HT
then
426 Exit_Program
(E_Fatal
);
429 ------------------------
430 -- Fatal_Error_Ignore --
431 ------------------------
433 procedure Fatal_Error_Ignore
is
435 if not Ignore_Errors
then
438 end Fatal_Error_Ignore
;
444 function Get_File_Name
445 (Lower
: Boolean := False) return File_Name_Type
450 F
:= Get_Name
(Ignore_Special
=> True);
452 -- Convert file name to all lower case if file names are not case
453 -- sensitive. This ensures that we handle names in the canonical
454 -- lower case format, regardless of the actual case.
456 if Lower
and not File_Names_Case_Sensitive
then
457 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
460 return File_Name_Type
(F
);
469 (Ignore_Spaces
: Boolean := False;
470 Ignore_Special
: Boolean := False) return Name_Id
477 if Ignore_Errors
then
485 Name_Len
:= Name_Len
+ 1;
486 Name_Buffer
(Name_Len
) := Getc
;
488 exit when At_End_Of_Field
and not Ignore_Spaces
;
490 if not Ignore_Special
then
491 if Name_Buffer
(1) = '"' then
492 exit when Name_Len
> 1 and then Name_Buffer
(Name_Len
) = '"';
495 -- Terminate on parens or angle brackets or equal sign
497 exit when Nextc
= '(' or else Nextc
= ')'
498 or else Nextc
= '{' or else Nextc
= '}'
499 or else Nextc
= '<' or else Nextc
= '>'
502 -- Terminate if left bracket not part of wide char sequence
503 -- Note that we only recognize brackets notation so far ???
505 exit when Nextc
= '[' and then T
(P
+ 1) /= '"';
507 -- Terminate if right bracket not part of wide char sequence
509 exit when Nextc
= ']' and then T
(P
- 1) /= '"';
521 function Get_Unit_Name
return Unit_Name_Type
is
523 return Unit_Name_Type
(Get_Name
);
530 function Get_Nat
return Nat
is
536 -- Check if we are on a number. In the case of bas ALI files, this
539 if not (Nextc
in '0' .. '9') then
545 V
:= V
* 10 + (Character'Pos (Getc
) - Character'Pos ('0'));
547 exit when At_End_Of_Field
;
548 exit when Nextc
< '0' or Nextc
> '9';
558 function Get_Stamp
return Time_Stamp_Type
is
566 if Ignore_Errors
then
567 return Dummy_Time_Stamp
;
573 -- Following reads old style time stamp missing first two digits
575 if Nextc
in '7' .. '9' then
580 -- Normal case of full year in time stamp
586 for J
in Start
.. T
'Last loop
597 procedure Get_Typeref
598 (Current_File_Num
: Sdep_Id
;
600 File_Num
: out Sdep_Id
;
602 Ref_Type
: out Character;
604 Standard_Entity
: out Name_Id
)
609 when '<' => Ref
:= Tref_Derived
;
610 when '(' => Ref
:= Tref_Access
;
611 when '{' => Ref
:= Tref_Type
;
612 when others => Ref
:= Tref_None
;
615 -- Case of typeref field present
617 if Ref
/= Tref_None
then
618 P
:= P
+ 1; -- skip opening bracket
620 if Nextc
in 'a' .. 'z' then
621 File_Num
:= No_Sdep_Id
;
625 Standard_Entity
:= Get_Name
(Ignore_Spaces
=> True);
630 File_Num
:= Sdep_Id
(N
+ Nat
(First_Sdep_Entry
) - 1);
634 File_Num
:= Current_File_Num
;
640 Standard_Entity
:= No_Name
;
643 -- ??? Temporary workaround for nested generics case:
644 -- 4i4 Directories{1|4I9[4|6[3|3]]}
648 Nested_Brackets
: Natural := 0;
654 Nested_Brackets
:= Nested_Brackets
+ 1;
656 Nested_Brackets
:= Nested_Brackets
- 1;
658 if Nested_Brackets
= 0 then
667 P
:= P
+ 1; -- skip closing bracket
670 -- No typeref entry present
673 File_Num
:= No_Sdep_Id
;
677 Standard_Entity
:= No_Name
;
685 function Getc
return Character is
699 function Nextc
return Character is
708 procedure Skip_Eol
is
713 if Ignore_Errors
then
714 while not At_Eol
loop
722 -- Loop to skip past blank lines (first time through skips this EOL)
724 while Nextc
< ' ' and then Nextc
/= EOF
loop
737 procedure Skip_Line
is
739 while not At_Eol
loop
750 procedure Skip_Space
is
752 while Nextc
= ' ' or else Nextc
= HT
loop
768 -- Start of processing for Scan_ALI
771 First_Sdep_Entry
:= Sdep
.Last
+ 1;
773 -- Acquire lines to be ignored
776 Ignore
:= ('U' |
'W' |
'Y' |
'D' |
'X' => False, others => True);
778 -- Read_Lines parameter given
780 elsif Read_Lines
/= "" then
781 Ignore
:= ('U' => False, others => True);
783 for J
in Read_Lines
'Range loop
784 Ignore
(Read_Lines
(J
)) := False;
787 -- Process Ignore_Lines parameter
790 Ignore
:= (others => False);
792 for J
in Ignore_Lines
'Range loop
793 pragma Assert
(Ignore_Lines
(J
) /= 'U');
794 Ignore
(Ignore_Lines
(J
)) := True;
798 -- Setup ALI Table entry with appropriate defaults
802 Set_Name_Table_Info
(F
, Int
(Id
));
806 Compile_Errors
=> False,
807 First_Interrupt_State
=> Interrupt_States
.Last
+ 1,
808 First_Sdep
=> No_Sdep_Id
,
809 First_Specific_Dispatching
=> Specific_Dispatching
.Last
+ 1,
810 First_Unit
=> No_Unit_Id
,
812 Last_Interrupt_State
=> Interrupt_States
.Last
,
813 Last_Sdep
=> No_Sdep_Id
,
814 Last_Specific_Dispatching
=> Specific_Dispatching
.Last
,
815 Last_Unit
=> No_Unit_Id
,
816 Locking_Policy
=> ' ',
818 Main_Program
=> None
,
820 Normalize_Scalars
=> False,
821 Ofile_Full_Name
=> Full_Object_File_Name
,
822 Queuing_Policy
=> ' ',
823 Restrictions
=> No_Restrictions
,
824 SAL_Interface
=> False,
826 Task_Dispatching_Policy
=> ' ',
827 Time_Slice_Value
=> -1,
829 Unit_Exception_Table
=> False,
830 Ver
=> (others => ' '),
832 Zero_Cost_Exceptions
=> False);
834 -- Now we acquire the input lines from the ALI file. Note that the
835 -- convention in the following code is that as we enter each section,
836 -- C is set to contain the first character of the following line.
841 -- Acquire library version
845 -- The V line missing really indicates trouble, most likely it
846 -- means we don't have an ALI file at all, so here we give a
847 -- fatal error even if we are in Ignore_Errors mode.
851 elsif Ignore
('V') then
859 for J
in 1 .. Ver_Len_Max
loop
862 ALIs
.Table
(Id
).Ver
(J
) := C
;
863 ALIs
.Table
(Id
).Ver_Len
:= J
;
872 -- Acquire main program line if present
885 ALIs
.Table
(Id
).Main_Program
:= Func
;
887 ALIs
.Table
(Id
).Main_Program
:= Proc
;
897 ALIs
.Table
(Id
).Main_Priority
:= Get_Nat
;
905 ALIs
.Table
(Id
).Time_Slice_Value
:= Get_Nat
;
912 ALIs
.Table
(Id
).WC_Encoding
:= Getc
;
921 -- Acquire argument lines
923 First_Arg
:= Args
.Last
+ 1;
927 exit A_Loop
when C
/= 'A';
938 while not At_Eol
loop
939 Name_Len
:= Name_Len
+ 1;
940 Name_Buffer
(Name_Len
) := Getc
;
943 -- If -fstack-check, record that it occurred
945 if Name_Buffer
(1 .. Name_Len
) = "-fstack-check" then
946 Stack_Check_Switch_Set
:= True;
949 -- Store the argument
952 Args
.Table
(Args
.Last
) := new String'(Name_Buffer (1 .. Name_Len));
965 if Ignore_Errors then
985 while not At_Eol loop
994 ALIs.Table (Id).Compile_Errors := True;
1000 Detect_Blocking := True;
1002 -- Processing for FD/FG/FI
1005 Float_Format_Specified := Getc;
1006 ALIs.Table (Id).Float_Format := Float_Format_Specified;
1008 -- Processing for Lx
1011 Locking_Policy_Specified := Getc;
1012 ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
1014 -- Processing for flags starting with N
1019 -- Processing for NO
1022 ALIs.Table (Id).No_Object := True;
1023 No_Object_Specified := True;
1025 -- Processing for NR
1028 No_Run_Time_Mode := True;
1029 Configurable_Run_Time_Mode := True;
1031 -- Processing for NS
1034 ALIs.Table (Id).Normalize_Scalars := True;
1035 Normalize_Scalars_Specified := True;
1038 -- Invalid switch starting with N
1044 -- Processing for Qx
1047 Queuing_Policy_Specified := Getc;
1048 ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
1050 -- Processing for flags starting with S
1055 -- Processing for SL
1058 ALIs.Table (Id).SAL_Interface := True;
1060 -- Processing for SS
1063 Opt.Sec_Stack_Used := True;
1065 -- Invalid switch starting with S
1071 -- Processing for Tx
1074 Task_Dispatching_Policy_Specified := Getc;
1075 ALIs.Table (Id).Task_Dispatching_Policy :=
1076 Task_Dispatching_Policy_Specified;
1078 -- Processing for switch starting with U
1083 -- Processing for UA
1086 Unreserve_All_Interrupts_Specified := True;
1088 -- Processing for UX
1091 ALIs.Table (Id).Unit_Exception_Table := True;
1093 -- Invalid switches starting with U
1099 -- Processing for ZX
1105 ALIs.Table (Id).Zero_Cost_Exceptions := True;
1106 Zero_Cost_Exceptions_Specified := True;
1111 -- Invalid parameter
1119 if not NS_Found then
1120 No_Normalize_Scalars_Specified := True;
1129 -- Acquire first restrictions line
1132 if Ignore_Errors then
1144 if Ignore ('R
') then
1147 -- Process restrictions line
1150 Scan_Restrictions : declare
1151 Save_R : constant Restrictions_Info := Cumulative_Restrictions;
1152 -- Save cumulative restrictions in case we have a fatal error
1154 Bad_R_Line : exception;
1155 -- Signal bad restrictions line (raised on unexpected character)
1161 -- Acquire information for boolean restrictions
1163 for R in All_Boolean_Restrictions loop
1168 ALIs.Table (Id).Restrictions.Violated (R) := True;
1169 Cumulative_Restrictions.Violated (R) := True;
1172 ALIs.Table (Id).Restrictions.Set (R) := True;
1173 Cumulative_Restrictions.Set (R) := True;
1183 -- Acquire information for parameter restrictions
1185 for RP in All_Parameter_Restrictions loop
1187 -- Acquire restrictions pragma information
1194 ALIs.Table (Id).Restrictions.Set (RP) := True;
1197 N : constant Integer := Integer (Get_Nat);
1199 ALIs.Table (Id).Restrictions.Value (RP) := N;
1201 if Cumulative_Restrictions.Set (RP) then
1202 Cumulative_Restrictions.Value (RP) :=
1204 (Cumulative_Restrictions.Value (RP), N);
1206 Cumulative_Restrictions.Set (RP) := True;
1207 Cumulative_Restrictions.Value (RP) := N;
1215 -- Acquire restrictions violations information
1222 ALIs.Table (Id).Restrictions.Violated (RP) := True;
1223 Cumulative_Restrictions.Violated (RP) := True;
1226 N : constant Integer := Integer (Get_Nat);
1227 pragma Unsuppress (Overflow_Check);
1230 ALIs.Table (Id).Restrictions.Count (RP) := N;
1232 if RP in Checked_Max_Parameter_Restrictions then
1233 Cumulative_Restrictions.Count (RP) :=
1235 (Cumulative_Restrictions.Count (RP), N);
1237 Cumulative_Restrictions.Count (RP) :=
1238 Cumulative_Restrictions.Count (RP) + N;
1242 when Constraint_Error =>
1244 -- A constraint error comes from the addition in
1245 -- the else branch. We reset to the maximum and
1246 -- indicate that the real value is now unknown.
1248 Cumulative_Restrictions.Value (RP) := Integer'Last;
1249 Cumulative_Restrictions.Unknown (RP) := True;
1254 ALIs.Table (Id).Restrictions.Unknown (RP) := True;
1255 Cumulative_Restrictions.Unknown (RP) := True;
1265 -- Here if error during scanning of restrictions line
1270 -- In Ignore_Errors mode, undo any changes to restrictions
1271 -- from this unit, and continue on.
1273 if Ignore_Errors then
1274 Cumulative_Restrictions := Save_R;
1275 ALIs.Table (Id).Restrictions := No_Restrictions;
1278 -- In normal mode, this is a fatal error
1284 end Scan_Restrictions;
1287 -- Acquire additional restrictions (No_Dependence) lines if present
1291 if Ignore ('R
') then
1295 No_Deps.Append ((Id, Get_Name));
1302 -- Acquire 'I
' lines if present
1307 if Ignore ('I
') then
1313 I_State : Character;
1322 Interrupt_States.Append (
1323 (Interrupt_Id => Int_Num,
1324 Interrupt_State => I_State,
1325 IS_Pragma_Line => Line_No));
1327 ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last;
1335 -- Acquire 'S
' lines if present
1340 if Ignore ('S
') then
1356 First_Prio := Get_Nat;
1357 Last_Prio := Get_Nat;
1360 Specific_Dispatching.Append (
1361 (Dispatching_Policy => Policy,
1362 First_Priority => First_Prio,
1363 Last_Priority => Last_Prio,
1364 PSD_Pragma_Line => Line_No));
1366 ALIs.Table (Id).Last_Specific_Dispatching :=
1367 Specific_Dispatching.Last;
1376 -- Loop to acquire unit entries
1380 exit U_Loop when C /= 'U
';
1382 -- Note: as per spec, we never ignore U lines
1386 Units.Increment_Last;
1388 if ALIs.Table (Id).First_Unit = No_Unit_Id then
1389 ALIs.Table (Id).First_Unit := Units.Last;
1393 UL : Unit_Record renames Units.Table (Units.Last);
1396 UL.Uname := Get_Unit_Name;
1397 UL.Predefined := Is_Predefined_Unit;
1398 UL.Internal := Is_Internal_Unit;
1400 UL.Sfile := Get_File_Name (Lower => True);
1402 UL.Preelab := False;
1403 UL.No_Elab := False;
1404 UL.Shared_Passive := False;
1406 UL.Remote_Types := False;
1407 UL.Has_RACW := False;
1408 UL.Init_Scalars := False;
1409 UL.Is_Generic := False;
1410 UL.Icasing := Mixed_Case;
1411 UL.Kcasing := All_Lower_Case;
1412 UL.Dynamic_Elab := False;
1413 UL.Elaborate_Body := False;
1414 UL.Set_Elab_Entity := False;
1415 UL.Version := "00000000";
1416 UL.First_With := Withs.Last + 1;
1417 UL.First_Arg := First_Arg;
1418 UL.Elab_Position := 0;
1419 UL.SAL_Interface := ALIs.Table (Id).SAL_Interface;
1420 UL.Body_Needed_For_SAL := False;
1421 UL.Elaborate_Body_Desirable := False;
1422 UL.Optimize_Alignment := 'O
';
1424 if Debug_Flag_U then
1425 Write_Str (" ----> reading unit ");
1426 Write_Int (Int (Units.Last));
1428 Write_Unit_Name (UL.Uname);
1429 Write_Str (" from file ");
1430 Write_Name (UL.Sfile);
1435 -- Check for duplicated unit in different files
1438 Info : constant Int := Get_Name_Table_Info
1439 (Units.Table (Units.Last).Uname);
1442 and then Units.Table (Units.Last).Sfile /=
1443 Units.Table (Unit_Id (Info)).Sfile
1445 -- If Err is set then ignore duplicate unit name. This is the
1446 -- case of a call from gnatmake, where the situation can arise
1447 -- from substitution of source files. In such situations, the
1448 -- processing in gnatmake will always result in any required
1449 -- recompilations in any case, and if we consider this to be
1450 -- an error we get strange cases (for example when a generic
1451 -- instantiation is replaced by a normal package) where we
1452 -- read the old ali file, decide to recompile, and then decide
1453 -- that the old and new ali files are incompatible.
1458 -- If Err is not set, then this is a fatal error. This is
1459 -- the case of being called from the binder, where we must
1460 -- definitely diagnose this as an error.
1464 Write_Str ("error: duplicate unit name: ");
1467 Write_Str ("error: unit """);
1468 Write_Unit_Name (Units.Table (Units.Last).Uname);
1469 Write_Str (""" found in file """);
1470 Write_Name_Decoded (Units.Table (Units.Last).Sfile);
1474 Write_Str ("error
: unit
""");
1475 Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
1476 Write_Str (""" found
in file
""");
1477 Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
1481 Exit_Program (E_Fatal);
1487 (Units.Table (Units.Last).Uname, Int (Units.Last));
1489 -- Scan out possible version and other parameters
1498 if C in '0' .. '9' or else C in 'a
' .. 'f
' then
1499 Units.Table (Units.Last).Version (1) := C;
1501 for J in 2 .. 8 loop
1503 Units.Table (Units.Last).Version (J) := C;
1512 Check_At_End_Of_Field;
1513 Units.Table (Units.Last).Elaborate_Body_Desirable := True;
1516 Check_At_End_Of_Field;
1517 Units.Table (Units.Last).Body_Needed_For_SAL := True;
1523 -- DE parameter (Dynamic elaboration checks)
1529 Check_At_End_Of_Field;
1530 Units.Table (Units.Last).Dynamic_Elab := True;
1531 Dynamic_Elaboration_Checks_Specified := True;
1542 Units.Table (Units.Last).Elaborate_Body := True;
1544 Units.Table (Units.Last).Set_Elab_Entity := True;
1549 Check_At_End_Of_Field;
1551 -- GE parameter (generic)
1557 Check_At_End_Of_Field;
1558 Units.Table (Units.Last).Is_Generic := True;
1563 -- IL/IS/IU parameters
1569 Units.Table (Units.Last).Icasing := All_Lower_Case;
1571 Units.Table (Units.Last).Init_Scalars := True;
1572 Initialize_Scalars_Used := True;
1574 Units.Table (Units.Last).Icasing := All_Upper_Case;
1579 Check_At_End_Of_Field;
1587 Units.Table (Units.Last).Kcasing := Mixed_Case;
1589 Units.Table (Units.Last).Kcasing := All_Upper_Case;
1594 Check_At_End_Of_Field;
1602 Units.Table (Units.Last).No_Elab := True;
1603 Check_At_End_Of_Field;
1608 -- PR/PU/PK parameters
1614 Units.Table (Units.Last).Preelab := True;
1616 Units.Table (Units.Last).Pure := True;
1618 Units.Table (Units.Last).Unit_Kind := 'p
';
1623 Check_At_End_Of_Field;
1625 -- OL/OO/OS/OT parameters
1630 if C = 'L
' or else C = 'O
' or else C = 'S
' or else C = 'T
' then
1631 Units.Table (Units.Last).Optimize_Alignment := C;
1636 Check_At_End_Of_Field;
1644 Units.Table (Units.Last).RCI := True;
1646 Units.Table (Units.Last).Remote_Types := True;
1648 Units.Table (Units.Last).Has_RACW := True;
1653 Check_At_End_Of_Field;
1659 Units.Table (Units.Last).Shared_Passive := True;
1661 Units.Table (Units.Last).Unit_Kind := 's
';
1666 Check_At_End_Of_Field;
1676 -- Check if static elaboration model used
1678 if not Units.Table (Units.Last).Dynamic_Elab
1679 and then not Units.Table (Units.Last).Internal
1681 Static_Elaboration_Model_Used := True;
1686 -- Scan out With lines for this unit
1690 exit With_Loop when C /= 'W
' and then C /= 'Y
';
1692 if Ignore ('W
') then
1698 Withs.Increment_Last;
1699 Withs.Table (Withs.Last).Uname := Get_Unit_Name;
1700 Withs.Table (Withs.Last).Elaborate := False;
1701 Withs.Table (Withs.Last).Elaborate_All := False;
1702 Withs.Table (Withs.Last).Elab_Desirable := False;
1703 Withs.Table (Withs.Last).Elab_All_Desirable := False;
1704 Withs.Table (Withs.Last).SAL_Interface := False;
1705 Withs.Table (Withs.Last).Limited_With := (C = 'Y
');
1707 -- Generic case with no object file available
1710 Withs.Table (Withs.Last).Sfile := No_File;
1711 Withs.Table (Withs.Last).Afile := No_File;
1716 Withs.Table (Withs.Last).Sfile := Get_File_Name
1718 Withs.Table (Withs.Last).Afile := Get_File_Name
1721 -- Scan out possible E, EA, ED, and AD parameters
1723 while not At_Eol loop
1729 Check_At_End_Of_Field;
1731 -- Store AD indication unless ignore required
1733 if not Ignore_ED then
1734 Withs.Table (Withs.Last).Elab_All_Desirable :=
1738 elsif Nextc = 'E
' then
1741 if At_End_Of_Field then
1742 Withs.Table (Withs.Last).Elaborate := True;
1744 elsif Nextc = 'A
' then
1746 Check_At_End_Of_Field;
1747 Withs.Table (Withs.Last).Elaborate_All := True;
1751 Check_At_End_Of_Field;
1753 -- Store ED indication unless ignore required
1755 if not Ignore_ED then
1756 Withs.Table (Withs.Last).Elab_Desirable :=
1773 Units.Table (Units.Last).Last_With := Withs.Last;
1774 Units.Table (Units.Last).Last_Arg := Args.Last;
1776 -- If there are linker options lines present, scan them
1780 Linker_Options_Loop : loop
1782 exit Linker_Options_Loop when C /= 'L
';
1784 if Ignore ('L
') then
1795 if C < Character'Val (16#20#)
1796 or else C > Character'Val (16#7E#)
1801 C := Character'Val (0);
1808 for J in 1 .. 2 loop
1811 if C in '0' .. '9' then
1814 Character'Pos ('0');
1816 elsif C in 'A' .. 'F' then
1819 Character'Pos ('A') +
1828 Add_Char_To_Name_Buffer (Character'Val (V));
1833 exit when Nextc /= '"';
1837 Add_Char_To_Name_Buffer (C);
1841 Add_Char_To_Name_Buffer (nul);
1846 end loop Linker_Options_Loop;
1848 -- Store the linker options entry if one was found
1850 if Name_Len /= 0 then
1851 Linker_Options.Increment_Last;
1853 Linker_Options.Table (Linker_Options.Last).Name :=
1856 Linker_Options.Table (Linker_Options.Last).Unit :=
1859 Linker_Options.Table (Linker_Options.Last).Internal_File :=
1860 Is_Internal_File_Name (F);
1862 Linker_Options.Table (Linker_Options.Last).Original_Pos :=
1863 Linker_Options.Last;
1867 -- End loop through units for one ALI file
1869 ALIs.Table (Id).Last_Unit := Units.Last;
1870 ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile;
1872 -- Set types of the units (there can be at most 2 of them)
1874 if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then
1875 Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body;
1876 Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec;
1879 -- Deal with body only and spec only cases, note that the reason we
1880 -- do our own checking of the name (rather than using Is_Body_Name)
1881 -- is that Uname drags in far too much compiler junk!
1883 Get_Name_String (Units.Table (Units.Last).Uname);
1885 if Name_Buffer (Name_Len) = 'b' then
1886 Units.Table (Units.Last).Utype := Is_Body_Only;
1888 Units.Table (Units.Last).Utype := Is_Spec_Only;
1892 -- Scan out external version references and put in hash table
1896 exit E_Loop when C /= 'E';
1898 if Ignore ('E') then
1914 exit when At_End_Of_Field;
1915 Add_Char_To_Name_Buffer (C);
1918 Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
1925 -- Scan out source dependency lines for this ALI file
1927 ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
1931 exit D_Loop when C /= 'D';
1933 if Ignore ('D') then
1939 Sdep.Increment_Last;
1941 -- In the following call, Lower is not set to True, this is either
1942 -- a bug, or it deserves a special comment as to why this is so???
1944 Sdep.Table (Sdep.Last).Sfile := Get_File_Name;
1946 Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
1947 Sdep.Table (Sdep.Last).Dummy_Entry :=
1948 (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
1950 -- Acquire checksum value
1963 exit when At_Eol or else Ctr = 8;
1965 if Nextc in '0' .. '9' then
1967 Character'Pos (Nextc) - Character'Pos ('0');
1969 elsif Nextc in 'a' .. 'f' then
1971 Character'Pos (Nextc) - Character'Pos ('a') + 10;
1981 if Ctr = 8 and then At_End_Of_Field then
1982 Sdep.Table (Sdep.Last).Checksum := Chk;
1988 -- Acquire subunit and reference file name entries
1990 Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
1991 Sdep.Table (Sdep.Last).Rfile :=
1992 Sdep.Table (Sdep.Last).Sfile;
1993 Sdep.Table (Sdep.Last).Start_Line := 1;
1998 -- Here for subunit name
2000 if Nextc not in '0' .. '9' then
2003 while not At_End_Of_Field loop
2004 Name_Len := Name_Len + 1;
2005 Name_Buffer (Name_Len) := Getc;
2008 Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter;
2012 -- Here for reference file name entry
2014 if Nextc in '0' .. '9' then
2015 Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
2020 while not At_End_Of_Field loop
2021 Name_Len := Name_Len + 1;
2022 Name_Buffer (Name_Len) := Getc;
2025 Sdep.Table (Sdep.Last).Rfile := Name_Enter;
2035 ALIs.Table (Id).Last_Sdep := Sdep.Last;
2037 -- We must at this stage be at an Xref line or the end of file
2049 -- If we are ignoring Xref sections we are done (we ignore all
2050 -- remaining lines since only xref related lines follow X).
2052 if Ignore ('X') and then not Debug_Flag_X then
2056 -- Loop through Xref sections
2060 exit X_Loop when C /= 'X';
2062 -- Make new entry in section table
2064 Xref_Section.Increment_Last;
2066 Read_Refs_For_One_File : declare
2067 XS : Xref_Section_Record renames
2068 Xref_Section.Table (Xref_Section.Last);
2070 Current_File_Num : Sdep_Id;
2071 -- Keeps track of the current file number (changed by nn|)
2074 XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
2075 XS.File_Name := Get_File_Name;
2076 XS.First_Entity := Xref_Entity.Last + 1;
2078 Current_File_Num := XS.File_Num;
2085 -- Loop through Xref entities
2087 while C /= 'X' and then C /= EOF loop
2088 Xref_Entity.Increment_Last;
2090 Read_Refs_For_One_Entity : declare
2091 XE : Xref_Entity_Record renames
2092 Xref_Entity.Table (Xref_Entity.Last);
2095 procedure Read_Instantiation_Reference;
2096 -- Acquire instantiation reference. Caller has checked
2097 -- that current character is '[' and on return the cursor
2098 -- is skipped past the corresponding closing ']'.
2100 ----------------------------------
2101 -- Read_Instantiation_Reference --
2102 ----------------------------------
2104 procedure Read_Instantiation_Reference is
2105 Local_File_Num : Sdep_Id := Current_File_Num;
2108 Xref.Increment_Last;
2111 XR : Xref_Record renames Xref.Table (Xref.Last);
2114 P := P + 1; -- skip [
2119 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2120 Local_File_Num := XR.File_Num;
2125 XR.File_Num := Local_File_Num;
2132 -- Recursive call for next reference
2135 pragma Warnings (Off); -- kill recursion warning
2136 Read_Instantiation_Reference;
2137 pragma Warnings (On);
2140 -- Skip closing bracket after recursive call
2144 end Read_Instantiation_Reference;
2146 -- Start of processing for Read_Refs_For_One_Entity
2152 XE.Lib := (Getc = '*');
2153 XE.Entity := Get_Name;
2155 -- Handle the information about generic instantiations
2158 Skipc; -- Opening '['
2161 if Nextc /= '|' then
2162 XE.Iref_File_Num := Current_File_Num;
2166 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2168 XE.Iref_Line := Get_Nat;
2176 XE.Iref_File_Num := No_Sdep_Id;
2180 Current_File_Num := XS.File_Num;
2182 -- Renaming reference is present
2186 XE.Rref_Line := Get_Nat;
2192 XE.Rref_Col := Get_Nat;
2194 -- No renaming reference present
2203 XE.Oref_File_Num := No_Sdep_Id;
2204 XE.Tref_File_Num := No_Sdep_Id;
2205 XE.Tref := Tref_None;
2206 XE.First_Xref := Xref.Last + 1;
2208 -- Loop to check for additional info present
2221 (Current_File_Num, Ref, File, Line, Typ, Col, Std);
2222 exit when Ref = Tref_None;
2224 -- Do we have an overriding procedure?
2226 if Ref = Tref_Derived and then Typ = 'p' then
2227 XE.Oref_File_Num := File;
2228 XE.Oref_Line := Line;
2231 -- Arrays never override anything, and <> points to
2232 -- the index types instead
2234 elsif Ref = Tref_Derived and then XE.Etype = 'A' then
2236 -- Index types are stored in the list of references
2238 Xref.Increment_Last;
2241 XR : Xref_Record renames Xref.Table (Xref.Last);
2243 XR.File_Num := File;
2245 XR.Rtype := Array_Index_Reference;
2250 -- Interfaces are stored in the list of references,
2251 -- although the parent type itself is stored in XE
2253 elsif Ref = Tref_Derived
2255 and then XE.Tref_File_Num /= No_Sdep_Id
2257 Xref.Increment_Last;
2260 XR : Xref_Record renames Xref.Table (Xref.Last);
2262 XR.File_Num := File;
2264 XR.Rtype := Interface_Reference;
2271 XE.Tref_File_Num := File;
2272 XE.Tref_Line := Line;
2273 XE.Tref_Type := Typ;
2275 XE.Tref_Standard_Entity := Std;
2280 -- Loop through cross-references for this entity
2287 exit when Nextc /= '.';
2291 Xref.Increment_Last;
2294 XR : Xref_Record renames Xref.Table (Xref.Last);
2301 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2302 Current_File_Num := XR.File_Num;
2306 XR.File_Num := Current_File_Num;
2312 -- Imported entities reference as in:
2313 -- 494b<c,__gnat_copy_attribs>25
2314 -- ??? Simply skipped for now
2317 while Getc /= '>' loop
2325 Read_Instantiation_Reference;
2330 -- Record last cross-reference
2332 XE.Last_Xref := Xref.Last;
2336 when Bad_ALI_Format =>
2338 -- If ignoring errors, then we skip a line with an
2339 -- unexpected error, and try to continue subsequent
2342 if Ignore_Errors then
2343 Xref_Entity.Decrement_Last;
2347 -- Otherwise, we reraise the fatal exception
2352 end Read_Refs_For_One_Entity;
2355 -- Record last entity
2357 XS.Last_Entity := Xref_Entity.Last;
2359 end Read_Refs_For_One_File;
2364 -- Here after dealing with xref sections
2366 if C /= EOF and then C /= 'X' then
2373 when Bad_ALI_Format =>
2381 function SEq (F1, F2 : String_Ptr) return Boolean is
2383 return F1.all = F2.all;
2390 function SHash (S : String_Ptr) return Vindex is
2395 for J in S.all'Range loop
2396 H := H * 2 + Character'Pos (S (J));
2399 return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));