Implement -mmemcpy-strategy= and -mmemset-strategy= options
[official-gcc.git] / gcc / ada / ali.adb
blob6c2f8187a925ccfa094fdde7e7a5f8dd4accaab7
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- A L I --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Butil; use Butil;
27 with Debug; use Debug;
28 with Fname; use Fname;
29 with Opt; use Opt;
30 with Osint; use Osint;
31 with Output; use Output;
33 package body ALI is
35 use ASCII;
36 -- Make control characters visible
38 -- The following variable records which characters currently are
39 -- used as line type markers in the ALI file. This is used in
40 -- Scan_ALI to detect (or skip) invalid lines.
42 Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean :=
43 ('V' => True, -- version
44 'M' => True, -- main program
45 'A' => True, -- argument
46 'P' => True, -- program
47 'R' => True, -- restriction
48 'I' => True, -- interrupt
49 'U' => True, -- unit
50 'W' => True, -- with
51 'L' => True, -- linker option
52 'N' => True, -- notes
53 'E' => True, -- external
54 'D' => True, -- dependency
55 'X' => True, -- xref
56 'S' => True, -- specific dispatching
57 'Y' => True, -- limited_with
58 'Z' => True, -- implicit with from instantiation
59 'C' => True, -- SCO information
60 'F' => True, -- SPARK cross-reference information
61 others => False);
63 --------------------
64 -- Initialize_ALI --
65 --------------------
67 procedure Initialize_ALI is
68 begin
69 -- When (re)initializing ALI data structures the ALI user expects to
70 -- get a fresh set of data structures. Thus we first need to erase the
71 -- marks put in the name table by the previous set of ALI routine calls.
72 -- These two loops are empty and harmless the first time in.
74 for J in ALIs.First .. ALIs.Last loop
75 Set_Name_Table_Info (ALIs.Table (J).Afile, 0);
76 end loop;
78 for J in Units.First .. Units.Last loop
79 Set_Name_Table_Info (Units.Table (J).Uname, 0);
80 end loop;
82 -- Free argument table strings
84 for J in Args.First .. Args.Last loop
85 Free (Args.Table (J));
86 end loop;
88 -- Initialize all tables
90 ALIs.Init;
91 No_Deps.Init;
92 Units.Init;
93 Withs.Init;
94 Sdep.Init;
95 Linker_Options.Init;
96 Notes.Init;
97 Xref_Section.Init;
98 Xref_Entity.Init;
99 Xref.Init;
100 Version_Ref.Reset;
102 -- Add dummy zero'th item in Linker_Options and Notes for sort calls
104 Linker_Options.Increment_Last;
105 Notes.Increment_Last;
107 -- Initialize global variables recording cumulative options in all
108 -- ALI files that are read for a given processing run in gnatbind.
110 Dynamic_Elaboration_Checks_Specified := False;
111 Float_Format_Specified := ' ';
112 Locking_Policy_Specified := ' ';
113 No_Normalize_Scalars_Specified := False;
114 No_Object_Specified := False;
115 Normalize_Scalars_Specified := False;
116 Partition_Elaboration_Policy_Specified := ' ';
117 Queuing_Policy_Specified := ' ';
118 Static_Elaboration_Model_Used := False;
119 Task_Dispatching_Policy_Specified := ' ';
120 Unreserve_All_Interrupts_Specified := False;
121 Zero_Cost_Exceptions_Specified := False;
122 end Initialize_ALI;
124 --------------
125 -- Scan_ALI --
126 --------------
128 function Scan_ALI
129 (F : File_Name_Type;
130 T : Text_Buffer_Ptr;
131 Ignore_ED : Boolean;
132 Err : Boolean;
133 Read_Xref : Boolean := False;
134 Read_Lines : String := "";
135 Ignore_Lines : String := "X";
136 Ignore_Errors : Boolean := False;
137 Directly_Scanned : Boolean := False) return ALI_Id
139 P : Text_Ptr := T'First;
140 Line : Logical_Line_Number := 1;
141 Id : ALI_Id;
142 C : Character;
143 NS_Found : Boolean;
144 First_Arg : Arg_Id;
146 Ignore : array (Character range 'A' .. 'Z') of Boolean;
147 -- Ignore (X) is set to True if lines starting with X are to
148 -- be ignored by Scan_ALI and skipped, and False if the lines
149 -- are to be read and processed.
151 Bad_ALI_Format : exception;
152 -- Exception raised by Fatal_Error if Err is True
154 function At_Eol return Boolean;
155 -- Test if at end of line
157 function At_End_Of_Field return Boolean;
158 -- Test if at end of line, or if at blank or horizontal tab
160 procedure Check_At_End_Of_Field;
161 -- Check if we are at end of field, fatal error if not
163 procedure Checkc (C : Character);
164 -- Check next character is C. If so bump past it, if not fatal error
166 procedure Check_Unknown_Line;
167 -- If Ignore_Errors mode, then checks C to make sure that it is not
168 -- an unknown ALI line type characters, and if so, skips lines
169 -- until the first character of the line is one of these characters,
170 -- at which point it does a Getc to put that character in C. The
171 -- call has no effect if C is already an appropriate character.
172 -- If not in Ignore_Errors mode, a fatal error is signalled if the
173 -- line is unknown. Note that if C is an EOL on entry, the line is
174 -- skipped (it is assumed that blank lines are never significant).
175 -- If C is EOF on entry, the call has no effect (it is assumed that
176 -- the caller will properly handle this case).
178 procedure Fatal_Error;
179 -- Generate fatal error message for badly formatted ALI file if
180 -- Err is false, or raise Bad_ALI_Format if Err is True.
182 procedure Fatal_Error_Ignore;
183 pragma Inline (Fatal_Error_Ignore);
184 -- In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error
186 function Getc return Character;
187 -- Get next character, bumping P past the character obtained
189 function Get_File_Name (Lower : Boolean := False) return File_Name_Type;
190 -- Skip blanks, then scan out a file name (name is left in Name_Buffer
191 -- with length in Name_Len, as well as returning a File_Name_Type value.
192 -- If lower is false, the case is unchanged, if Lower is True then the
193 -- result is forced to all lower case for systems where file names are
194 -- not case sensitive. This ensures that gnatbind works correctly
195 -- regardless of the case of the file name on all systems. The scan
196 -- is terminated by a end of line, space or horizontal tab. Any other
197 -- special characters are included in the returned name.
199 function Get_Name
200 (Ignore_Spaces : Boolean := False;
201 Ignore_Special : Boolean := False) return Name_Id;
202 -- Skip blanks, then scan out a name (name is left in Name_Buffer with
203 -- length in Name_Len, as well as being returned in Name_Id form).
204 -- If Lower is set to True then the Name_Buffer will be converted to
205 -- all lower case, for systems where file names are not case sensitive.
206 -- This ensures that gnatbind works correctly regardless of the case
207 -- of the file name on all systems. The termination condition depends
208 -- on the settings of Ignore_Spaces and Ignore_Special:
210 -- If Ignore_Spaces is False (normal case), then scan is terminated
211 -- by the normal end of field condition (EOL, space, horizontal tab)
213 -- If Ignore_Special is False (normal case), the scan is terminated by
214 -- a typeref bracket or an equal sign except for the special case of
215 -- an operator name starting with a double quote which is terminated
216 -- by another double quote.
218 -- It is an error to set both Ignore_Spaces and Ignore_Special to True.
219 -- This function handles wide characters properly.
221 function Get_Nat return Nat;
222 -- Skip blanks, then scan out an unsigned integer value in Nat range
223 -- raises ALI_Reading_Error if the encoutered type is not natural.
225 function Get_Stamp return Time_Stamp_Type;
226 -- Skip blanks, then scan out a time stamp
228 function Get_Unit_Name return Unit_Name_Type;
229 -- Skip blanks, then scan out a file name (name is left in Name_Buffer
230 -- with length in Name_Len, as well as returning a Unit_Name_Type value.
231 -- The case is unchanged and terminated by a normal end of field.
233 function Nextc return Character;
234 -- Return current character without modifying pointer P
236 procedure Get_Typeref
237 (Current_File_Num : Sdep_Id;
238 Ref : out Tref_Kind;
239 File_Num : out Sdep_Id;
240 Line : out Nat;
241 Ref_Type : out Character;
242 Col : out Nat;
243 Standard_Entity : out Name_Id);
244 -- Parse the definition of a typeref (<...>, {...} or (...))
246 procedure Skip_Eol;
247 -- Skip past spaces, then skip past end of line (fatal error if not
248 -- at end of line). Also skips past any following blank lines.
250 procedure Skip_Line;
251 -- Skip rest of current line and any following blank lines
253 procedure Skip_Space;
254 -- Skip past white space (blanks or horizontal tab)
256 procedure Skipc;
257 -- Skip past next character, does not affect value in C. This call
258 -- is like calling Getc and ignoring the returned result.
260 ---------------------
261 -- At_End_Of_Field --
262 ---------------------
264 function At_End_Of_Field return Boolean is
265 begin
266 return Nextc <= ' ';
267 end At_End_Of_Field;
269 ------------
270 -- At_Eol --
271 ------------
273 function At_Eol return Boolean is
274 begin
275 return Nextc = EOF or else Nextc = CR or else Nextc = LF;
276 end At_Eol;
278 ---------------------------
279 -- Check_At_End_Of_Field --
280 ---------------------------
282 procedure Check_At_End_Of_Field is
283 begin
284 if not At_End_Of_Field then
285 if Ignore_Errors then
286 while Nextc > ' ' loop
287 P := P + 1;
288 end loop;
289 else
290 Fatal_Error;
291 end if;
292 end if;
293 end Check_At_End_Of_Field;
295 ------------------------
296 -- Check_Unknown_Line --
297 ------------------------
299 procedure Check_Unknown_Line is
300 begin
301 while C not in 'A' .. 'Z'
302 or else not Known_ALI_Lines (C)
303 loop
304 if C = CR or else C = LF then
305 Skip_Line;
306 C := Nextc;
308 elsif C = EOF then
309 return;
311 elsif Ignore_Errors then
312 Skip_Line;
313 C := Getc;
315 else
316 Fatal_Error;
317 end if;
318 end loop;
319 end Check_Unknown_Line;
321 ------------
322 -- Checkc --
323 ------------
325 procedure Checkc (C : Character) is
326 begin
327 if Nextc = C then
328 P := P + 1;
329 elsif Ignore_Errors then
330 P := P + 1;
331 else
332 Fatal_Error;
333 end if;
334 end Checkc;
336 -----------------
337 -- Fatal_Error --
338 -----------------
340 procedure Fatal_Error is
341 Ptr1 : Text_Ptr;
342 Ptr2 : Text_Ptr;
343 Col : Int;
345 procedure Wchar (C : Character);
346 -- Write a single character, replacing horizontal tab by spaces
348 procedure Wchar (C : Character) is
349 begin
350 if C = HT then
351 loop
352 Wchar (' ');
353 exit when Col mod 8 = 0;
354 end loop;
356 else
357 Write_Char (C);
358 Col := Col + 1;
359 end if;
360 end Wchar;
362 -- Start of processing for Fatal_Error
364 begin
365 if Err then
366 raise Bad_ALI_Format;
367 end if;
369 Set_Standard_Error;
370 Write_Str ("fatal error: file ");
371 Write_Name (F);
372 Write_Str (" is incorrectly formatted");
373 Write_Eol;
375 Write_Str ("make sure you are using consistent versions " &
377 -- Split the following line so that it can easily be transformed for
378 -- e.g. JVM/.NET back-ends where the compiler has a different name.
380 "of gcc/gnatbind");
382 Write_Eol;
384 -- Find start of line
386 Ptr1 := P;
387 while Ptr1 > T'First
388 and then T (Ptr1 - 1) /= CR
389 and then T (Ptr1 - 1) /= LF
390 loop
391 Ptr1 := Ptr1 - 1;
392 end loop;
394 Write_Int (Int (Line));
395 Write_Str (". ");
397 if Line < 100 then
398 Write_Char (' ');
399 end if;
401 if Line < 10 then
402 Write_Char (' ');
403 end if;
405 Col := 0;
406 Ptr2 := Ptr1;
408 while Ptr2 < T'Last
409 and then T (Ptr2) /= CR
410 and then T (Ptr2) /= LF
411 loop
412 Wchar (T (Ptr2));
413 Ptr2 := Ptr2 + 1;
414 end loop;
416 Write_Eol;
418 Write_Str (" ");
419 Col := 0;
421 while Ptr1 < P loop
422 if T (Ptr1) = HT then
423 Wchar (HT);
424 else
425 Wchar (' ');
426 end if;
428 Ptr1 := Ptr1 + 1;
429 end loop;
431 Wchar ('|');
432 Write_Eol;
434 Exit_Program (E_Fatal);
435 end Fatal_Error;
437 ------------------------
438 -- Fatal_Error_Ignore --
439 ------------------------
441 procedure Fatal_Error_Ignore is
442 begin
443 if not Ignore_Errors then
444 Fatal_Error;
445 end if;
446 end Fatal_Error_Ignore;
448 -------------------
449 -- Get_File_Name --
450 -------------------
452 function Get_File_Name
453 (Lower : Boolean := False) return File_Name_Type
455 F : Name_Id;
457 begin
458 F := Get_Name (Ignore_Special => True);
460 -- Convert file name to all lower case if file names are not case
461 -- sensitive. This ensures that we handle names in the canonical
462 -- lower case format, regardless of the actual case.
464 if Lower and not File_Names_Case_Sensitive then
465 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
466 return Name_Find;
467 else
468 return File_Name_Type (F);
469 end if;
470 end Get_File_Name;
472 --------------
473 -- Get_Name --
474 --------------
476 function Get_Name
477 (Ignore_Spaces : Boolean := False;
478 Ignore_Special : Boolean := False) return Name_Id
480 begin
481 Name_Len := 0;
482 Skip_Space;
484 if At_Eol then
485 if Ignore_Errors then
486 return Error_Name;
487 else
488 Fatal_Error;
489 end if;
490 end if;
492 loop
493 Add_Char_To_Name_Buffer (Getc);
495 exit when At_End_Of_Field and then not Ignore_Spaces;
497 if not Ignore_Special then
498 if Name_Buffer (1) = '"' then
499 exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';
501 else
502 -- Terminate on parens or angle brackets or equal sign
504 exit when Nextc = '(' or else Nextc = ')'
505 or else Nextc = '{' or else Nextc = '}'
506 or else Nextc = '<' or else Nextc = '>'
507 or else Nextc = '=';
509 -- Terminate on comma
511 exit when Nextc = ',';
513 -- Terminate if left bracket not part of wide char sequence
514 -- Note that we only recognize brackets notation so far ???
516 exit when Nextc = '[' and then T (P + 1) /= '"';
518 -- Terminate if right bracket not part of wide char sequence
520 exit when Nextc = ']' and then T (P - 1) /= '"';
521 end if;
522 end if;
523 end loop;
525 return Name_Find;
526 end Get_Name;
528 -------------------
529 -- Get_Unit_Name --
530 -------------------
532 function Get_Unit_Name return Unit_Name_Type is
533 begin
534 return Unit_Name_Type (Get_Name);
535 end Get_Unit_Name;
537 -------------
538 -- Get_Nat --
539 -------------
541 function Get_Nat return Nat is
542 V : Nat;
544 begin
545 Skip_Space;
547 -- Check if we are on a number. In the case of bad ALI files, this
548 -- may not be true.
550 if not (Nextc in '0' .. '9') then
551 Fatal_Error;
552 end if;
554 V := 0;
555 loop
556 V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0'));
558 exit when At_End_Of_Field;
559 exit when Nextc < '0' or else Nextc > '9';
560 end loop;
562 return V;
563 end Get_Nat;
565 ---------------
566 -- Get_Stamp --
567 ---------------
569 function Get_Stamp return Time_Stamp_Type is
570 T : Time_Stamp_Type;
571 Start : Integer;
573 begin
574 Skip_Space;
576 if At_Eol then
577 if Ignore_Errors then
578 return Dummy_Time_Stamp;
579 else
580 Fatal_Error;
581 end if;
582 end if;
584 -- Following reads old style time stamp missing first two digits
586 if Nextc in '7' .. '9' then
587 T (1) := '1';
588 T (2) := '9';
589 Start := 3;
591 -- Normal case of full year in time stamp
593 else
594 Start := 1;
595 end if;
597 for J in Start .. T'Last loop
598 T (J) := Getc;
599 end loop;
601 return T;
602 end Get_Stamp;
604 -----------------
605 -- Get_Typeref --
606 -----------------
608 procedure Get_Typeref
609 (Current_File_Num : Sdep_Id;
610 Ref : out Tref_Kind;
611 File_Num : out Sdep_Id;
612 Line : out Nat;
613 Ref_Type : out Character;
614 Col : out Nat;
615 Standard_Entity : out Name_Id)
617 N : Nat;
618 begin
619 case Nextc is
620 when '<' => Ref := Tref_Derived;
621 when '(' => Ref := Tref_Access;
622 when '{' => Ref := Tref_Type;
623 when others => Ref := Tref_None;
624 end case;
626 -- Case of typeref field present
628 if Ref /= Tref_None then
629 P := P + 1; -- skip opening bracket
631 if Nextc in 'a' .. 'z' then
632 File_Num := No_Sdep_Id;
633 Line := 0;
634 Ref_Type := ' ';
635 Col := 0;
636 Standard_Entity := Get_Name (Ignore_Spaces => True);
637 else
638 N := Get_Nat;
640 if Nextc = '|' then
641 File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
642 P := P + 1;
643 N := Get_Nat;
644 else
645 File_Num := Current_File_Num;
646 end if;
648 Line := N;
649 Ref_Type := Getc;
650 Col := Get_Nat;
651 Standard_Entity := No_Name;
652 end if;
654 -- ??? Temporary workaround for nested generics case:
655 -- 4i4 Directories{1|4I9[4|6[3|3]]}
656 -- See C918-002
658 declare
659 Nested_Brackets : Natural := 0;
661 begin
662 loop
663 case Nextc is
664 when '[' =>
665 Nested_Brackets := Nested_Brackets + 1;
666 when ']' =>
667 Nested_Brackets := Nested_Brackets - 1;
668 when others =>
669 if Nested_Brackets = 0 then
670 exit;
671 end if;
672 end case;
674 Skipc;
675 end loop;
676 end;
678 P := P + 1; -- skip closing bracket
679 Skip_Space;
681 -- No typeref entry present
683 else
684 File_Num := No_Sdep_Id;
685 Line := 0;
686 Ref_Type := ' ';
687 Col := 0;
688 Standard_Entity := No_Name;
689 end if;
690 end Get_Typeref;
692 ----------
693 -- Getc --
694 ----------
696 function Getc return Character is
697 begin
698 if P = T'Last then
699 return EOF;
700 else
701 P := P + 1;
702 return T (P - 1);
703 end if;
704 end Getc;
706 -----------
707 -- Nextc --
708 -----------
710 function Nextc return Character is
711 begin
712 return T (P);
713 end Nextc;
715 --------------
716 -- Skip_Eol --
717 --------------
719 procedure Skip_Eol is
720 begin
721 Skip_Space;
723 if not At_Eol then
724 if Ignore_Errors then
725 while not At_Eol loop
726 P := P + 1;
727 end loop;
728 else
729 Fatal_Error;
730 end if;
731 end if;
733 -- Loop to skip past blank lines (first time through skips this EOL)
735 while Nextc < ' ' and then Nextc /= EOF loop
736 if Nextc = LF then
737 Line := Line + 1;
738 end if;
740 P := P + 1;
741 end loop;
742 end Skip_Eol;
744 ---------------
745 -- Skip_Line --
746 ---------------
748 procedure Skip_Line is
749 begin
750 while not At_Eol loop
751 P := P + 1;
752 end loop;
754 Skip_Eol;
755 end Skip_Line;
757 ----------------
758 -- Skip_Space --
759 ----------------
761 procedure Skip_Space is
762 begin
763 while Nextc = ' ' or else Nextc = HT loop
764 P := P + 1;
765 end loop;
766 end Skip_Space;
768 -----------
769 -- Skipc --
770 -----------
772 procedure Skipc is
773 begin
774 if P /= T'Last then
775 P := P + 1;
776 end if;
777 end Skipc;
779 -- Start of processing for Scan_ALI
781 begin
782 First_Sdep_Entry := Sdep.Last + 1;
784 -- Acquire lines to be ignored
786 if Read_Xref then
787 Ignore :=
788 ('U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True);
790 -- Read_Lines parameter given
792 elsif Read_Lines /= "" then
793 Ignore := ('U' => False, others => True);
795 for J in Read_Lines'Range loop
796 Ignore (Read_Lines (J)) := False;
797 end loop;
799 -- Process Ignore_Lines parameter
801 else
802 Ignore := (others => False);
804 for J in Ignore_Lines'Range loop
805 pragma Assert (Ignore_Lines (J) /= 'U');
806 Ignore (Ignore_Lines (J)) := True;
807 end loop;
808 end if;
810 -- Setup ALI Table entry with appropriate defaults
812 ALIs.Increment_Last;
813 Id := ALIs.Last;
814 Set_Name_Table_Info (F, Int (Id));
816 ALIs.Table (Id) := (
817 Afile => F,
818 Compile_Errors => False,
819 First_Interrupt_State => Interrupt_States.Last + 1,
820 First_Sdep => No_Sdep_Id,
821 First_Specific_Dispatching => Specific_Dispatching.Last + 1,
822 First_Unit => No_Unit_Id,
823 Float_Format => 'I',
824 Last_Interrupt_State => Interrupt_States.Last,
825 Last_Sdep => No_Sdep_Id,
826 Last_Specific_Dispatching => Specific_Dispatching.Last,
827 Last_Unit => No_Unit_Id,
828 Locking_Policy => ' ',
829 Main_Priority => -1,
830 Main_CPU => -1,
831 Main_Program => None,
832 No_Object => False,
833 Normalize_Scalars => False,
834 Ofile_Full_Name => Full_Object_File_Name,
835 Partition_Elaboration_Policy => ' ',
836 Queuing_Policy => ' ',
837 Restrictions => No_Restrictions,
838 SAL_Interface => False,
839 Sfile => No_File,
840 Task_Dispatching_Policy => ' ',
841 Time_Slice_Value => -1,
842 Allocator_In_Body => False,
843 WC_Encoding => 'b',
844 Unit_Exception_Table => False,
845 Ver => (others => ' '),
846 Ver_Len => 0,
847 Zero_Cost_Exceptions => False);
849 -- Now we acquire the input lines from the ALI file. Note that the
850 -- convention in the following code is that as we enter each section,
851 -- C is set to contain the first character of the following line.
853 C := Getc;
854 Check_Unknown_Line;
856 -- Acquire library version
858 if C /= 'V' then
860 -- The V line missing really indicates trouble, most likely it
861 -- means we don't have an ALI file at all, so here we give a
862 -- fatal error even if we are in Ignore_Errors mode.
864 Fatal_Error;
866 elsif Ignore ('V') then
867 Skip_Line;
869 else
870 Checkc (' ');
871 Skip_Space;
872 Checkc ('"');
874 for J in 1 .. Ver_Len_Max loop
875 C := Getc;
876 exit when C = '"';
877 ALIs.Table (Id).Ver (J) := C;
878 ALIs.Table (Id).Ver_Len := J;
879 end loop;
881 Skip_Eol;
882 end if;
884 C := Getc;
885 Check_Unknown_Line;
887 -- Acquire main program line if present
889 if C = 'M' then
890 if Ignore ('M') then
891 Skip_Line;
893 else
894 Checkc (' ');
895 Skip_Space;
897 C := Getc;
899 if C = 'F' then
900 ALIs.Table (Id).Main_Program := Func;
901 elsif C = 'P' then
902 ALIs.Table (Id).Main_Program := Proc;
903 else
904 P := P - 1;
905 Fatal_Error;
906 end if;
908 Skip_Space;
910 if not At_Eol then
911 if Nextc < 'A' then
912 ALIs.Table (Id).Main_Priority := Get_Nat;
913 end if;
915 Skip_Space;
917 if Nextc = 'T' then
918 P := P + 1;
919 Checkc ('=');
920 ALIs.Table (Id).Time_Slice_Value := Get_Nat;
921 end if;
923 Skip_Space;
925 if Nextc = 'A' then
926 P := P + 1;
927 Checkc ('B');
928 ALIs.Table (Id).Allocator_In_Body := True;
929 end if;
931 Skip_Space;
933 if Nextc = 'C' then
934 P := P + 1;
935 Checkc ('=');
936 ALIs.Table (Id).Main_CPU := Get_Nat;
937 end if;
939 Skip_Space;
941 Checkc ('W');
942 Checkc ('=');
943 ALIs.Table (Id).WC_Encoding := Getc;
944 end if;
946 Skip_Eol;
947 end if;
949 C := Getc;
950 end if;
952 -- Acquire argument lines
954 First_Arg := Args.Last + 1;
956 A_Loop : loop
957 Check_Unknown_Line;
958 exit A_Loop when C /= 'A';
960 if Ignore ('A') then
961 Skip_Line;
963 else
964 Checkc (' ');
966 -- Scan out argument
968 Name_Len := 0;
969 while not At_Eol loop
970 Add_Char_To_Name_Buffer (Getc);
971 end loop;
973 -- If -fstack-check, record that it occurred. Note that an
974 -- additional string parameter can be specified, in the form of
975 -- -fstack-check={no|generic|specific}. "no" means no checking,
976 -- "generic" means force the use of old-style checking, and
977 -- "specific" means use the best checking method.
979 if Name_Len >= 13
980 and then Name_Buffer (1 .. 13) = "-fstack-check"
981 and then Name_Buffer (1 .. Name_Len) /= "-fstack-check=no"
982 then
983 Stack_Check_Switch_Set := True;
984 end if;
986 -- Store the argument
988 Args.Increment_Last;
989 Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len));
991 Skip_Eol;
992 end if;
994 C := Getc;
995 end loop A_Loop;
997 -- Acquire P line
999 Check_Unknown_Line;
1001 while C /= 'P' loop
1002 if Ignore_Errors then
1003 if C = EOF then
1004 Fatal_Error;
1005 else
1006 Skip_Line;
1007 C := Nextc;
1008 end if;
1009 else
1010 Fatal_Error;
1011 end if;
1012 end loop;
1014 if Ignore ('P') then
1015 Skip_Line;
1017 -- Process P line
1019 else
1020 NS_Found := False;
1022 while not At_Eol loop
1023 Checkc (' ');
1024 Skip_Space;
1025 C := Getc;
1027 -- Processing for CE
1029 if C = 'C' then
1030 Checkc ('E');
1031 ALIs.Table (Id).Compile_Errors := True;
1033 -- Processing for DB
1035 elsif C = 'D' then
1036 Checkc ('B');
1037 Detect_Blocking := True;
1039 -- Processing for Ex
1041 elsif C = 'E' then
1042 Partition_Elaboration_Policy_Specified := Getc;
1043 ALIs.Table (Id).Partition_Elaboration_Policy :=
1044 Partition_Elaboration_Policy_Specified;
1046 -- Processing for FD/FG/FI
1048 elsif C = 'F' then
1049 Float_Format_Specified := Getc;
1050 ALIs.Table (Id).Float_Format := Float_Format_Specified;
1052 -- Processing for Lx
1054 elsif C = 'L' then
1055 Locking_Policy_Specified := Getc;
1056 ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
1058 -- Processing for flags starting with N
1060 elsif C = 'N' then
1061 C := Getc;
1063 -- Processing for NO
1065 if C = 'O' then
1066 ALIs.Table (Id).No_Object := True;
1067 No_Object_Specified := True;
1069 -- Processing for NR
1071 elsif C = 'R' then
1072 No_Run_Time_Mode := True;
1073 Configurable_Run_Time_Mode := True;
1075 -- Processing for NS
1077 elsif C = 'S' then
1078 ALIs.Table (Id).Normalize_Scalars := True;
1079 Normalize_Scalars_Specified := True;
1080 NS_Found := True;
1082 -- Invalid switch starting with N
1084 else
1085 Fatal_Error_Ignore;
1086 end if;
1088 -- Processing for Qx
1090 elsif C = 'Q' then
1091 Queuing_Policy_Specified := Getc;
1092 ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
1094 -- Processing for flags starting with S
1096 elsif C = 'S' then
1097 C := Getc;
1099 -- Processing for SL
1101 if C = 'L' then
1102 ALIs.Table (Id).SAL_Interface := True;
1104 -- Processing for SS
1106 elsif C = 'S' then
1107 Opt.Sec_Stack_Used := True;
1109 -- Invalid switch starting with S
1111 else
1112 Fatal_Error_Ignore;
1113 end if;
1115 -- Processing for Tx
1117 elsif C = 'T' then
1118 Task_Dispatching_Policy_Specified := Getc;
1119 ALIs.Table (Id).Task_Dispatching_Policy :=
1120 Task_Dispatching_Policy_Specified;
1122 -- Processing for switch starting with U
1124 elsif C = 'U' then
1125 C := Getc;
1127 -- Processing for UA
1129 if C = 'A' then
1130 Unreserve_All_Interrupts_Specified := True;
1132 -- Processing for UX
1134 elsif C = 'X' then
1135 ALIs.Table (Id).Unit_Exception_Table := True;
1137 -- Invalid switches starting with U
1139 else
1140 Fatal_Error_Ignore;
1141 end if;
1143 -- Processing for ZX
1145 elsif C = 'Z' then
1146 C := Getc;
1148 if C = 'X' then
1149 ALIs.Table (Id).Zero_Cost_Exceptions := True;
1150 Zero_Cost_Exceptions_Specified := True;
1151 else
1152 Fatal_Error_Ignore;
1153 end if;
1155 -- Invalid parameter
1157 else
1158 C := Getc;
1159 Fatal_Error_Ignore;
1160 end if;
1161 end loop;
1163 if not NS_Found then
1164 No_Normalize_Scalars_Specified := True;
1165 end if;
1167 Skip_Eol;
1168 end if;
1170 C := Getc;
1171 Check_Unknown_Line;
1173 -- Loop to skip to first restrictions line
1175 while C /= 'R' loop
1176 if Ignore_Errors then
1177 if C = EOF then
1178 Fatal_Error;
1179 else
1180 Skip_Line;
1181 C := Nextc;
1182 end if;
1183 else
1184 Fatal_Error;
1185 end if;
1186 end loop;
1188 -- Ignore all 'R' lines if that is required
1190 if Ignore ('R') then
1191 while C = 'R' loop
1192 Skip_Line;
1193 C := Getc;
1194 end loop;
1196 -- Here we process the restrictions lines (other than unit name cases)
1198 else
1199 Scan_Restrictions : declare
1200 Save_R : constant Restrictions_Info := Cumulative_Restrictions;
1201 -- Save cumulative restrictions in case we have a fatal error
1203 Bad_R_Line : exception;
1204 -- Signal bad restrictions line (raised on unexpected character)
1206 Typ : Character;
1207 R : Restriction_Id;
1208 N : Natural;
1210 begin
1211 -- Named restriction case
1213 if Nextc = 'N' then
1214 Skip_Line;
1215 C := Getc;
1217 -- Loop through RR and RV lines
1219 while C = 'R' and then Nextc /= ' ' loop
1220 Typ := Getc;
1221 Checkc (' ');
1223 -- Acquire restriction name
1225 Name_Len := 0;
1226 while not At_Eol and then Nextc /= '=' loop
1227 Name_Len := Name_Len + 1;
1228 Name_Buffer (Name_Len) := Getc;
1229 end loop;
1231 -- Now search list of restrictions to find match
1233 declare
1234 RN : String renames Name_Buffer (1 .. Name_Len);
1236 begin
1237 R := Restriction_Id'First;
1238 while R < Not_A_Restriction_Id loop
1239 if Restriction_Id'Image (R) = RN then
1240 goto R_Found;
1241 end if;
1243 R := Restriction_Id'Succ (R);
1244 end loop;
1246 -- We don't recognize the restriction. This might be
1247 -- thought of as an error, and it really is, but we
1248 -- want to allow building with inconsistent versions
1249 -- of the binder and ali files (see comments at the
1250 -- start of package System.Rident), so we just ignore
1251 -- this situation.
1253 goto Done_With_Restriction_Line;
1254 end;
1256 <<R_Found>>
1258 case R is
1260 -- Boolean restriction case
1262 when All_Boolean_Restrictions =>
1263 case Typ is
1264 when 'V' =>
1265 ALIs.Table (Id).Restrictions.Violated (R) :=
1266 True;
1267 Cumulative_Restrictions.Violated (R) := True;
1269 when 'R' =>
1270 ALIs.Table (Id).Restrictions.Set (R) := True;
1271 Cumulative_Restrictions.Set (R) := True;
1273 when others =>
1274 raise Bad_R_Line;
1275 end case;
1277 -- Parameter restriction case
1279 when All_Parameter_Restrictions =>
1280 if At_Eol or else Nextc /= '=' then
1281 raise Bad_R_Line;
1282 else
1283 Skipc;
1284 end if;
1286 N := Natural (Get_Nat);
1288 case Typ is
1290 -- Restriction set
1292 when 'R' =>
1293 ALIs.Table (Id).Restrictions.Set (R) := True;
1294 ALIs.Table (Id).Restrictions.Value (R) := N;
1296 if Cumulative_Restrictions.Set (R) then
1297 Cumulative_Restrictions.Value (R) :=
1298 Integer'Min
1299 (Cumulative_Restrictions.Value (R), N);
1300 else
1301 Cumulative_Restrictions.Set (R) := True;
1302 Cumulative_Restrictions.Value (R) := N;
1303 end if;
1305 -- Restriction violated
1307 when 'V' =>
1308 ALIs.Table (Id).Restrictions.Violated (R) :=
1309 True;
1310 Cumulative_Restrictions.Violated (R) := True;
1311 ALIs.Table (Id).Restrictions.Count (R) := N;
1313 -- Checked Max_Parameter case
1315 if R in Checked_Max_Parameter_Restrictions then
1316 Cumulative_Restrictions.Count (R) :=
1317 Integer'Max
1318 (Cumulative_Restrictions.Count (R), N);
1320 -- Other checked parameter cases
1322 else
1323 declare
1324 pragma Unsuppress (Overflow_Check);
1326 begin
1327 Cumulative_Restrictions.Count (R) :=
1328 Cumulative_Restrictions.Count (R) + N;
1330 exception
1331 when Constraint_Error =>
1333 -- A constraint error comes from the
1334 -- addition. We reset to the maximum
1335 -- and indicate that the real value
1336 -- is now unknown.
1338 Cumulative_Restrictions.Value (R) :=
1339 Integer'Last;
1340 Cumulative_Restrictions.Unknown (R) :=
1341 True;
1342 end;
1343 end if;
1345 -- Deal with + case
1347 if Nextc = '+' then
1348 Skipc;
1349 ALIs.Table (Id).Restrictions.Unknown (R) :=
1350 True;
1351 Cumulative_Restrictions.Unknown (R) := True;
1352 end if;
1354 -- Other than 'R' or 'V'
1356 when others =>
1357 raise Bad_R_Line;
1358 end case;
1360 if not At_Eol then
1361 raise Bad_R_Line;
1362 end if;
1364 -- Bizarre error case NOT_A_RESTRICTION
1366 when Not_A_Restriction_Id =>
1367 raise Bad_R_Line;
1368 end case;
1370 if not At_Eol then
1371 raise Bad_R_Line;
1372 end if;
1374 <<Done_With_Restriction_Line>>
1375 Skip_Line;
1376 C := Getc;
1377 end loop;
1379 -- Positional restriction case
1381 else
1382 Checkc (' ');
1383 Skip_Space;
1385 -- Acquire information for boolean restrictions
1387 for R in All_Boolean_Restrictions loop
1388 C := Getc;
1390 case C is
1391 when 'v' =>
1392 ALIs.Table (Id).Restrictions.Violated (R) := True;
1393 Cumulative_Restrictions.Violated (R) := True;
1395 when 'r' =>
1396 ALIs.Table (Id).Restrictions.Set (R) := True;
1397 Cumulative_Restrictions.Set (R) := True;
1399 when 'n' =>
1400 null;
1402 when others =>
1403 raise Bad_R_Line;
1404 end case;
1405 end loop;
1407 -- Acquire information for parameter restrictions
1409 for RP in All_Parameter_Restrictions loop
1410 case Getc is
1411 when 'n' =>
1412 null;
1414 when 'r' =>
1415 ALIs.Table (Id).Restrictions.Set (RP) := True;
1417 declare
1418 N : constant Integer := Integer (Get_Nat);
1419 begin
1420 ALIs.Table (Id).Restrictions.Value (RP) := N;
1422 if Cumulative_Restrictions.Set (RP) then
1423 Cumulative_Restrictions.Value (RP) :=
1424 Integer'Min
1425 (Cumulative_Restrictions.Value (RP), N);
1426 else
1427 Cumulative_Restrictions.Set (RP) := True;
1428 Cumulative_Restrictions.Value (RP) := N;
1429 end if;
1430 end;
1432 when others =>
1433 raise Bad_R_Line;
1434 end case;
1436 -- Acquire restrictions violations information
1438 case Getc is
1440 when 'n' =>
1441 null;
1443 when 'v' =>
1444 ALIs.Table (Id).Restrictions.Violated (RP) := True;
1445 Cumulative_Restrictions.Violated (RP) := True;
1447 declare
1448 N : constant Integer := Integer (Get_Nat);
1450 begin
1451 ALIs.Table (Id).Restrictions.Count (RP) := N;
1453 if RP in Checked_Max_Parameter_Restrictions then
1454 Cumulative_Restrictions.Count (RP) :=
1455 Integer'Max
1456 (Cumulative_Restrictions.Count (RP), N);
1458 else
1459 declare
1460 pragma Unsuppress (Overflow_Check);
1462 begin
1463 Cumulative_Restrictions.Count (RP) :=
1464 Cumulative_Restrictions.Count (RP) + N;
1466 exception
1467 when Constraint_Error =>
1469 -- A constraint error comes from the add. We
1470 -- reset to the maximum and indicate that the
1471 -- real value is now unknown.
1473 Cumulative_Restrictions.Value (RP) :=
1474 Integer'Last;
1475 Cumulative_Restrictions.Unknown (RP) := True;
1476 end;
1477 end if;
1479 if Nextc = '+' then
1480 Skipc;
1481 ALIs.Table (Id).Restrictions.Unknown (RP) := True;
1482 Cumulative_Restrictions.Unknown (RP) := True;
1483 end if;
1484 end;
1486 when others =>
1487 raise Bad_R_Line;
1488 end case;
1489 end loop;
1491 if not At_Eol then
1492 raise Bad_R_Line;
1493 else
1494 Skip_Line;
1495 C := Getc;
1496 end if;
1497 end if;
1499 -- Here if error during scanning of restrictions line
1501 exception
1502 when Bad_R_Line =>
1504 -- In Ignore_Errors mode, undo any changes to restrictions
1505 -- from this unit, and continue on, skipping remaining R
1506 -- lines for this unit.
1508 if Ignore_Errors then
1509 Cumulative_Restrictions := Save_R;
1510 ALIs.Table (Id).Restrictions := No_Restrictions;
1512 loop
1513 Skip_Eol;
1514 C := Getc;
1515 exit when C /= 'R';
1516 end loop;
1518 -- In normal mode, this is a fatal error
1520 else
1521 Fatal_Error;
1522 end if;
1523 end Scan_Restrictions;
1524 end if;
1526 -- Acquire additional restrictions (No_Dependence) lines if present
1528 while C = 'R' loop
1529 if Ignore ('R') then
1530 Skip_Line;
1531 else
1532 Skip_Space;
1533 No_Deps.Append ((Id, Get_Name));
1534 Skip_Eol;
1535 end if;
1537 C := Getc;
1538 end loop;
1540 -- Acquire 'I' lines if present
1542 Check_Unknown_Line;
1544 while C = 'I' loop
1545 if Ignore ('I') then
1546 Skip_Line;
1548 else
1549 declare
1550 Int_Num : Nat;
1551 I_State : Character;
1552 Line_No : Nat;
1554 begin
1555 Int_Num := Get_Nat;
1556 Skip_Space;
1557 I_State := Getc;
1558 Line_No := Get_Nat;
1560 Interrupt_States.Append (
1561 (Interrupt_Id => Int_Num,
1562 Interrupt_State => I_State,
1563 IS_Pragma_Line => Line_No));
1565 ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last;
1566 Skip_Eol;
1567 end;
1568 end if;
1570 C := Getc;
1571 end loop;
1573 -- Acquire 'S' lines if present
1575 Check_Unknown_Line;
1577 while C = 'S' loop
1578 if Ignore ('S') then
1579 Skip_Line;
1581 else
1582 declare
1583 Policy : Character;
1584 First_Prio : Nat;
1585 Last_Prio : Nat;
1586 Line_No : Nat;
1588 begin
1589 Checkc (' ');
1590 Skip_Space;
1592 Policy := Getc;
1593 Skip_Space;
1594 First_Prio := Get_Nat;
1595 Last_Prio := Get_Nat;
1596 Line_No := Get_Nat;
1598 Specific_Dispatching.Append (
1599 (Dispatching_Policy => Policy,
1600 First_Priority => First_Prio,
1601 Last_Priority => Last_Prio,
1602 PSD_Pragma_Line => Line_No));
1604 ALIs.Table (Id).Last_Specific_Dispatching :=
1605 Specific_Dispatching.Last;
1607 Skip_Eol;
1608 end;
1609 end if;
1611 C := Getc;
1612 end loop;
1614 -- Loop to acquire unit entries
1616 U_Loop : loop
1617 Check_Unknown_Line;
1618 exit U_Loop when C /= 'U';
1620 -- Note: as per spec, we never ignore U lines
1622 Checkc (' ');
1623 Skip_Space;
1624 Units.Increment_Last;
1626 if ALIs.Table (Id).First_Unit = No_Unit_Id then
1627 ALIs.Table (Id).First_Unit := Units.Last;
1628 end if;
1630 declare
1631 UL : Unit_Record renames Units.Table (Units.Last);
1633 begin
1634 UL.Uname := Get_Unit_Name;
1635 UL.Predefined := Is_Predefined_Unit;
1636 UL.Internal := Is_Internal_Unit;
1637 UL.My_ALI := Id;
1638 UL.Sfile := Get_File_Name (Lower => True);
1639 UL.Pure := False;
1640 UL.Preelab := False;
1641 UL.No_Elab := False;
1642 UL.Shared_Passive := False;
1643 UL.RCI := False;
1644 UL.Remote_Types := False;
1645 UL.Has_RACW := False;
1646 UL.Init_Scalars := False;
1647 UL.Is_Generic := False;
1648 UL.Icasing := Mixed_Case;
1649 UL.Kcasing := All_Lower_Case;
1650 UL.Dynamic_Elab := False;
1651 UL.Elaborate_Body := False;
1652 UL.Set_Elab_Entity := False;
1653 UL.Version := "00000000";
1654 UL.First_With := Withs.Last + 1;
1655 UL.First_Arg := First_Arg;
1656 UL.Elab_Position := 0;
1657 UL.SAL_Interface := ALIs.Table (Id).SAL_Interface;
1658 UL.Directly_Scanned := Directly_Scanned;
1659 UL.Body_Needed_For_SAL := False;
1660 UL.Elaborate_Body_Desirable := False;
1661 UL.Optimize_Alignment := 'O';
1662 UL.Has_Finalizer := False;
1664 if Debug_Flag_U then
1665 Write_Str (" ----> reading unit ");
1666 Write_Int (Int (Units.Last));
1667 Write_Str (" ");
1668 Write_Unit_Name (UL.Uname);
1669 Write_Str (" from file ");
1670 Write_Name (UL.Sfile);
1671 Write_Eol;
1672 end if;
1673 end;
1675 -- Check for duplicated unit in different files
1677 declare
1678 Info : constant Int := Get_Name_Table_Info
1679 (Units.Table (Units.Last).Uname);
1680 begin
1681 if Info /= 0
1682 and then Units.Table (Units.Last).Sfile /=
1683 Units.Table (Unit_Id (Info)).Sfile
1684 then
1685 -- If Err is set then ignore duplicate unit name. This is the
1686 -- case of a call from gnatmake, where the situation can arise
1687 -- from substitution of source files. In such situations, the
1688 -- processing in gnatmake will always result in any required
1689 -- recompilations in any case, and if we consider this to be
1690 -- an error we get strange cases (for example when a generic
1691 -- instantiation is replaced by a normal package) where we
1692 -- read the old ali file, decide to recompile, and then decide
1693 -- that the old and new ali files are incompatible.
1695 if Err then
1696 null;
1698 -- If Err is not set, then this is a fatal error. This is
1699 -- the case of being called from the binder, where we must
1700 -- definitely diagnose this as an error.
1702 else
1703 Set_Standard_Error;
1704 Write_Str ("error: duplicate unit name: ");
1705 Write_Eol;
1707 Write_Str ("error: unit """);
1708 Write_Unit_Name (Units.Table (Units.Last).Uname);
1709 Write_Str (""" found in file """);
1710 Write_Name_Decoded (Units.Table (Units.Last).Sfile);
1711 Write_Char ('"');
1712 Write_Eol;
1714 Write_Str ("error: unit """);
1715 Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
1716 Write_Str (""" found in file """);
1717 Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
1718 Write_Char ('"');
1719 Write_Eol;
1721 Exit_Program (E_Fatal);
1722 end if;
1723 end if;
1724 end;
1726 Set_Name_Table_Info
1727 (Units.Table (Units.Last).Uname, Int (Units.Last));
1729 -- Scan out possible version and other parameters
1731 loop
1732 Skip_Space;
1733 exit when At_Eol;
1734 C := Getc;
1736 -- Version field
1738 if C in '0' .. '9' or else C in 'a' .. 'f' then
1739 Units.Table (Units.Last).Version (1) := C;
1741 for J in 2 .. 8 loop
1742 C := Getc;
1743 Units.Table (Units.Last).Version (J) := C;
1744 end loop;
1746 -- BD/BN parameters
1748 elsif C = 'B' then
1749 C := Getc;
1751 if C = 'D' then
1752 Check_At_End_Of_Field;
1753 Units.Table (Units.Last).Elaborate_Body_Desirable := True;
1755 elsif C = 'N' then
1756 Check_At_End_Of_Field;
1757 Units.Table (Units.Last).Body_Needed_For_SAL := True;
1759 else
1760 Fatal_Error_Ignore;
1761 end if;
1763 -- DE parameter (Dynamic elaboration checks)
1765 elsif C = 'D' then
1766 C := Getc;
1768 if C = 'E' then
1769 Check_At_End_Of_Field;
1770 Units.Table (Units.Last).Dynamic_Elab := True;
1771 Dynamic_Elaboration_Checks_Specified := True;
1772 else
1773 Fatal_Error_Ignore;
1774 end if;
1776 -- EB/EE parameters
1778 elsif C = 'E' then
1779 C := Getc;
1781 if C = 'B' then
1782 Units.Table (Units.Last).Elaborate_Body := True;
1783 elsif C = 'E' then
1784 Units.Table (Units.Last).Set_Elab_Entity := True;
1785 else
1786 Fatal_Error_Ignore;
1787 end if;
1789 Check_At_End_Of_Field;
1791 -- GE parameter (generic)
1793 elsif C = 'G' then
1794 C := Getc;
1796 if C = 'E' then
1797 Check_At_End_Of_Field;
1798 Units.Table (Units.Last).Is_Generic := True;
1799 else
1800 Fatal_Error_Ignore;
1801 end if;
1803 -- IL/IS/IU parameters
1805 elsif C = 'I' then
1806 C := Getc;
1808 if C = 'L' then
1809 Units.Table (Units.Last).Icasing := All_Lower_Case;
1810 elsif C = 'S' then
1811 Units.Table (Units.Last).Init_Scalars := True;
1812 Initialize_Scalars_Used := True;
1813 elsif C = 'U' then
1814 Units.Table (Units.Last).Icasing := All_Upper_Case;
1815 else
1816 Fatal_Error_Ignore;
1817 end if;
1819 Check_At_End_Of_Field;
1821 -- KM/KU parameters
1823 elsif C = 'K' then
1824 C := Getc;
1826 if C = 'M' then
1827 Units.Table (Units.Last).Kcasing := Mixed_Case;
1828 elsif C = 'U' then
1829 Units.Table (Units.Last).Kcasing := All_Upper_Case;
1830 else
1831 Fatal_Error_Ignore;
1832 end if;
1834 Check_At_End_Of_Field;
1836 -- NE parameter
1838 elsif C = 'N' then
1839 C := Getc;
1841 if C = 'E' then
1842 Units.Table (Units.Last).No_Elab := True;
1843 Check_At_End_Of_Field;
1844 else
1845 Fatal_Error_Ignore;
1846 end if;
1848 -- PF/PR/PU/PK parameters
1850 elsif C = 'P' then
1851 C := Getc;
1853 if C = 'F' then
1854 Units.Table (Units.Last).Has_Finalizer := True;
1855 elsif C = 'R' then
1856 Units.Table (Units.Last).Preelab := True;
1857 elsif C = 'U' then
1858 Units.Table (Units.Last).Pure := True;
1859 elsif C = 'K' then
1860 Units.Table (Units.Last).Unit_Kind := 'p';
1861 else
1862 Fatal_Error_Ignore;
1863 end if;
1865 Check_At_End_Of_Field;
1867 -- OL/OO/OS/OT parameters
1869 elsif C = 'O' then
1870 C := Getc;
1872 if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then
1873 Units.Table (Units.Last).Optimize_Alignment := C;
1874 else
1875 Fatal_Error_Ignore;
1876 end if;
1878 Check_At_End_Of_Field;
1880 -- RC/RT parameters
1882 elsif C = 'R' then
1883 C := Getc;
1885 if C = 'C' then
1886 Units.Table (Units.Last).RCI := True;
1887 elsif C = 'T' then
1888 Units.Table (Units.Last).Remote_Types := True;
1889 elsif C = 'A' then
1890 Units.Table (Units.Last).Has_RACW := True;
1891 else
1892 Fatal_Error_Ignore;
1893 end if;
1895 Check_At_End_Of_Field;
1897 elsif C = 'S' then
1898 C := Getc;
1900 if C = 'P' then
1901 Units.Table (Units.Last).Shared_Passive := True;
1902 elsif C = 'U' then
1903 Units.Table (Units.Last).Unit_Kind := 's';
1904 else
1905 Fatal_Error_Ignore;
1906 end if;
1908 Check_At_End_Of_Field;
1910 else
1911 C := Getc;
1912 Fatal_Error_Ignore;
1913 end if;
1914 end loop;
1916 Skip_Eol;
1918 -- Check if static elaboration model used
1920 if not Units.Table (Units.Last).Dynamic_Elab
1921 and then not Units.Table (Units.Last).Internal
1922 then
1923 Static_Elaboration_Model_Used := True;
1924 end if;
1926 C := Getc;
1928 -- Scan out With lines for this unit
1930 With_Loop : loop
1931 Check_Unknown_Line;
1932 exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z';
1934 if Ignore ('W') then
1935 Skip_Line;
1937 else
1938 Checkc (' ');
1939 Skip_Space;
1940 Withs.Increment_Last;
1941 Withs.Table (Withs.Last).Uname := Get_Unit_Name;
1942 Withs.Table (Withs.Last).Elaborate := False;
1943 Withs.Table (Withs.Last).Elaborate_All := False;
1944 Withs.Table (Withs.Last).Elab_Desirable := False;
1945 Withs.Table (Withs.Last).Elab_All_Desirable := False;
1946 Withs.Table (Withs.Last).SAL_Interface := False;
1947 Withs.Table (Withs.Last).Limited_With := (C = 'Y');
1948 Withs.Table (Withs.Last).Implicit_With_From_Instantiation
1949 := (C = 'Z');
1951 -- Generic case with no object file available
1953 if At_Eol then
1954 Withs.Table (Withs.Last).Sfile := No_File;
1955 Withs.Table (Withs.Last).Afile := No_File;
1957 -- Normal case
1959 else
1960 Withs.Table (Withs.Last).Sfile := Get_File_Name
1961 (Lower => True);
1962 Withs.Table (Withs.Last).Afile := Get_File_Name
1963 (Lower => True);
1965 -- Scan out possible E, EA, ED, and AD parameters
1967 while not At_Eol loop
1968 Skip_Space;
1970 if Nextc = 'A' then
1971 P := P + 1;
1972 Checkc ('D');
1973 Check_At_End_Of_Field;
1975 -- Store AD indication unless ignore required
1977 if not Ignore_ED then
1978 Withs.Table (Withs.Last).Elab_All_Desirable :=
1979 True;
1980 end if;
1982 elsif Nextc = 'E' then
1983 P := P + 1;
1985 if At_End_Of_Field then
1986 Withs.Table (Withs.Last).Elaborate := True;
1988 elsif Nextc = 'A' then
1989 P := P + 1;
1990 Check_At_End_Of_Field;
1991 Withs.Table (Withs.Last).Elaborate_All := True;
1993 else
1994 Checkc ('D');
1995 Check_At_End_Of_Field;
1997 -- Store ED indication unless ignore required
1999 if not Ignore_ED then
2000 Withs.Table (Withs.Last).Elab_Desirable :=
2001 True;
2002 end if;
2003 end if;
2005 else
2006 Fatal_Error;
2007 end if;
2008 end loop;
2009 end if;
2011 Skip_Eol;
2012 end if;
2014 C := Getc;
2015 end loop With_Loop;
2017 Units.Table (Units.Last).Last_With := Withs.Last;
2018 Units.Table (Units.Last).Last_Arg := Args.Last;
2020 -- If there are linker options lines present, scan them
2022 Name_Len := 0;
2024 Linker_Options_Loop : loop
2025 Check_Unknown_Line;
2026 exit Linker_Options_Loop when C /= 'L';
2028 if Ignore ('L') then
2029 Skip_Line;
2031 else
2032 Checkc (' ');
2033 Skip_Space;
2034 Checkc ('"');
2036 loop
2037 C := Getc;
2039 if C < Character'Val (16#20#)
2040 or else C > Character'Val (16#7E#)
2041 then
2042 Fatal_Error_Ignore;
2044 elsif C = '{' then
2045 C := Character'Val (0);
2047 declare
2048 V : Natural;
2050 begin
2051 V := 0;
2052 for J in 1 .. 2 loop
2053 C := Getc;
2055 if C in '0' .. '9' then
2056 V := V * 16 +
2057 Character'Pos (C) -
2058 Character'Pos ('0');
2060 elsif C in 'A' .. 'F' then
2061 V := V * 16 +
2062 Character'Pos (C) -
2063 Character'Pos ('A') +
2066 else
2067 Fatal_Error_Ignore;
2068 end if;
2069 end loop;
2071 Checkc ('}');
2072 Add_Char_To_Name_Buffer (Character'Val (V));
2073 end;
2075 else
2076 if C = '"' then
2077 exit when Nextc /= '"';
2078 C := Getc;
2079 end if;
2081 Add_Char_To_Name_Buffer (C);
2082 end if;
2083 end loop;
2085 Add_Char_To_Name_Buffer (NUL);
2086 Skip_Eol;
2087 end if;
2089 C := Getc;
2090 end loop Linker_Options_Loop;
2092 -- Store the linker options entry if one was found
2094 if Name_Len /= 0 then
2095 Linker_Options.Increment_Last;
2097 Linker_Options.Table (Linker_Options.Last).Name :=
2098 Name_Enter;
2100 Linker_Options.Table (Linker_Options.Last).Unit :=
2101 Units.Last;
2103 Linker_Options.Table (Linker_Options.Last).Internal_File :=
2104 Is_Internal_File_Name (F);
2106 Linker_Options.Table (Linker_Options.Last).Original_Pos :=
2107 Linker_Options.Last;
2108 end if;
2110 -- If there are notes present, scan them
2112 Notes_Loop : loop
2113 Check_Unknown_Line;
2114 exit Notes_Loop when C /= 'N';
2116 if Ignore ('N') then
2117 Skip_Line;
2119 else
2120 Checkc (' ');
2122 Notes.Increment_Last;
2123 Notes.Table (Notes.Last).Pragma_Type := Getc;
2124 Notes.Table (Notes.Last).Pragma_Line := Get_Nat;
2125 Checkc (':');
2126 Notes.Table (Notes.Last).Pragma_Col := Get_Nat;
2127 Notes.Table (Notes.Last).Unit := Units.Last;
2129 if At_Eol then
2130 Notes.Table (Notes.Last).Pragma_Args := No_Name;
2132 else
2133 Checkc (' ');
2135 Name_Len := 0;
2136 while not At_Eol loop
2137 Add_Char_To_Name_Buffer (Getc);
2138 end loop;
2140 Notes.Table (Notes.Last).Pragma_Args := Name_Enter;
2141 end if;
2143 Skip_Eol;
2144 end if;
2146 C := Getc;
2147 end loop Notes_Loop;
2148 end loop U_Loop;
2150 -- End loop through units for one ALI file
2152 ALIs.Table (Id).Last_Unit := Units.Last;
2153 ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile;
2155 -- Set types of the units (there can be at most 2 of them)
2157 if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then
2158 Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body;
2159 Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec;
2161 else
2162 -- Deal with body only and spec only cases, note that the reason we
2163 -- do our own checking of the name (rather than using Is_Body_Name)
2164 -- is that Uname drags in far too much compiler junk!
2166 Get_Name_String (Units.Table (Units.Last).Uname);
2168 if Name_Buffer (Name_Len) = 'b' then
2169 Units.Table (Units.Last).Utype := Is_Body_Only;
2170 else
2171 Units.Table (Units.Last).Utype := Is_Spec_Only;
2172 end if;
2173 end if;
2175 -- Scan out external version references and put in hash table
2177 E_Loop : loop
2178 Check_Unknown_Line;
2179 exit E_Loop when C /= 'E';
2181 if Ignore ('E') then
2182 Skip_Line;
2184 else
2185 Checkc (' ');
2186 Skip_Space;
2188 Name_Len := 0;
2189 Name_Len := 0;
2190 loop
2191 C := Getc;
2193 if C < ' ' then
2194 Fatal_Error;
2195 end if;
2197 exit when At_End_Of_Field;
2198 Add_Char_To_Name_Buffer (C);
2199 end loop;
2201 Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
2202 Skip_Eol;
2203 end if;
2205 C := Getc;
2206 end loop E_Loop;
2208 -- Scan out source dependency lines for this ALI file
2210 ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
2212 D_Loop : loop
2213 Check_Unknown_Line;
2214 exit D_Loop when C /= 'D';
2216 if Ignore ('D') then
2217 Skip_Line;
2219 else
2220 Checkc (' ');
2221 Skip_Space;
2222 Sdep.Increment_Last;
2224 -- In the following call, Lower is not set to True, this is either
2225 -- a bug, or it deserves a special comment as to why this is so???
2227 Sdep.Table (Sdep.Last).Sfile := Get_File_Name;
2229 Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
2230 Sdep.Table (Sdep.Last).Dummy_Entry :=
2231 (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
2233 -- Acquire checksum value
2235 Skip_Space;
2237 declare
2238 Ctr : Natural;
2239 Chk : Word;
2241 begin
2242 Ctr := 0;
2243 Chk := 0;
2245 loop
2246 exit when At_Eol or else Ctr = 8;
2248 if Nextc in '0' .. '9' then
2249 Chk := Chk * 16 +
2250 Character'Pos (Nextc) - Character'Pos ('0');
2252 elsif Nextc in 'a' .. 'f' then
2253 Chk := Chk * 16 +
2254 Character'Pos (Nextc) - Character'Pos ('a') + 10;
2256 else
2257 exit;
2258 end if;
2260 Ctr := Ctr + 1;
2261 P := P + 1;
2262 end loop;
2264 if Ctr = 8 and then At_End_Of_Field then
2265 Sdep.Table (Sdep.Last).Checksum := Chk;
2266 else
2267 Fatal_Error;
2268 end if;
2269 end;
2271 -- Acquire subunit and reference file name entries
2273 Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
2274 Sdep.Table (Sdep.Last).Rfile :=
2275 Sdep.Table (Sdep.Last).Sfile;
2276 Sdep.Table (Sdep.Last).Start_Line := 1;
2278 if not At_Eol then
2279 Skip_Space;
2281 -- Here for subunit name
2283 if Nextc not in '0' .. '9' then
2284 Name_Len := 0;
2285 while not At_End_Of_Field loop
2286 Add_Char_To_Name_Buffer (Getc);
2287 end loop;
2289 -- Set the subunit name. Note that we use Name_Find rather
2290 -- than Name_Enter here as the subunit name may already
2291 -- have been put in the name table by the Project Manager.
2293 Sdep.Table (Sdep.Last).Subunit_Name := Name_Find;
2295 Skip_Space;
2296 end if;
2298 -- Here for reference file name entry
2300 if Nextc in '0' .. '9' then
2301 Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
2302 Checkc (':');
2304 Name_Len := 0;
2306 while not At_End_Of_Field loop
2307 Add_Char_To_Name_Buffer (Getc);
2308 end loop;
2310 Sdep.Table (Sdep.Last).Rfile := Name_Enter;
2311 end if;
2312 end if;
2314 Skip_Eol;
2315 end if;
2317 C := Getc;
2318 end loop D_Loop;
2320 ALIs.Table (Id).Last_Sdep := Sdep.Last;
2322 -- We must at this stage be at an Xref line or the end of file
2324 if C = EOF then
2325 return Id;
2326 end if;
2328 Check_Unknown_Line;
2330 if C /= 'X' then
2331 Fatal_Error;
2332 end if;
2334 -- If we are ignoring Xref sections we are done (we ignore all
2335 -- remaining lines since only xref related lines follow X).
2337 if Ignore ('X') and then not Debug_Flag_X then
2338 return Id;
2339 end if;
2341 -- Loop through Xref sections
2343 X_Loop : loop
2344 Check_Unknown_Line;
2345 exit X_Loop when C /= 'X';
2347 -- Make new entry in section table
2349 Xref_Section.Increment_Last;
2351 Read_Refs_For_One_File : declare
2352 XS : Xref_Section_Record renames
2353 Xref_Section.Table (Xref_Section.Last);
2355 Current_File_Num : Sdep_Id;
2356 -- Keeps track of the current file number (changed by nn|)
2358 begin
2359 XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
2360 XS.File_Name := Get_File_Name;
2361 XS.First_Entity := Xref_Entity.Last + 1;
2363 Current_File_Num := XS.File_Num;
2365 Skip_Space;
2367 Skip_Eol;
2368 C := Nextc;
2370 -- Loop through Xref entities
2372 while C /= 'X' and then C /= EOF loop
2373 Xref_Entity.Increment_Last;
2375 Read_Refs_For_One_Entity : declare
2376 XE : Xref_Entity_Record renames
2377 Xref_Entity.Table (Xref_Entity.Last);
2378 N : Nat;
2380 procedure Read_Instantiation_Reference;
2381 -- Acquire instantiation reference. Caller has checked
2382 -- that current character is '[' and on return the cursor
2383 -- is skipped past the corresponding closing ']'.
2385 ----------------------------------
2386 -- Read_Instantiation_Reference --
2387 ----------------------------------
2389 procedure Read_Instantiation_Reference is
2390 Local_File_Num : Sdep_Id := Current_File_Num;
2392 begin
2393 Xref.Increment_Last;
2395 declare
2396 XR : Xref_Record renames Xref.Table (Xref.Last);
2398 begin
2399 P := P + 1; -- skip [
2400 N := Get_Nat;
2402 if Nextc = '|' then
2403 XR.File_Num :=
2404 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2405 Local_File_Num := XR.File_Num;
2406 P := P + 1;
2407 N := Get_Nat;
2409 else
2410 XR.File_Num := Local_File_Num;
2411 end if;
2413 XR.Line := N;
2414 XR.Rtype := ' ';
2415 XR.Col := 0;
2417 -- Recursive call for next reference
2419 if Nextc = '[' then
2420 pragma Warnings (Off); -- kill recursion warning
2421 Read_Instantiation_Reference;
2422 pragma Warnings (On);
2423 end if;
2425 -- Skip closing bracket after recursive call
2427 P := P + 1;
2428 end;
2429 end Read_Instantiation_Reference;
2431 -- Start of processing for Read_Refs_For_One_Entity
2433 begin
2434 XE.Line := Get_Nat;
2435 XE.Etype := Getc;
2436 XE.Col := Get_Nat;
2438 case Getc is
2439 when '*' =>
2440 XE.Visibility := Global;
2441 when '+' =>
2442 XE.Visibility := Static;
2443 when others =>
2444 XE.Visibility := Other;
2445 end case;
2447 XE.Entity := Get_Name;
2449 -- Handle the information about generic instantiations
2451 if Nextc = '[' then
2452 Skipc; -- Opening '['
2453 N := Get_Nat;
2455 if Nextc /= '|' then
2456 XE.Iref_File_Num := Current_File_Num;
2457 XE.Iref_Line := N;
2458 else
2459 XE.Iref_File_Num :=
2460 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2461 Skipc;
2462 XE.Iref_Line := Get_Nat;
2463 end if;
2465 if Getc /= ']' then
2466 Fatal_Error;
2467 end if;
2469 else
2470 XE.Iref_File_Num := No_Sdep_Id;
2471 XE.Iref_Line := 0;
2472 end if;
2474 Current_File_Num := XS.File_Num;
2476 -- Renaming reference is present
2478 if Nextc = '=' then
2479 P := P + 1;
2480 XE.Rref_Line := Get_Nat;
2482 if Getc /= ':' then
2483 Fatal_Error;
2484 end if;
2486 XE.Rref_Col := Get_Nat;
2488 -- No renaming reference present
2490 else
2491 XE.Rref_Line := 0;
2492 XE.Rref_Col := 0;
2493 end if;
2495 Skip_Space;
2497 XE.Oref_File_Num := No_Sdep_Id;
2498 XE.Tref_File_Num := No_Sdep_Id;
2499 XE.Tref := Tref_None;
2500 XE.First_Xref := Xref.Last + 1;
2502 -- Loop to check for additional info present
2504 loop
2505 declare
2506 Ref : Tref_Kind;
2507 File : Sdep_Id;
2508 Line : Nat;
2509 Typ : Character;
2510 Col : Nat;
2511 Std : Name_Id;
2513 begin
2514 Get_Typeref
2515 (Current_File_Num, Ref, File, Line, Typ, Col, Std);
2516 exit when Ref = Tref_None;
2518 -- Do we have an overriding procedure?
2520 if Ref = Tref_Derived and then Typ = 'p' then
2521 XE.Oref_File_Num := File;
2522 XE.Oref_Line := Line;
2523 XE.Oref_Col := Col;
2525 -- Arrays never override anything, and <> points to
2526 -- the index types instead
2528 elsif Ref = Tref_Derived and then XE.Etype = 'A' then
2530 -- Index types are stored in the list of references
2532 Xref.Increment_Last;
2534 declare
2535 XR : Xref_Record renames Xref.Table (Xref.Last);
2536 begin
2537 XR.File_Num := File;
2538 XR.Line := Line;
2539 XR.Rtype := Array_Index_Reference;
2540 XR.Col := Col;
2541 XR.Name := Std;
2542 end;
2544 -- Interfaces are stored in the list of references,
2545 -- although the parent type itself is stored in XE.
2546 -- The first interface (when there are only
2547 -- interfaces) is stored in XE.Tref*)
2549 elsif Ref = Tref_Derived
2550 and then Typ = 'R'
2551 and then XE.Tref_File_Num /= No_Sdep_Id
2552 then
2553 Xref.Increment_Last;
2555 declare
2556 XR : Xref_Record renames Xref.Table (Xref.Last);
2557 begin
2558 XR.File_Num := File;
2559 XR.Line := Line;
2560 XR.Rtype := Interface_Reference;
2561 XR.Col := Col;
2562 XR.Name := Std;
2563 end;
2565 else
2566 XE.Tref := Ref;
2567 XE.Tref_File_Num := File;
2568 XE.Tref_Line := Line;
2569 XE.Tref_Type := Typ;
2570 XE.Tref_Col := Col;
2571 XE.Tref_Standard_Entity := Std;
2572 end if;
2573 end;
2574 end loop;
2576 -- Loop through cross-references for this entity
2578 loop
2579 Skip_Space;
2581 if At_Eol then
2582 Skip_Eol;
2583 exit when Nextc /= '.';
2584 P := P + 1;
2585 end if;
2587 Xref.Increment_Last;
2589 declare
2590 XR : Xref_Record renames Xref.Table (Xref.Last);
2592 begin
2593 N := Get_Nat;
2595 if Nextc = '|' then
2596 XR.File_Num :=
2597 Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2598 Current_File_Num := XR.File_Num;
2599 P := P + 1;
2600 N := Get_Nat;
2601 else
2602 XR.File_Num := Current_File_Num;
2603 end if;
2605 XR.Line := N;
2606 XR.Rtype := Getc;
2608 -- Imported entities reference as in:
2609 -- 494b<c,__gnat_copy_attribs>25
2611 if Nextc = '<' then
2612 Skipc;
2613 XR.Imported_Lang := Get_Name;
2615 pragma Assert (Nextc = ',');
2616 Skipc;
2618 XR.Imported_Name := Get_Name;
2620 pragma Assert (Nextc = '>');
2621 Skipc;
2623 else
2624 XR.Imported_Lang := No_Name;
2625 XR.Imported_Name := No_Name;
2626 end if;
2628 XR.Col := Get_Nat;
2630 if Nextc = '[' then
2631 Read_Instantiation_Reference;
2632 end if;
2633 end;
2634 end loop;
2636 -- Record last cross-reference
2638 XE.Last_Xref := Xref.Last;
2639 C := Nextc;
2641 exception
2642 when Bad_ALI_Format =>
2644 -- If ignoring errors, then we skip a line with an
2645 -- unexpected error, and try to continue subsequent
2646 -- xref lines.
2648 if Ignore_Errors then
2649 Xref_Entity.Decrement_Last;
2650 Skip_Line;
2651 C := Nextc;
2653 -- Otherwise, we reraise the fatal exception
2655 else
2656 raise;
2657 end if;
2658 end Read_Refs_For_One_Entity;
2659 end loop;
2661 -- Record last entity
2663 XS.Last_Entity := Xref_Entity.Last;
2665 end Read_Refs_For_One_File;
2667 C := Getc;
2668 end loop X_Loop;
2670 -- Here after dealing with xref sections
2672 -- Ignore remaining lines, which belong to an additional section of the
2673 -- ALI file not considered here (like SCO or SPARK information).
2675 Check_Unknown_Line;
2677 return Id;
2679 exception
2680 when Bad_ALI_Format =>
2681 return No_ALI_Id;
2682 end Scan_ALI;
2684 ---------
2685 -- SEq --
2686 ---------
2688 function SEq (F1, F2 : String_Ptr) return Boolean is
2689 begin
2690 return F1.all = F2.all;
2691 end SEq;
2693 -----------
2694 -- SHash --
2695 -----------
2697 function SHash (S : String_Ptr) return Vindex is
2698 H : Word;
2700 begin
2701 H := 0;
2702 for J in S.all'Range loop
2703 H := H * 2 + Character'Pos (S (J));
2704 end loop;
2706 return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));
2707 end SHash;
2709 end ALI;