OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [ali.adb] - Blame information for rev 320

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                                  A L I                                   --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, 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
------------------------------------------------------------------------------
25
 
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;
32
 
33
package body ALI is
34
 
35
   use ASCII;
36
   --  Make control characters visible
37
 
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.
41
 
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
      'E'    => True,   -- external
53
      'D'    => True,   -- dependency
54
      'X'    => True,   -- xref
55
      'S'    => True,   -- specific dispatching
56
      'Y'    => True,   -- limited_with
57
      others => False);
58
 
59
   --------------------
60
   -- Initialize_ALI --
61
   --------------------
62
 
63
   procedure Initialize_ALI is
64
   begin
65
      --  When (re)initializing ALI data structures the ALI user expects to
66
      --  get a fresh set of data structures. Thus we first need to erase the
67
      --  marks put in the name table by the previous set of ALI routine calls.
68
      --  These two loops are empty and harmless the first time in.
69
 
70
      for J in ALIs.First .. ALIs.Last loop
71
         Set_Name_Table_Info (ALIs.Table (J).Afile, 0);
72
      end loop;
73
 
74
      for J in Units.First .. Units.Last loop
75
         Set_Name_Table_Info (Units.Table (J).Uname, 0);
76
      end loop;
77
 
78
      --  Free argument table strings
79
 
80
      for J in Args.First .. Args.Last loop
81
         Free (Args.Table (J));
82
      end loop;
83
 
84
      --  Initialize all tables
85
 
86
      ALIs.Init;
87
      No_Deps.Init;
88
      Units.Init;
89
      Withs.Init;
90
      Sdep.Init;
91
      Linker_Options.Init;
92
      Xref_Section.Init;
93
      Xref_Entity.Init;
94
      Xref.Init;
95
      Version_Ref.Reset;
96
 
97
      --  Add dummy zero'th item in Linker_Options for the sort function
98
 
99
      Linker_Options.Increment_Last;
100
 
101
      --  Initialize global variables recording cumulative options in all
102
      --  ALI files that are read for a given processing run in gnatbind.
103
 
104
      Dynamic_Elaboration_Checks_Specified := False;
105
      Float_Format_Specified               := ' ';
106
      Locking_Policy_Specified             := ' ';
107
      No_Normalize_Scalars_Specified       := False;
108
      No_Object_Specified                  := False;
109
      Normalize_Scalars_Specified          := False;
110
      Queuing_Policy_Specified             := ' ';
111
      Static_Elaboration_Model_Used        := False;
112
      Task_Dispatching_Policy_Specified    := ' ';
113
      Unreserve_All_Interrupts_Specified   := False;
114
      Zero_Cost_Exceptions_Specified       := False;
115
   end Initialize_ALI;
116
 
117
   --------------
118
   -- Scan_ALI --
119
   --------------
120
 
121
   function Scan_ALI
122
     (F             : File_Name_Type;
123
      T             : Text_Buffer_Ptr;
124
      Ignore_ED     : Boolean;
125
      Err           : Boolean;
126
      Read_Xref     : Boolean := False;
127
      Read_Lines    : String  := "";
128
      Ignore_Lines  : String  := "X";
129
      Ignore_Errors : Boolean := False) return ALI_Id
130
   is
131
      P         : Text_Ptr := T'First;
132
      Line      : Logical_Line_Number := 1;
133
      Id        : ALI_Id;
134
      C         : Character;
135
      NS_Found  : Boolean;
136
      First_Arg : Arg_Id;
137
 
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.
142
 
143
      Bad_ALI_Format : exception;
144
      --  Exception raised by Fatal_Error if Err is True
145
 
146
      function At_Eol return Boolean;
147
      --  Test if at end of line
148
 
149
      function At_End_Of_Field return Boolean;
150
      --  Test if at end of line, or if at blank or horizontal tab
151
 
152
      procedure Check_At_End_Of_Field;
153
      --  Check if we are at end of field, fatal error if not
154
 
155
      procedure Checkc (C : Character);
156
      --  Check next character is C. If so bump past it, if not fatal error
157
 
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).
169
 
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.
173
 
174
      procedure Fatal_Error_Ignore;
175
      pragma Inline (Fatal_Error_Ignore);
176
      --  In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error
177
 
178
      function Getc return Character;
179
      --  Get next character, bumping P past the character obtained
180
 
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.
190
 
191
      function Get_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:
201
      --
202
      --    If Ignore_Spaces is False (normal case), then scan is terminated
203
      --    by the normal end of field condition (EOL, space, horizontal tab)
204
      --
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.
209
      --
210
      --  It is an error to set both Ignore_Spaces and Ignore_Special to True.
211
      --  This function handles wide characters properly.
212
 
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.
216
 
217
      function Get_Stamp return Time_Stamp_Type;
218
      --  Skip blanks, then scan out a time stamp
219
 
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.
224
 
225
      function Nextc return Character;
226
      --  Return current character without modifying pointer P
227
 
228
      procedure Get_Typeref
229
        (Current_File_Num : Sdep_Id;
230
         Ref             : out Tref_Kind;
231
         File_Num        : out Sdep_Id;
232
         Line            : out Nat;
233
         Ref_Type        : out Character;
234
         Col             : out Nat;
235
         Standard_Entity : out Name_Id);
236
      --  Parse the definition of a typeref (<...>, {...} or (...))
237
 
238
      procedure Skip_Eol;
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.
241
 
242
      procedure Skip_Line;
243
      --  Skip rest of current line and any following blank lines
244
 
245
      procedure Skip_Space;
246
      --  Skip past white space (blanks or horizontal tab)
247
 
248
      procedure Skipc;
249
      --  Skip past next character, does not affect value in C. This call
250
      --  is like calling Getc and ignoring the returned result.
251
 
252
      ---------------------
253
      -- At_End_Of_Field --
254
      ---------------------
255
 
256
      function At_End_Of_Field return Boolean is
257
      begin
258
         return Nextc <= ' ';
259
      end At_End_Of_Field;
260
 
261
      ------------
262
      -- At_Eol --
263
      ------------
264
 
265
      function At_Eol return Boolean is
266
      begin
267
         return Nextc = EOF or else Nextc = CR or else Nextc = LF;
268
      end At_Eol;
269
 
270
      ---------------------------
271
      -- Check_At_End_Of_Field --
272
      ---------------------------
273
 
274
      procedure Check_At_End_Of_Field is
275
      begin
276
         if not At_End_Of_Field then
277
            if Ignore_Errors then
278
               while Nextc > ' ' loop
279
                  P := P + 1;
280
               end loop;
281
            else
282
               Fatal_Error;
283
            end if;
284
         end if;
285
      end Check_At_End_Of_Field;
286
 
287
      ------------------------
288
      -- Check_Unknown_Line --
289
      ------------------------
290
 
291
      procedure Check_Unknown_Line is
292
      begin
293
         while C not in 'A' .. 'Z'
294
           or else not Known_ALI_Lines (C)
295
         loop
296
            if C = CR or else C = LF then
297
               Skip_Line;
298
               C := Nextc;
299
 
300
            elsif C = EOF then
301
               return;
302
 
303
            elsif Ignore_Errors then
304
               Skip_Line;
305
               C := Getc;
306
 
307
            else
308
               Fatal_Error;
309
            end if;
310
         end loop;
311
      end Check_Unknown_Line;
312
 
313
      ------------
314
      -- Checkc --
315
      ------------
316
 
317
      procedure Checkc (C : Character) is
318
      begin
319
         if Nextc = C then
320
            P := P + 1;
321
         elsif Ignore_Errors then
322
            P := P + 1;
323
         else
324
            Fatal_Error;
325
         end if;
326
      end Checkc;
327
 
328
      -----------------
329
      -- Fatal_Error --
330
      -----------------
331
 
332
      procedure Fatal_Error is
333
         Ptr1 : Text_Ptr;
334
         Ptr2 : Text_Ptr;
335
         Col  : Int;
336
 
337
         procedure Wchar (C : Character);
338
         --  Write a single character, replacing horizontal tab by spaces
339
 
340
         procedure Wchar (C : Character) is
341
         begin
342
            if C = HT then
343
               loop
344
                  Wchar (' ');
345
                  exit when Col mod 8 = 0;
346
               end loop;
347
 
348
            else
349
               Write_Char (C);
350
               Col := Col + 1;
351
            end if;
352
         end Wchar;
353
 
354
      --  Start of processing for Fatal_Error
355
 
356
      begin
357
         if Err then
358
            raise Bad_ALI_Format;
359
         end if;
360
 
361
         Set_Standard_Error;
362
         Write_Str ("fatal error: file ");
363
         Write_Name (F);
364
         Write_Str (" is incorrectly formatted");
365
         Write_Eol;
366
 
367
         Write_Str ("make sure you are using consistent versions " &
368
 
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.
371
 
372
                    "of gcc/gnatbind");
373
 
374
         Write_Eol;
375
 
376
         --  Find start of line
377
 
378
         Ptr1 := P;
379
         while Ptr1 > T'First
380
           and then T (Ptr1 - 1) /= CR
381
           and then T (Ptr1 - 1) /= LF
382
         loop
383
            Ptr1 := Ptr1 - 1;
384
         end loop;
385
 
386
         Write_Int (Int (Line));
387
         Write_Str (". ");
388
 
389
         if Line < 100 then
390
            Write_Char (' ');
391
         end if;
392
 
393
         if Line < 10 then
394
            Write_Char (' ');
395
         end if;
396
 
397
         Col := 0;
398
         Ptr2 := Ptr1;
399
 
400
         while Ptr2 < T'Last
401
           and then T (Ptr2) /= CR
402
           and then T (Ptr2) /= LF
403
         loop
404
            Wchar (T (Ptr2));
405
            Ptr2 := Ptr2 + 1;
406
         end loop;
407
 
408
         Write_Eol;
409
 
410
         Write_Str ("     ");
411
         Col := 0;
412
 
413
         while Ptr1 < P loop
414
            if T (Ptr1) = HT then
415
               Wchar (HT);
416
            else
417
               Wchar (' ');
418
            end if;
419
 
420
            Ptr1 := Ptr1 + 1;
421
         end loop;
422
 
423
         Wchar ('|');
424
         Write_Eol;
425
 
426
         Exit_Program (E_Fatal);
427
      end Fatal_Error;
428
 
429
      ------------------------
430
      -- Fatal_Error_Ignore --
431
      ------------------------
432
 
433
      procedure Fatal_Error_Ignore is
434
      begin
435
         if not Ignore_Errors then
436
            Fatal_Error;
437
         end if;
438
      end Fatal_Error_Ignore;
439
 
440
      -------------------
441
      -- Get_File_Name --
442
      -------------------
443
 
444
      function Get_File_Name
445
        (Lower : Boolean := False) return File_Name_Type
446
      is
447
         F : Name_Id;
448
 
449
      begin
450
         F := Get_Name (Ignore_Special => True);
451
 
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.
455
 
456
         if Lower and not File_Names_Case_Sensitive then
457
            Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
458
            return Name_Find;
459
         else
460
            return File_Name_Type (F);
461
         end if;
462
      end Get_File_Name;
463
 
464
      --------------
465
      -- Get_Name --
466
      --------------
467
 
468
      function Get_Name
469
        (Ignore_Spaces  : Boolean := False;
470
         Ignore_Special : Boolean := False) return Name_Id
471
      is
472
      begin
473
         Name_Len := 0;
474
         Skip_Space;
475
 
476
         if At_Eol then
477
            if Ignore_Errors then
478
               return Error_Name;
479
            else
480
               Fatal_Error;
481
            end if;
482
         end if;
483
 
484
         loop
485
            Add_Char_To_Name_Buffer (Getc);
486
 
487
            exit when At_End_Of_Field and then not Ignore_Spaces;
488
 
489
            if not Ignore_Special then
490
               if Name_Buffer (1) = '"' then
491
                  exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';
492
 
493
               else
494
                  --  Terminate on parens or angle brackets or equal sign
495
 
496
                  exit when Nextc = '(' or else Nextc = ')'
497
                    or else Nextc = '{' or else Nextc = '}'
498
                    or else Nextc = '<' or else Nextc = '>'
499
                    or else Nextc = '=';
500
 
501
                  --  Terminate if left bracket not part of wide char sequence
502
                  --  Note that we only recognize brackets notation so far ???
503
 
504
                  exit when Nextc = '[' and then T (P + 1) /= '"';
505
 
506
                  --  Terminate if right bracket not part of wide char sequence
507
 
508
                  exit when Nextc = ']' and then T (P - 1) /= '"';
509
               end if;
510
            end if;
511
         end loop;
512
 
513
         return Name_Find;
514
      end Get_Name;
515
 
516
      -------------------
517
      -- Get_Unit_Name --
518
      -------------------
519
 
520
      function Get_Unit_Name return Unit_Name_Type is
521
      begin
522
         return Unit_Name_Type (Get_Name);
523
      end Get_Unit_Name;
524
 
525
      -------------
526
      -- Get_Nat --
527
      -------------
528
 
529
      function Get_Nat return Nat is
530
         V : Nat;
531
 
532
      begin
533
         Skip_Space;
534
 
535
         --  Check if we are on a number. In the case of bad ALI files, this
536
         --  may not be true.
537
 
538
         if not (Nextc in '0' .. '9') then
539
            Fatal_Error;
540
         end if;
541
 
542
         V := 0;
543
         loop
544
            V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0'));
545
 
546
            exit when At_End_Of_Field;
547
            exit when Nextc < '0' or else Nextc > '9';
548
         end loop;
549
 
550
         return V;
551
      end Get_Nat;
552
 
553
      ---------------
554
      -- Get_Stamp --
555
      ---------------
556
 
557
      function Get_Stamp return Time_Stamp_Type is
558
         T     : Time_Stamp_Type;
559
         Start : Integer;
560
 
561
      begin
562
         Skip_Space;
563
 
564
         if At_Eol then
565
            if Ignore_Errors then
566
               return Dummy_Time_Stamp;
567
            else
568
               Fatal_Error;
569
            end if;
570
         end if;
571
 
572
         --  Following reads old style time stamp missing first two digits
573
 
574
         if Nextc in '7' .. '9' then
575
            T (1) := '1';
576
            T (2) := '9';
577
            Start := 3;
578
 
579
         --  Normal case of full year in time stamp
580
 
581
         else
582
            Start := 1;
583
         end if;
584
 
585
         for J in Start .. T'Last loop
586
            T (J) := Getc;
587
         end loop;
588
 
589
         return T;
590
      end Get_Stamp;
591
 
592
      -----------------
593
      -- Get_Typeref --
594
      -----------------
595
 
596
      procedure Get_Typeref
597
        (Current_File_Num : Sdep_Id;
598
         Ref              : out Tref_Kind;
599
         File_Num         : out Sdep_Id;
600
         Line             : out Nat;
601
         Ref_Type         : out Character;
602
         Col              : out Nat;
603
         Standard_Entity  : out Name_Id)
604
      is
605
         N : Nat;
606
      begin
607
         case Nextc is
608
            when '<'    => Ref := Tref_Derived;
609
            when '('    => Ref := Tref_Access;
610
            when '{'    => Ref := Tref_Type;
611
            when others => Ref := Tref_None;
612
         end case;
613
 
614
         --  Case of typeref field present
615
 
616
         if Ref /= Tref_None then
617
            P := P + 1; -- skip opening bracket
618
 
619
            if Nextc in 'a' .. 'z' then
620
               File_Num        := No_Sdep_Id;
621
               Line            := 0;
622
               Ref_Type        := ' ';
623
               Col             := 0;
624
               Standard_Entity := Get_Name (Ignore_Spaces => True);
625
            else
626
               N := Get_Nat;
627
 
628
               if Nextc = '|' then
629
                  File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
630
                  P := P + 1;
631
                  N := Get_Nat;
632
               else
633
                  File_Num := Current_File_Num;
634
               end if;
635
 
636
               Line            := N;
637
               Ref_Type        := Getc;
638
               Col             := Get_Nat;
639
               Standard_Entity := No_Name;
640
            end if;
641
 
642
            --  ??? Temporary workaround for nested generics case:
643
            --     4i4 Directories{1|4I9[4|6[3|3]]}
644
            --  See C918-002
645
 
646
            declare
647
               Nested_Brackets : Natural := 0;
648
 
649
            begin
650
               loop
651
                  case Nextc is
652
                     when '['   =>
653
                        Nested_Brackets := Nested_Brackets + 1;
654
                     when ']' =>
655
                        Nested_Brackets := Nested_Brackets - 1;
656
                     when others =>
657
                        if Nested_Brackets = 0 then
658
                           exit;
659
                        end if;
660
                  end case;
661
 
662
                  Skipc;
663
               end loop;
664
            end;
665
 
666
            P := P + 1; -- skip closing bracket
667
            Skip_Space;
668
 
669
         --  No typeref entry present
670
 
671
         else
672
            File_Num        := No_Sdep_Id;
673
            Line            := 0;
674
            Ref_Type        := ' ';
675
            Col             := 0;
676
            Standard_Entity := No_Name;
677
         end if;
678
      end Get_Typeref;
679
 
680
      ----------
681
      -- Getc --
682
      ----------
683
 
684
      function Getc return Character is
685
      begin
686
         if P = T'Last then
687
            return EOF;
688
         else
689
            P := P + 1;
690
            return T (P - 1);
691
         end if;
692
      end Getc;
693
 
694
      -----------
695
      -- Nextc --
696
      -----------
697
 
698
      function Nextc return Character is
699
      begin
700
         return T (P);
701
      end Nextc;
702
 
703
      --------------
704
      -- Skip_Eol --
705
      --------------
706
 
707
      procedure Skip_Eol is
708
      begin
709
         Skip_Space;
710
 
711
         if not At_Eol then
712
            if Ignore_Errors then
713
               while not At_Eol loop
714
                  P := P + 1;
715
               end loop;
716
            else
717
               Fatal_Error;
718
            end if;
719
         end if;
720
 
721
         --  Loop to skip past blank lines (first time through skips this EOL)
722
 
723
         while Nextc < ' ' and then Nextc /= EOF loop
724
            if Nextc = LF then
725
               Line := Line + 1;
726
            end if;
727
 
728
            P := P + 1;
729
         end loop;
730
      end Skip_Eol;
731
 
732
      ---------------
733
      -- Skip_Line --
734
      ---------------
735
 
736
      procedure Skip_Line is
737
      begin
738
         while not At_Eol loop
739
            P := P + 1;
740
         end loop;
741
 
742
         Skip_Eol;
743
      end Skip_Line;
744
 
745
      ----------------
746
      -- Skip_Space --
747
      ----------------
748
 
749
      procedure Skip_Space is
750
      begin
751
         while Nextc = ' ' or else Nextc = HT loop
752
            P := P + 1;
753
         end loop;
754
      end Skip_Space;
755
 
756
      -----------
757
      -- Skipc --
758
      -----------
759
 
760
      procedure Skipc is
761
      begin
762
         if P /= T'Last then
763
            P := P + 1;
764
         end if;
765
      end Skipc;
766
 
767
   --  Start of processing for Scan_ALI
768
 
769
   begin
770
      First_Sdep_Entry := Sdep.Last + 1;
771
 
772
      --  Acquire lines to be ignored
773
 
774
      if Read_Xref then
775
         Ignore := ('U' | 'W' | 'Y' | 'D' | 'X' => False, others => True);
776
 
777
      --  Read_Lines parameter given
778
 
779
      elsif Read_Lines /= "" then
780
         Ignore := ('U' => False, others => True);
781
 
782
         for J in Read_Lines'Range loop
783
            Ignore (Read_Lines (J)) := False;
784
         end loop;
785
 
786
      --  Process Ignore_Lines parameter
787
 
788
      else
789
         Ignore := (others => False);
790
 
791
         for J in Ignore_Lines'Range loop
792
            pragma Assert (Ignore_Lines (J) /= 'U');
793
            Ignore (Ignore_Lines (J)) := True;
794
         end loop;
795
      end if;
796
 
797
      --  Setup ALI Table entry with appropriate defaults
798
 
799
      ALIs.Increment_Last;
800
      Id := ALIs.Last;
801
      Set_Name_Table_Info (F, Int (Id));
802
 
803
      ALIs.Table (Id) := (
804
        Afile                      => F,
805
        Compile_Errors             => False,
806
        First_Interrupt_State      => Interrupt_States.Last + 1,
807
        First_Sdep                 => No_Sdep_Id,
808
        First_Specific_Dispatching => Specific_Dispatching.Last + 1,
809
        First_Unit                 => No_Unit_Id,
810
        Float_Format               => 'I',
811
        Last_Interrupt_State       => Interrupt_States.Last,
812
        Last_Sdep                  => No_Sdep_Id,
813
        Last_Specific_Dispatching  => Specific_Dispatching.Last,
814
        Last_Unit                  => No_Unit_Id,
815
        Locking_Policy             => ' ',
816
        Main_Priority              => -1,
817
        Main_Program               => None,
818
        No_Object                  => False,
819
        Normalize_Scalars          => False,
820
        Ofile_Full_Name            => Full_Object_File_Name,
821
        Queuing_Policy             => ' ',
822
        Restrictions               => No_Restrictions,
823
        SAL_Interface              => False,
824
        Sfile                      => No_File,
825
        Task_Dispatching_Policy    => ' ',
826
        Time_Slice_Value           => -1,
827
        WC_Encoding                => 'b',
828
        Unit_Exception_Table       => False,
829
        Ver                        => (others => ' '),
830
        Ver_Len                    => 0,
831
        Zero_Cost_Exceptions       => False);
832
 
833
      --  Now we acquire the input lines from the ALI file. Note that the
834
      --  convention in the following code is that as we enter each section,
835
      --  C is set to contain the first character of the following line.
836
 
837
      C := Getc;
838
      Check_Unknown_Line;
839
 
840
      --  Acquire library version
841
 
842
      if C /= 'V' then
843
 
844
         --  The V line missing really indicates trouble, most likely it
845
         --  means we don't have an ALI file at all, so here we give a
846
         --  fatal error even if we are in Ignore_Errors mode.
847
 
848
         Fatal_Error;
849
 
850
      elsif Ignore ('V') then
851
         Skip_Line;
852
 
853
      else
854
         Checkc (' ');
855
         Skip_Space;
856
         Checkc ('"');
857
 
858
         for J in 1 .. Ver_Len_Max loop
859
            C := Getc;
860
            exit when C = '"';
861
            ALIs.Table (Id).Ver (J) := C;
862
            ALIs.Table (Id).Ver_Len := J;
863
         end loop;
864
 
865
         Skip_Eol;
866
      end if;
867
 
868
      C := Getc;
869
      Check_Unknown_Line;
870
 
871
      --  Acquire main program line if present
872
 
873
      if C = 'M' then
874
         if Ignore ('M') then
875
            Skip_Line;
876
 
877
         else
878
            Checkc (' ');
879
            Skip_Space;
880
 
881
            C := Getc;
882
 
883
            if C = 'F' then
884
               ALIs.Table (Id).Main_Program := Func;
885
            elsif C = 'P' then
886
               ALIs.Table (Id).Main_Program := Proc;
887
            else
888
               P := P - 1;
889
               Fatal_Error;
890
            end if;
891
 
892
            Skip_Space;
893
 
894
            if not At_Eol then
895
               if Nextc < 'A' then
896
                  ALIs.Table (Id).Main_Priority := Get_Nat;
897
               end if;
898
 
899
               Skip_Space;
900
 
901
               if Nextc = 'T' then
902
                  P := P + 1;
903
                  Checkc ('=');
904
                  ALIs.Table (Id).Time_Slice_Value := Get_Nat;
905
               end if;
906
 
907
               Skip_Space;
908
 
909
               Checkc ('W');
910
               Checkc ('=');
911
               ALIs.Table (Id).WC_Encoding := Getc;
912
            end if;
913
 
914
            Skip_Eol;
915
         end if;
916
 
917
         C := Getc;
918
      end if;
919
 
920
      --  Acquire argument lines
921
 
922
      First_Arg := Args.Last + 1;
923
 
924
      A_Loop : loop
925
         Check_Unknown_Line;
926
         exit A_Loop when C /= 'A';
927
 
928
         if Ignore ('A') then
929
            Skip_Line;
930
 
931
         else
932
            Checkc (' ');
933
 
934
            --  Scan out argument
935
 
936
            Name_Len := 0;
937
            while not At_Eol loop
938
               Add_Char_To_Name_Buffer (Getc);
939
            end loop;
940
 
941
            --  If -fstack-check, record that it occurred
942
 
943
            if Name_Buffer (1 .. Name_Len) = "-fstack-check" then
944
               Stack_Check_Switch_Set := True;
945
            end if;
946
 
947
            --  Store the argument
948
 
949
            Args.Increment_Last;
950
            Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len));
951
 
952
            Skip_Eol;
953
         end if;
954
 
955
         C := Getc;
956
      end loop A_Loop;
957
 
958
      --  Acquire P line
959
 
960
      Check_Unknown_Line;
961
 
962
      while C /= 'P' loop
963
         if Ignore_Errors then
964
            if C = EOF then
965
               Fatal_Error;
966
            else
967
               Skip_Line;
968
               C := Nextc;
969
            end if;
970
         else
971
            Fatal_Error;
972
         end if;
973
      end loop;
974
 
975
      if Ignore ('P') then
976
         Skip_Line;
977
 
978
      --  Process P line
979
 
980
      else
981
         NS_Found := False;
982
 
983
         while not At_Eol loop
984
            Checkc (' ');
985
            Skip_Space;
986
            C := Getc;
987
 
988
            --  Processing for CE
989
 
990
            if C = 'C' then
991
               Checkc ('E');
992
               ALIs.Table (Id).Compile_Errors := True;
993
 
994
            --  Processing for DB
995
 
996
            elsif C = 'D' then
997
               Checkc ('B');
998
               Detect_Blocking := True;
999
 
1000
            --  Processing for FD/FG/FI
1001
 
1002
            elsif C = 'F' then
1003
               Float_Format_Specified := Getc;
1004
               ALIs.Table (Id).Float_Format := Float_Format_Specified;
1005
 
1006
            --  Processing for Lx
1007
 
1008
            elsif C = 'L' then
1009
               Locking_Policy_Specified := Getc;
1010
               ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
1011
 
1012
            --  Processing for flags starting with N
1013
 
1014
            elsif C = 'N' then
1015
               C := Getc;
1016
 
1017
               --  Processing for NO
1018
 
1019
               if C = 'O' then
1020
                  ALIs.Table (Id).No_Object := True;
1021
                  No_Object_Specified := True;
1022
 
1023
               --  Processing for NR
1024
 
1025
               elsif C = 'R' then
1026
                  No_Run_Time_Mode           := True;
1027
                  Configurable_Run_Time_Mode := True;
1028
 
1029
               --  Processing for NS
1030
 
1031
               elsif C = 'S' then
1032
                  ALIs.Table (Id).Normalize_Scalars := True;
1033
                  Normalize_Scalars_Specified := True;
1034
                  NS_Found := True;
1035
 
1036
               --  Invalid switch starting with N
1037
 
1038
               else
1039
                  Fatal_Error_Ignore;
1040
               end if;
1041
 
1042
            --  Processing for Qx
1043
 
1044
            elsif C = 'Q' then
1045
               Queuing_Policy_Specified := Getc;
1046
               ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
1047
 
1048
            --  Processing for flags starting with S
1049
 
1050
            elsif C = 'S' then
1051
               C := Getc;
1052
 
1053
               --  Processing for SL
1054
 
1055
               if C = 'L' then
1056
                  ALIs.Table (Id).SAL_Interface := True;
1057
 
1058
               --  Processing for SS
1059
 
1060
               elsif C = 'S' then
1061
                  Opt.Sec_Stack_Used := True;
1062
 
1063
               --  Invalid switch starting with S
1064
 
1065
               else
1066
                  Fatal_Error_Ignore;
1067
               end if;
1068
 
1069
            --  Processing for Tx
1070
 
1071
            elsif C = 'T' then
1072
               Task_Dispatching_Policy_Specified := Getc;
1073
               ALIs.Table (Id).Task_Dispatching_Policy :=
1074
                 Task_Dispatching_Policy_Specified;
1075
 
1076
            --  Processing for switch starting with U
1077
 
1078
            elsif C = 'U' then
1079
               C := Getc;
1080
 
1081
               --  Processing for UA
1082
 
1083
               if C  = 'A' then
1084
                  Unreserve_All_Interrupts_Specified := True;
1085
 
1086
               --  Processing for UX
1087
 
1088
               elsif C = 'X' then
1089
                  ALIs.Table (Id).Unit_Exception_Table := True;
1090
 
1091
               --  Invalid switches starting with U
1092
 
1093
               else
1094
                  Fatal_Error_Ignore;
1095
               end if;
1096
 
1097
            --  Processing for ZX
1098
 
1099
            elsif C = 'Z' then
1100
               C := Getc;
1101
 
1102
               if C = 'X' then
1103
                  ALIs.Table (Id).Zero_Cost_Exceptions := True;
1104
                  Zero_Cost_Exceptions_Specified := True;
1105
               else
1106
                  Fatal_Error_Ignore;
1107
               end if;
1108
 
1109
            --  Invalid parameter
1110
 
1111
            else
1112
               C := Getc;
1113
               Fatal_Error_Ignore;
1114
            end if;
1115
         end loop;
1116
 
1117
         if not NS_Found then
1118
            No_Normalize_Scalars_Specified := True;
1119
         end if;
1120
 
1121
         Skip_Eol;
1122
      end if;
1123
 
1124
      C := Getc;
1125
      Check_Unknown_Line;
1126
 
1127
      --  Acquire first restrictions line
1128
 
1129
      while C /= 'R' loop
1130
         if Ignore_Errors then
1131
            if C = EOF then
1132
               Fatal_Error;
1133
            else
1134
               Skip_Line;
1135
               C := Nextc;
1136
            end if;
1137
         else
1138
            Fatal_Error;
1139
         end if;
1140
      end loop;
1141
 
1142
      if Ignore ('R') then
1143
         Skip_Line;
1144
 
1145
      --  Process restrictions line
1146
 
1147
      else
1148
         Scan_Restrictions : declare
1149
            Save_R : constant Restrictions_Info := Cumulative_Restrictions;
1150
            --  Save cumulative restrictions in case we have a fatal error
1151
 
1152
            Bad_R_Line : exception;
1153
            --  Signal bad restrictions line (raised on unexpected character)
1154
 
1155
         begin
1156
            Checkc (' ');
1157
            Skip_Space;
1158
 
1159
            --  Acquire information for boolean restrictions
1160
 
1161
            for R in All_Boolean_Restrictions loop
1162
               C := Getc;
1163
 
1164
               case C is
1165
                  when 'v' =>
1166
                     ALIs.Table (Id).Restrictions.Violated (R) := True;
1167
                     Cumulative_Restrictions.Violated (R) := True;
1168
 
1169
                  when 'r' =>
1170
                     ALIs.Table (Id).Restrictions.Set (R) := True;
1171
                     Cumulative_Restrictions.Set (R) := True;
1172
 
1173
                  when 'n' =>
1174
                     null;
1175
 
1176
                  when others =>
1177
                     raise Bad_R_Line;
1178
               end case;
1179
            end loop;
1180
 
1181
            --  Acquire information for parameter restrictions
1182
 
1183
            for RP in All_Parameter_Restrictions loop
1184
 
1185
               --  Acquire restrictions pragma information
1186
 
1187
               case Getc is
1188
                  when 'n' =>
1189
                     null;
1190
 
1191
                  when 'r' =>
1192
                     ALIs.Table (Id).Restrictions.Set (RP) := True;
1193
 
1194
                     declare
1195
                        N : constant Integer := Integer (Get_Nat);
1196
                     begin
1197
                        ALIs.Table (Id).Restrictions.Value (RP) := N;
1198
 
1199
                        if Cumulative_Restrictions.Set (RP) then
1200
                           Cumulative_Restrictions.Value (RP) :=
1201
                             Integer'Min
1202
                               (Cumulative_Restrictions.Value (RP), N);
1203
                        else
1204
                           Cumulative_Restrictions.Set (RP) := True;
1205
                           Cumulative_Restrictions.Value (RP) := N;
1206
                        end if;
1207
                     end;
1208
 
1209
                  when others =>
1210
                     raise Bad_R_Line;
1211
               end case;
1212
 
1213
               --  Acquire restrictions violations information
1214
 
1215
               case Getc is
1216
                  when 'n' =>
1217
                     null;
1218
 
1219
                  when 'v' =>
1220
                     ALIs.Table (Id).Restrictions.Violated (RP) := True;
1221
                     Cumulative_Restrictions.Violated (RP) := True;
1222
 
1223
                     declare
1224
                        N : constant Integer := Integer (Get_Nat);
1225
                        pragma Unsuppress (Overflow_Check);
1226
 
1227
                     begin
1228
                        ALIs.Table (Id).Restrictions.Count (RP) := N;
1229
 
1230
                        if RP in Checked_Max_Parameter_Restrictions then
1231
                           Cumulative_Restrictions.Count (RP) :=
1232
                             Integer'Max
1233
                               (Cumulative_Restrictions.Count (RP), N);
1234
                        else
1235
                           Cumulative_Restrictions.Count (RP) :=
1236
                             Cumulative_Restrictions.Count (RP) + N;
1237
                        end if;
1238
 
1239
                     exception
1240
                        when Constraint_Error =>
1241
 
1242
                           --  A constraint error comes from the addition in
1243
                           --  the else branch. We reset to the maximum and
1244
                           --  indicate that the real value is now unknown.
1245
 
1246
                           Cumulative_Restrictions.Value (RP) := Integer'Last;
1247
                           Cumulative_Restrictions.Unknown (RP) := True;
1248
                     end;
1249
 
1250
                     if Nextc = '+' then
1251
                        Skipc;
1252
                        ALIs.Table (Id).Restrictions.Unknown (RP) := True;
1253
                        Cumulative_Restrictions.Unknown (RP) := True;
1254
                     end if;
1255
 
1256
                  when others =>
1257
                     raise Bad_R_Line;
1258
               end case;
1259
            end loop;
1260
 
1261
            Skip_Eol;
1262
 
1263
         --  Here if error during scanning of restrictions line
1264
 
1265
         exception
1266
            when Bad_R_Line =>
1267
 
1268
               --  In Ignore_Errors mode, undo any changes to restrictions
1269
               --  from this unit, and continue on.
1270
 
1271
               if Ignore_Errors then
1272
                  Cumulative_Restrictions := Save_R;
1273
                  ALIs.Table (Id).Restrictions := No_Restrictions;
1274
                  Skip_Eol;
1275
 
1276
               --  In normal mode, this is a fatal error
1277
 
1278
               else
1279
                  Fatal_Error;
1280
               end if;
1281
 
1282
         end Scan_Restrictions;
1283
      end if;
1284
 
1285
      --  Acquire additional restrictions (No_Dependence) lines if present
1286
 
1287
      C := Getc;
1288
      while C = 'R' loop
1289
         if Ignore ('R') then
1290
            Skip_Line;
1291
         else
1292
            Skip_Space;
1293
            No_Deps.Append ((Id, Get_Name));
1294
         end if;
1295
 
1296
         Skip_Eol;
1297
         C := Getc;
1298
      end loop;
1299
 
1300
      --  Acquire 'I' lines if present
1301
 
1302
      Check_Unknown_Line;
1303
 
1304
      while C = 'I' loop
1305
         if Ignore ('I') then
1306
            Skip_Line;
1307
 
1308
         else
1309
            declare
1310
               Int_Num : Nat;
1311
               I_State : Character;
1312
               Line_No : Nat;
1313
 
1314
            begin
1315
               Int_Num := Get_Nat;
1316
               Skip_Space;
1317
               I_State := Getc;
1318
               Line_No := Get_Nat;
1319
 
1320
               Interrupt_States.Append (
1321
                 (Interrupt_Id    => Int_Num,
1322
                  Interrupt_State => I_State,
1323
                  IS_Pragma_Line  => Line_No));
1324
 
1325
               ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last;
1326
               Skip_Eol;
1327
            end;
1328
         end if;
1329
 
1330
         C := Getc;
1331
      end loop;
1332
 
1333
      --  Acquire 'S' lines if present
1334
 
1335
      Check_Unknown_Line;
1336
 
1337
      while C = 'S' loop
1338
         if Ignore ('S') then
1339
            Skip_Line;
1340
 
1341
         else
1342
            declare
1343
               Policy     : Character;
1344
               First_Prio : Nat;
1345
               Last_Prio  : Nat;
1346
               Line_No    : Nat;
1347
 
1348
            begin
1349
               Checkc (' ');
1350
               Skip_Space;
1351
 
1352
               Policy := Getc;
1353
               Skip_Space;
1354
               First_Prio := Get_Nat;
1355
               Last_Prio := Get_Nat;
1356
               Line_No := Get_Nat;
1357
 
1358
               Specific_Dispatching.Append (
1359
                 (Dispatching_Policy => Policy,
1360
                  First_Priority     => First_Prio,
1361
                  Last_Priority      => Last_Prio,
1362
                  PSD_Pragma_Line    => Line_No));
1363
 
1364
               ALIs.Table (Id).Last_Specific_Dispatching :=
1365
                 Specific_Dispatching.Last;
1366
 
1367
               Skip_Eol;
1368
            end;
1369
         end if;
1370
 
1371
         C := Getc;
1372
      end loop;
1373
 
1374
      --  Loop to acquire unit entries
1375
 
1376
      U_Loop : loop
1377
         Check_Unknown_Line;
1378
         exit U_Loop when C /= 'U';
1379
 
1380
         --  Note: as per spec, we never ignore U lines
1381
 
1382
         Checkc (' ');
1383
         Skip_Space;
1384
         Units.Increment_Last;
1385
 
1386
         if ALIs.Table (Id).First_Unit = No_Unit_Id then
1387
            ALIs.Table (Id).First_Unit := Units.Last;
1388
         end if;
1389
 
1390
         declare
1391
            UL : Unit_Record renames Units.Table (Units.Last);
1392
 
1393
         begin
1394
            UL.Uname                    := Get_Unit_Name;
1395
            UL.Predefined               := Is_Predefined_Unit;
1396
            UL.Internal                 := Is_Internal_Unit;
1397
            UL.My_ALI                   := Id;
1398
            UL.Sfile                    := Get_File_Name (Lower => True);
1399
            UL.Pure                     := False;
1400
            UL.Preelab                  := False;
1401
            UL.No_Elab                  := False;
1402
            UL.Shared_Passive           := False;
1403
            UL.RCI                      := False;
1404
            UL.Remote_Types             := False;
1405
            UL.Has_RACW                 := False;
1406
            UL.Init_Scalars             := False;
1407
            UL.Is_Generic               := False;
1408
            UL.Icasing                  := Mixed_Case;
1409
            UL.Kcasing                  := All_Lower_Case;
1410
            UL.Dynamic_Elab             := False;
1411
            UL.Elaborate_Body           := False;
1412
            UL.Set_Elab_Entity          := False;
1413
            UL.Version                  := "00000000";
1414
            UL.First_With               := Withs.Last + 1;
1415
            UL.First_Arg                := First_Arg;
1416
            UL.Elab_Position            := 0;
1417
            UL.SAL_Interface            := ALIs.Table (Id).SAL_Interface;
1418
            UL.Body_Needed_For_SAL      := False;
1419
            UL.Elaborate_Body_Desirable := False;
1420
            UL.Optimize_Alignment       := 'O';
1421
 
1422
            if Debug_Flag_U then
1423
               Write_Str (" ----> reading unit ");
1424
               Write_Int (Int (Units.Last));
1425
               Write_Str ("  ");
1426
               Write_Unit_Name (UL.Uname);
1427
               Write_Str (" from file ");
1428
               Write_Name (UL.Sfile);
1429
               Write_Eol;
1430
            end if;
1431
         end;
1432
 
1433
         --  Check for duplicated unit in different files
1434
 
1435
         declare
1436
            Info : constant Int := Get_Name_Table_Info
1437
                                     (Units.Table (Units.Last).Uname);
1438
         begin
1439
            if Info /= 0
1440
              and then Units.Table (Units.Last).Sfile /=
1441
                       Units.Table (Unit_Id (Info)).Sfile
1442
            then
1443
               --  If Err is set then ignore duplicate unit name. This is the
1444
               --  case of a call from gnatmake, where the situation can arise
1445
               --  from substitution of source files. In such situations, the
1446
               --  processing in gnatmake will always result in any required
1447
               --  recompilations in any case, and if we consider this to be
1448
               --  an error we get strange cases (for example when a generic
1449
               --  instantiation is replaced by a normal package) where we
1450
               --  read the old ali file, decide to recompile, and then decide
1451
               --  that the old and new ali files are incompatible.
1452
 
1453
               if Err then
1454
                  null;
1455
 
1456
               --  If Err is not set, then this is a fatal error. This is
1457
               --  the case of being called from the binder, where we must
1458
               --  definitely diagnose this as an error.
1459
 
1460
               else
1461
                  Set_Standard_Error;
1462
                  Write_Str ("error: duplicate unit name: ");
1463
                  Write_Eol;
1464
 
1465
                  Write_Str ("error: unit """);
1466
                  Write_Unit_Name (Units.Table (Units.Last).Uname);
1467
                  Write_Str (""" found in file """);
1468
                  Write_Name_Decoded (Units.Table (Units.Last).Sfile);
1469
                  Write_Char ('"');
1470
                  Write_Eol;
1471
 
1472
                  Write_Str ("error: unit """);
1473
                  Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
1474
                  Write_Str (""" found in file """);
1475
                  Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
1476
                  Write_Char ('"');
1477
                  Write_Eol;
1478
 
1479
                  Exit_Program (E_Fatal);
1480
               end if;
1481
            end if;
1482
         end;
1483
 
1484
         Set_Name_Table_Info
1485
           (Units.Table (Units.Last).Uname, Int (Units.Last));
1486
 
1487
         --  Scan out possible version and other parameters
1488
 
1489
         loop
1490
            Skip_Space;
1491
            exit when At_Eol;
1492
            C := Getc;
1493
 
1494
            --  Version field
1495
 
1496
            if C in '0' .. '9' or else C in 'a' .. 'f' then
1497
               Units.Table (Units.Last).Version (1) := C;
1498
 
1499
               for J in 2 .. 8 loop
1500
                  C := Getc;
1501
                  Units.Table (Units.Last).Version (J) := C;
1502
               end loop;
1503
 
1504
            --  BD/BN parameters
1505
 
1506
            elsif C = 'B' then
1507
               C := Getc;
1508
 
1509
               if C = 'D' then
1510
                  Check_At_End_Of_Field;
1511
                  Units.Table (Units.Last).Elaborate_Body_Desirable := True;
1512
 
1513
               elsif C = 'N' then
1514
                  Check_At_End_Of_Field;
1515
                  Units.Table (Units.Last).Body_Needed_For_SAL := True;
1516
 
1517
               else
1518
                  Fatal_Error_Ignore;
1519
               end if;
1520
 
1521
            --  DE parameter (Dynamic elaboration checks)
1522
 
1523
            elsif C = 'D' then
1524
               C := Getc;
1525
 
1526
               if C = 'E' then
1527
                  Check_At_End_Of_Field;
1528
                  Units.Table (Units.Last).Dynamic_Elab := True;
1529
                  Dynamic_Elaboration_Checks_Specified := True;
1530
               else
1531
                  Fatal_Error_Ignore;
1532
               end if;
1533
 
1534
            --  EB/EE parameters
1535
 
1536
            elsif C = 'E' then
1537
               C := Getc;
1538
 
1539
               if C = 'B' then
1540
                  Units.Table (Units.Last).Elaborate_Body := True;
1541
               elsif C = 'E' then
1542
                  Units.Table (Units.Last).Set_Elab_Entity := True;
1543
               else
1544
                  Fatal_Error_Ignore;
1545
               end if;
1546
 
1547
               Check_At_End_Of_Field;
1548
 
1549
            --  GE parameter (generic)
1550
 
1551
            elsif C = 'G' then
1552
               C := Getc;
1553
 
1554
               if C = 'E' then
1555
                  Check_At_End_Of_Field;
1556
                  Units.Table (Units.Last).Is_Generic := True;
1557
               else
1558
                  Fatal_Error_Ignore;
1559
               end if;
1560
 
1561
            --  IL/IS/IU parameters
1562
 
1563
            elsif C = 'I' then
1564
               C := Getc;
1565
 
1566
               if C = 'L' then
1567
                  Units.Table (Units.Last).Icasing := All_Lower_Case;
1568
               elsif C = 'S' then
1569
                  Units.Table (Units.Last).Init_Scalars := True;
1570
                  Initialize_Scalars_Used := True;
1571
               elsif C = 'U' then
1572
                  Units.Table (Units.Last).Icasing := All_Upper_Case;
1573
               else
1574
                  Fatal_Error_Ignore;
1575
               end if;
1576
 
1577
               Check_At_End_Of_Field;
1578
 
1579
            --  KM/KU parameters
1580
 
1581
            elsif C = 'K' then
1582
               C := Getc;
1583
 
1584
               if C = 'M' then
1585
                  Units.Table (Units.Last).Kcasing := Mixed_Case;
1586
               elsif C = 'U' then
1587
                  Units.Table (Units.Last).Kcasing := All_Upper_Case;
1588
               else
1589
                  Fatal_Error_Ignore;
1590
               end if;
1591
 
1592
               Check_At_End_Of_Field;
1593
 
1594
            --  NE parameter
1595
 
1596
            elsif C = 'N' then
1597
               C := Getc;
1598
 
1599
               if C = 'E' then
1600
                  Units.Table (Units.Last).No_Elab := True;
1601
                  Check_At_End_Of_Field;
1602
               else
1603
                  Fatal_Error_Ignore;
1604
               end if;
1605
 
1606
            --  PR/PU/PK parameters
1607
 
1608
            elsif C = 'P' then
1609
               C := Getc;
1610
 
1611
               if C = 'R' then
1612
                  Units.Table (Units.Last).Preelab := True;
1613
               elsif C = 'U' then
1614
                  Units.Table (Units.Last).Pure := True;
1615
               elsif C = 'K' then
1616
                  Units.Table (Units.Last).Unit_Kind := 'p';
1617
               else
1618
                  Fatal_Error_Ignore;
1619
               end if;
1620
 
1621
               Check_At_End_Of_Field;
1622
 
1623
            --  OL/OO/OS/OT parameters
1624
 
1625
            elsif C = 'O' then
1626
               C := Getc;
1627
 
1628
               if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then
1629
                  Units.Table (Units.Last).Optimize_Alignment := C;
1630
               else
1631
                  Fatal_Error_Ignore;
1632
               end if;
1633
 
1634
               Check_At_End_Of_Field;
1635
 
1636
            --  RC/RT parameters
1637
 
1638
            elsif C = 'R' then
1639
               C := Getc;
1640
 
1641
               if C = 'C' then
1642
                  Units.Table (Units.Last).RCI := True;
1643
               elsif C = 'T' then
1644
                  Units.Table (Units.Last).Remote_Types := True;
1645
               elsif C = 'A' then
1646
                  Units.Table (Units.Last).Has_RACW := True;
1647
               else
1648
                  Fatal_Error_Ignore;
1649
               end if;
1650
 
1651
               Check_At_End_Of_Field;
1652
 
1653
            elsif C = 'S' then
1654
               C := Getc;
1655
 
1656
               if C = 'P' then
1657
                  Units.Table (Units.Last).Shared_Passive := True;
1658
               elsif C = 'U' then
1659
                  Units.Table (Units.Last).Unit_Kind := 's';
1660
               else
1661
                  Fatal_Error_Ignore;
1662
               end if;
1663
 
1664
               Check_At_End_Of_Field;
1665
 
1666
            else
1667
               C := Getc;
1668
               Fatal_Error_Ignore;
1669
            end if;
1670
         end loop;
1671
 
1672
         Skip_Eol;
1673
 
1674
         --  Check if static elaboration model used
1675
 
1676
         if not Units.Table (Units.Last).Dynamic_Elab
1677
           and then not Units.Table (Units.Last).Internal
1678
         then
1679
            Static_Elaboration_Model_Used := True;
1680
         end if;
1681
 
1682
         C := Getc;
1683
 
1684
         --  Scan out With lines for this unit
1685
 
1686
         With_Loop : loop
1687
            Check_Unknown_Line;
1688
            exit With_Loop when C /= 'W' and then C /= 'Y';
1689
 
1690
            if Ignore ('W') then
1691
               Skip_Line;
1692
 
1693
            else
1694
               Checkc (' ');
1695
               Skip_Space;
1696
               Withs.Increment_Last;
1697
               Withs.Table (Withs.Last).Uname              := Get_Unit_Name;
1698
               Withs.Table (Withs.Last).Elaborate          := False;
1699
               Withs.Table (Withs.Last).Elaborate_All      := False;
1700
               Withs.Table (Withs.Last).Elab_Desirable     := False;
1701
               Withs.Table (Withs.Last).Elab_All_Desirable := False;
1702
               Withs.Table (Withs.Last).SAL_Interface      := False;
1703
               Withs.Table (Withs.Last).Limited_With       := (C = 'Y');
1704
 
1705
               --  Generic case with no object file available
1706
 
1707
               if At_Eol then
1708
                  Withs.Table (Withs.Last).Sfile := No_File;
1709
                  Withs.Table (Withs.Last).Afile := No_File;
1710
 
1711
               --  Normal case
1712
 
1713
               else
1714
                  Withs.Table (Withs.Last).Sfile := Get_File_Name
1715
                                                      (Lower => True);
1716
                  Withs.Table (Withs.Last).Afile := Get_File_Name
1717
                                                      (Lower => True);
1718
 
1719
                  --  Scan out possible E, EA, ED, and AD parameters
1720
 
1721
                  while not At_Eol loop
1722
                     Skip_Space;
1723
 
1724
                     if Nextc = 'A' then
1725
                        P := P + 1;
1726
                        Checkc ('D');
1727
                        Check_At_End_Of_Field;
1728
 
1729
                        --  Store AD indication unless ignore required
1730
 
1731
                        if not Ignore_ED then
1732
                           Withs.Table (Withs.Last).Elab_All_Desirable :=
1733
                             True;
1734
                        end if;
1735
 
1736
                     elsif Nextc = 'E' then
1737
                        P := P + 1;
1738
 
1739
                        if At_End_Of_Field then
1740
                           Withs.Table (Withs.Last).Elaborate := True;
1741
 
1742
                        elsif Nextc = 'A' then
1743
                           P := P + 1;
1744
                           Check_At_End_Of_Field;
1745
                           Withs.Table (Withs.Last).Elaborate_All := True;
1746
 
1747
                        else
1748
                           Checkc ('D');
1749
                           Check_At_End_Of_Field;
1750
 
1751
                           --  Store ED indication unless ignore required
1752
 
1753
                           if not Ignore_ED then
1754
                              Withs.Table (Withs.Last).Elab_Desirable :=
1755
                                True;
1756
                           end if;
1757
                        end if;
1758
 
1759
                     else
1760
                        Fatal_Error;
1761
                     end if;
1762
                  end loop;
1763
               end if;
1764
 
1765
               Skip_Eol;
1766
            end if;
1767
 
1768
            C := Getc;
1769
         end loop With_Loop;
1770
 
1771
         Units.Table (Units.Last).Last_With := Withs.Last;
1772
         Units.Table (Units.Last).Last_Arg  := Args.Last;
1773
 
1774
         --  If there are linker options lines present, scan them
1775
 
1776
         Name_Len := 0;
1777
 
1778
         Linker_Options_Loop : loop
1779
            Check_Unknown_Line;
1780
            exit Linker_Options_Loop when C /= 'L';
1781
 
1782
            if Ignore ('L') then
1783
               Skip_Line;
1784
 
1785
            else
1786
               Checkc (' ');
1787
               Skip_Space;
1788
               Checkc ('"');
1789
 
1790
               loop
1791
                  C := Getc;
1792
 
1793
                  if C < Character'Val (16#20#)
1794
                    or else C > Character'Val (16#7E#)
1795
                  then
1796
                     Fatal_Error_Ignore;
1797
 
1798
                  elsif C = '{' then
1799
                     C := Character'Val (0);
1800
 
1801
                     declare
1802
                        V : Natural;
1803
 
1804
                     begin
1805
                        V := 0;
1806
                        for J in 1 .. 2 loop
1807
                           C := Getc;
1808
 
1809
                           if C in '0' .. '9' then
1810
                              V := V * 16 +
1811
                                     Character'Pos (C) -
1812
                                       Character'Pos ('0');
1813
 
1814
                           elsif C in 'A' .. 'F' then
1815
                              V := V * 16 +
1816
                                     Character'Pos (C) -
1817
                                       Character'Pos ('A') +
1818
                                         10;
1819
 
1820
                           else
1821
                              Fatal_Error_Ignore;
1822
                           end if;
1823
                        end loop;
1824
 
1825
                        Checkc ('}');
1826
                        Add_Char_To_Name_Buffer (Character'Val (V));
1827
                     end;
1828
 
1829
                  else
1830
                     if C = '"' then
1831
                        exit when Nextc /= '"';
1832
                        C := Getc;
1833
                     end if;
1834
 
1835
                     Add_Char_To_Name_Buffer (C);
1836
                  end if;
1837
               end loop;
1838
 
1839
               Add_Char_To_Name_Buffer (NUL);
1840
               Skip_Eol;
1841
            end if;
1842
 
1843
            C := Getc;
1844
         end loop Linker_Options_Loop;
1845
 
1846
         --  Store the linker options entry if one was found
1847
 
1848
         if Name_Len /= 0 then
1849
            Linker_Options.Increment_Last;
1850
 
1851
            Linker_Options.Table (Linker_Options.Last).Name :=
1852
              Name_Enter;
1853
 
1854
            Linker_Options.Table (Linker_Options.Last).Unit :=
1855
              Units.Last;
1856
 
1857
            Linker_Options.Table (Linker_Options.Last).Internal_File :=
1858
              Is_Internal_File_Name (F);
1859
 
1860
            Linker_Options.Table (Linker_Options.Last).Original_Pos :=
1861
              Linker_Options.Last;
1862
         end if;
1863
      end loop U_Loop;
1864
 
1865
      --  End loop through units for one ALI file
1866
 
1867
      ALIs.Table (Id).Last_Unit := Units.Last;
1868
      ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile;
1869
 
1870
      --  Set types of the units (there can be at most 2 of them)
1871
 
1872
      if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then
1873
         Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body;
1874
         Units.Table (ALIs.Table (Id).Last_Unit).Utype  := Is_Spec;
1875
 
1876
      else
1877
         --  Deal with body only and spec only cases, note that the reason we
1878
         --  do our own checking of the name (rather than using Is_Body_Name)
1879
         --  is that Uname drags in far too much compiler junk!
1880
 
1881
         Get_Name_String (Units.Table (Units.Last).Uname);
1882
 
1883
         if Name_Buffer (Name_Len) = 'b' then
1884
            Units.Table (Units.Last).Utype := Is_Body_Only;
1885
         else
1886
            Units.Table (Units.Last).Utype := Is_Spec_Only;
1887
         end if;
1888
      end if;
1889
 
1890
      --  Scan out external version references and put in hash table
1891
 
1892
      E_Loop : loop
1893
         Check_Unknown_Line;
1894
         exit E_Loop when C /= 'E';
1895
 
1896
         if Ignore ('E') then
1897
            Skip_Line;
1898
 
1899
         else
1900
            Checkc (' ');
1901
            Skip_Space;
1902
 
1903
            Name_Len := 0;
1904
            Name_Len := 0;
1905
            loop
1906
               C := Getc;
1907
 
1908
               if C < ' ' then
1909
                  Fatal_Error;
1910
               end if;
1911
 
1912
               exit when At_End_Of_Field;
1913
               Add_Char_To_Name_Buffer (C);
1914
            end loop;
1915
 
1916
            Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
1917
            Skip_Eol;
1918
         end if;
1919
 
1920
         C := Getc;
1921
      end loop E_Loop;
1922
 
1923
      --  Scan out source dependency lines for this ALI file
1924
 
1925
      ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
1926
 
1927
      D_Loop : loop
1928
         Check_Unknown_Line;
1929
         exit D_Loop when C /= 'D';
1930
 
1931
         if Ignore ('D') then
1932
            Skip_Line;
1933
 
1934
         else
1935
            Checkc (' ');
1936
            Skip_Space;
1937
            Sdep.Increment_Last;
1938
 
1939
            --  In the following call, Lower is not set to True, this is either
1940
            --  a bug, or it deserves a special comment as to why this is so???
1941
 
1942
            Sdep.Table (Sdep.Last).Sfile := Get_File_Name;
1943
 
1944
            Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
1945
            Sdep.Table (Sdep.Last).Dummy_Entry :=
1946
              (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
1947
 
1948
            --  Acquire checksum value
1949
 
1950
            Skip_Space;
1951
 
1952
            declare
1953
               Ctr : Natural;
1954
               Chk : Word;
1955
 
1956
            begin
1957
               Ctr := 0;
1958
               Chk := 0;
1959
 
1960
               loop
1961
                  exit when At_Eol or else Ctr = 8;
1962
 
1963
                  if Nextc in '0' .. '9' then
1964
                     Chk := Chk * 16 +
1965
                              Character'Pos (Nextc) - Character'Pos ('0');
1966
 
1967
                  elsif Nextc in 'a' .. 'f' then
1968
                     Chk := Chk * 16 +
1969
                              Character'Pos (Nextc) - Character'Pos ('a') + 10;
1970
 
1971
                  else
1972
                     exit;
1973
                  end if;
1974
 
1975
                  Ctr := Ctr + 1;
1976
                  P := P + 1;
1977
               end loop;
1978
 
1979
               if Ctr = 8 and then At_End_Of_Field then
1980
                  Sdep.Table (Sdep.Last).Checksum := Chk;
1981
               else
1982
                  Fatal_Error;
1983
               end if;
1984
            end;
1985
 
1986
            --  Acquire subunit and reference file name entries
1987
 
1988
            Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
1989
            Sdep.Table (Sdep.Last).Rfile        :=
1990
              Sdep.Table (Sdep.Last).Sfile;
1991
            Sdep.Table (Sdep.Last).Start_Line   := 1;
1992
 
1993
            if not At_Eol then
1994
               Skip_Space;
1995
 
1996
               --  Here for subunit name
1997
 
1998
               if Nextc not in '0' .. '9' then
1999
                  Name_Len := 0;
2000
                  while not At_End_Of_Field loop
2001
                     Add_Char_To_Name_Buffer (Getc);
2002
                  end loop;
2003
 
2004
                  --  Set the subunit name. Note that we use Name_Find rather
2005
                  --  than Name_Enter here as the subunit name may already
2006
                  --  have been put in the name table by the Project Manager.
2007
 
2008
                  Sdep.Table (Sdep.Last).Subunit_Name := Name_Find;
2009
 
2010
                  Skip_Space;
2011
               end if;
2012
 
2013
               --  Here for reference file name entry
2014
 
2015
               if Nextc in '0' .. '9' then
2016
                  Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
2017
                  Checkc (':');
2018
 
2019
                  Name_Len := 0;
2020
 
2021
                  while not At_End_Of_Field loop
2022
                     Add_Char_To_Name_Buffer (Getc);
2023
                  end loop;
2024
 
2025
                  Sdep.Table (Sdep.Last).Rfile := Name_Enter;
2026
               end if;
2027
            end if;
2028
 
2029
            Skip_Eol;
2030
         end if;
2031
 
2032
         C := Getc;
2033
      end loop D_Loop;
2034
 
2035
      ALIs.Table (Id).Last_Sdep := Sdep.Last;
2036
 
2037
      --  We must at this stage be at an Xref line or the end of file
2038
 
2039
      if C = EOF then
2040
         return Id;
2041
      end if;
2042
 
2043
      Check_Unknown_Line;
2044
 
2045
      if C /= 'X' then
2046
         Fatal_Error;
2047
      end if;
2048
 
2049
      --  If we are ignoring Xref sections we are done (we ignore all
2050
      --  remaining lines since only xref related lines follow X).
2051
 
2052
      if Ignore ('X') and then not Debug_Flag_X then
2053
         return Id;
2054
      end if;
2055
 
2056
      --  Loop through Xref sections
2057
 
2058
      X_Loop : loop
2059
         Check_Unknown_Line;
2060
         exit X_Loop when C /= 'X';
2061
 
2062
         --  Make new entry in section table
2063
 
2064
         Xref_Section.Increment_Last;
2065
 
2066
         Read_Refs_For_One_File : declare
2067
            XS : Xref_Section_Record renames
2068
                   Xref_Section.Table (Xref_Section.Last);
2069
 
2070
            Current_File_Num : Sdep_Id;
2071
            --  Keeps track of the current file number (changed by nn|)
2072
 
2073
         begin
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;
2077
 
2078
            Current_File_Num := XS.File_Num;
2079
 
2080
            Skip_Space;
2081
 
2082
            Skip_Eol;
2083
            C := Nextc;
2084
 
2085
            --  Loop through Xref entities
2086
 
2087
            while C /= 'X' and then C /= EOF loop
2088
               Xref_Entity.Increment_Last;
2089
 
2090
               Read_Refs_For_One_Entity : declare
2091
                  XE : Xref_Entity_Record renames
2092
                         Xref_Entity.Table (Xref_Entity.Last);
2093
                  N  : Nat;
2094
 
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 ']'.
2099
 
2100
                  ----------------------------------
2101
                  -- Read_Instantiation_Reference --
2102
                  ----------------------------------
2103
 
2104
                  procedure Read_Instantiation_Reference is
2105
                     Local_File_Num : Sdep_Id := Current_File_Num;
2106
 
2107
                  begin
2108
                     Xref.Increment_Last;
2109
 
2110
                     declare
2111
                        XR : Xref_Record renames Xref.Table (Xref.Last);
2112
 
2113
                     begin
2114
                        P := P + 1; -- skip [
2115
                        N := Get_Nat;
2116
 
2117
                        if Nextc = '|' then
2118
                           XR.File_Num :=
2119
                             Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2120
                           Local_File_Num := XR.File_Num;
2121
                           P := P + 1;
2122
                           N := Get_Nat;
2123
 
2124
                        else
2125
                           XR.File_Num := Local_File_Num;
2126
                        end if;
2127
 
2128
                        XR.Line  := N;
2129
                        XR.Rtype := ' ';
2130
                        XR.Col   := 0;
2131
 
2132
                        --  Recursive call for next reference
2133
 
2134
                        if Nextc = '[' then
2135
                           pragma Warnings (Off); -- kill recursion warning
2136
                           Read_Instantiation_Reference;
2137
                           pragma Warnings (On);
2138
                        end if;
2139
 
2140
                        --  Skip closing bracket after recursive call
2141
 
2142
                        P := P + 1;
2143
                     end;
2144
                  end Read_Instantiation_Reference;
2145
 
2146
               --  Start of processing for Read_Refs_For_One_Entity
2147
 
2148
               begin
2149
                  XE.Line   := Get_Nat;
2150
                  XE.Etype  := Getc;
2151
                  XE.Col    := Get_Nat;
2152
                  XE.Lib    := (Getc = '*');
2153
                  XE.Entity := Get_Name;
2154
 
2155
                  --  Handle the information about generic instantiations
2156
 
2157
                  if Nextc = '[' then
2158
                     Skipc; --  Opening '['
2159
                     N := Get_Nat;
2160
 
2161
                     if Nextc /= '|' then
2162
                        XE.Iref_File_Num := Current_File_Num;
2163
                        XE.Iref_Line     := N;
2164
                     else
2165
                        XE.Iref_File_Num :=
2166
                          Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2167
                        Skipc;
2168
                        XE.Iref_Line := Get_Nat;
2169
                     end if;
2170
 
2171
                     if Getc /= ']' then
2172
                        Fatal_Error;
2173
                     end if;
2174
 
2175
                  else
2176
                     XE.Iref_File_Num := No_Sdep_Id;
2177
                     XE.Iref_Line     := 0;
2178
                  end if;
2179
 
2180
                  Current_File_Num := XS.File_Num;
2181
 
2182
                  --  Renaming reference is present
2183
 
2184
                  if Nextc = '=' then
2185
                     P := P + 1;
2186
                     XE.Rref_Line := Get_Nat;
2187
 
2188
                     if Getc /= ':' then
2189
                        Fatal_Error;
2190
                     end if;
2191
 
2192
                     XE.Rref_Col := Get_Nat;
2193
 
2194
                  --  No renaming reference present
2195
 
2196
                  else
2197
                     XE.Rref_Line := 0;
2198
                     XE.Rref_Col  := 0;
2199
                  end if;
2200
 
2201
                  Skip_Space;
2202
 
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;
2207
 
2208
                  --  Loop to check for additional info present
2209
 
2210
                  loop
2211
                     declare
2212
                        Ref  : Tref_Kind;
2213
                        File : Sdep_Id;
2214
                        Line : Nat;
2215
                        Typ  : Character;
2216
                        Col  : Nat;
2217
                        Std  : Name_Id;
2218
 
2219
                     begin
2220
                        Get_Typeref
2221
                          (Current_File_Num, Ref, File, Line, Typ, Col, Std);
2222
                        exit when Ref = Tref_None;
2223
 
2224
                        --  Do we have an overriding procedure?
2225
 
2226
                        if Ref = Tref_Derived and then Typ = 'p' then
2227
                           XE.Oref_File_Num := File;
2228
                           XE.Oref_Line     := Line;
2229
                           XE.Oref_Col      := Col;
2230
 
2231
                        --  Arrays never override anything, and <> points to
2232
                        --  the index types instead
2233
 
2234
                        elsif Ref = Tref_Derived and then XE.Etype = 'A' then
2235
 
2236
                           --  Index types are stored in the list of references
2237
 
2238
                           Xref.Increment_Last;
2239
 
2240
                           declare
2241
                              XR : Xref_Record renames Xref.Table (Xref.Last);
2242
                           begin
2243
                              XR.File_Num := File;
2244
                              XR.Line     := Line;
2245
                              XR.Rtype    := Array_Index_Reference;
2246
                              XR.Col      := Col;
2247
                              XR.Name     := Std;
2248
                           end;
2249
 
2250
                        --  Interfaces are stored in the list of references,
2251
                        --  although the parent type itself is stored in XE.
2252
                        --  The first interface (when there are only
2253
                        --  interfaces) is stored in XE.Tref*)
2254
 
2255
                        elsif Ref = Tref_Derived
2256
                          and then Typ = 'R'
2257
                          and then XE.Tref_File_Num /= No_Sdep_Id
2258
                        then
2259
                           Xref.Increment_Last;
2260
 
2261
                           declare
2262
                              XR : Xref_Record renames Xref.Table (Xref.Last);
2263
                           begin
2264
                              XR.File_Num := File;
2265
                              XR.Line     := Line;
2266
                              XR.Rtype    := Interface_Reference;
2267
                              XR.Col      := Col;
2268
                              XR.Name     := Std;
2269
                           end;
2270
 
2271
                        else
2272
                           XE.Tref                 := Ref;
2273
                           XE.Tref_File_Num        := File;
2274
                           XE.Tref_Line            := Line;
2275
                           XE.Tref_Type            := Typ;
2276
                           XE.Tref_Col             := Col;
2277
                           XE.Tref_Standard_Entity := Std;
2278
                        end if;
2279
                     end;
2280
                  end loop;
2281
 
2282
                  --  Loop through cross-references for this entity
2283
 
2284
                  loop
2285
                     Skip_Space;
2286
 
2287
                     if At_Eol then
2288
                        Skip_Eol;
2289
                        exit when Nextc /= '.';
2290
                        P := P + 1;
2291
                     end if;
2292
 
2293
                     Xref.Increment_Last;
2294
 
2295
                     declare
2296
                        XR : Xref_Record renames Xref.Table (Xref.Last);
2297
 
2298
                     begin
2299
                        N := Get_Nat;
2300
 
2301
                        if Nextc = '|' then
2302
                           XR.File_Num :=
2303
                             Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
2304
                           Current_File_Num := XR.File_Num;
2305
                           P := P + 1;
2306
                           N := Get_Nat;
2307
                        else
2308
                           XR.File_Num := Current_File_Num;
2309
                        end if;
2310
 
2311
                        XR.Line  := N;
2312
                        XR.Rtype := Getc;
2313
 
2314
                        --  Imported entities reference as in:
2315
                        --    494b<c,__gnat_copy_attribs>25
2316
                        --  ??? Simply skipped for now
2317
 
2318
                        if Nextc = '<' then
2319
                           while Getc /= '>' loop
2320
                              null;
2321
                           end loop;
2322
                        end if;
2323
 
2324
                        XR.Col   := Get_Nat;
2325
 
2326
                        if Nextc = '[' then
2327
                           Read_Instantiation_Reference;
2328
                        end if;
2329
                     end;
2330
                  end loop;
2331
 
2332
                  --  Record last cross-reference
2333
 
2334
                  XE.Last_Xref := Xref.Last;
2335
                  C := Nextc;
2336
 
2337
               exception
2338
                  when Bad_ALI_Format =>
2339
 
2340
                     --  If ignoring errors, then we skip a line with an
2341
                     --  unexpected error, and try to continue subsequent
2342
                     --  xref lines.
2343
 
2344
                     if Ignore_Errors then
2345
                        Xref_Entity.Decrement_Last;
2346
                        Skip_Line;
2347
                        C := Nextc;
2348
 
2349
                     --  Otherwise, we reraise the fatal exception
2350
 
2351
                     else
2352
                        raise;
2353
                     end if;
2354
               end Read_Refs_For_One_Entity;
2355
            end loop;
2356
 
2357
            --  Record last entity
2358
 
2359
            XS.Last_Entity := Xref_Entity.Last;
2360
 
2361
         end Read_Refs_For_One_File;
2362
 
2363
         C := Getc;
2364
      end loop X_Loop;
2365
 
2366
      --  Here after dealing with xref sections
2367
 
2368
      if C /= EOF and then C /= 'X' then
2369
         Fatal_Error;
2370
      end if;
2371
 
2372
      return Id;
2373
 
2374
   exception
2375
      when Bad_ALI_Format =>
2376
         return No_ALI_Id;
2377
   end Scan_ALI;
2378
 
2379
   ---------
2380
   -- SEq --
2381
   ---------
2382
 
2383
   function SEq (F1, F2 : String_Ptr) return Boolean is
2384
   begin
2385
      return F1.all = F2.all;
2386
   end SEq;
2387
 
2388
   -----------
2389
   -- SHash --
2390
   -----------
2391
 
2392
   function SHash (S : String_Ptr) return Vindex is
2393
      H : Word;
2394
 
2395
   begin
2396
      H := 0;
2397
      for J in S.all'Range loop
2398
         H := H * 2 + Character'Pos (S (J));
2399
      end loop;
2400
 
2401
      return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));
2402
   end SHash;
2403
 
2404
end ALI;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.