1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                                  A L I                                   --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2019, 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
26with Butil;  use Butil;
27with Debug;  use Debug;
28with Fname;  use Fname;
29with Opt;    use Opt;
30with Osint;  use Osint;
31with Output; use Output;
32with Snames; use Snames;
33
34with GNAT;                 use GNAT;
35with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
36
37package body ALI is
38
39   use ASCII;
40   --  Make control characters visible
41
42   -----------
43   -- Types --
44   -----------
45
46   --  The following type represents an invocation construct
47
48   type Invocation_Construct_Record is record
49      Body_Placement : Declaration_Placement_Kind := No_Declaration_Placement;
50      --  The location of the invocation construct's body with respect to the
51      --  unit where it is declared.
52
53      Kind : Invocation_Construct_Kind := Regular_Construct;
54      --  The nature of the invocation construct
55
56      Signature : Invocation_Signature_Id := No_Invocation_Signature;
57      --  The invocation signature that uniquely identifies the invocation
58      --  construct in the ALI space.
59
60      Spec_Placement : Declaration_Placement_Kind := No_Declaration_Placement;
61      --  The location of the invocation construct's spec with respect to the
62      --  unit where it is declared.
63   end record;
64
65   --  The following type represents an invocation relation. It associates an
66   --  invoker that activates/calls/instantiates with a target.
67
68   type Invocation_Relation_Record is record
69      Extra : Name_Id := No_Name;
70      --  The name of an additional entity used in error diagnostics
71
72      Invoker : Invocation_Signature_Id := No_Invocation_Signature;
73      --  The invocation signature that uniquely identifies the invoker within
74      --  the ALI space.
75
76      Kind : Invocation_Kind := No_Invocation;
77      --  The nature of the invocation
78
79      Target : Invocation_Signature_Id := No_Invocation_Signature;
80      --  The invocation signature that uniquely identifies the target within
81      --  the ALI space.
82   end record;
83
84   --  The following type represents an invocation signature. Its purpose is
85   --  to uniquely identify an invocation construct within the ALI space. The
86   --  signature comprises several pieces, some of which are used in error
87   --  diagnostics by the binder. Identification issues are resolved as
88   --  follows:
89   --
90   --    * The Column, Line, and Locations attributes together differentiate
91   --      between homonyms. In most cases, the Column and Line are sufficient
92   --      except when generic instantiations are involved. Together, the three
93   --      attributes offer a sequence of column-line pairs that eventually
94   --      reflect the location within the generic template.
95   --
96   --    * The Name attribute differentiates between invocation constructs at
97   --      the scope level. Since it is illegal for two entities with the same
98   --      name to coexist in the same scope, the Name attribute is sufficient
99   --      to distinguish them. Overloaded entities are already handled by the
100   --      Column, Line, and Locations attributes.
101   --
102   --    * The Scope attribute differentiates between invocation constructs at
103   --      various levels of nesting.
104
105   type Invocation_Signature_Record is record
106      Column : Nat := 0;
107      --  The column number where the invocation construct is declared
108
109      Line : Nat := 0;
110      --  The line number where the invocation construct is declared
111
112      Locations : Name_Id := No_Name;
113      --  Sequence of column and line numbers within nested instantiations
114
115      Name : Name_Id := No_Name;
116      --  The name of the invocation construct
117
118      Scope : Name_Id := No_Name;
119      --  The qualified name of the scope where the invocation construct is
120      --  declared.
121   end record;
122
123   ---------------------
124   -- Data structures --
125   ---------------------
126
127   package Invocation_Constructs is new Table.Table
128     (Table_Index_Type     => Invocation_Construct_Id,
129      Table_Component_Type => Invocation_Construct_Record,
130      Table_Low_Bound      => First_Invocation_Construct,
131      Table_Initial        => 2500,
132      Table_Increment      => 200,
133      Table_Name           => "Invocation_Constructs");
134
135   package Invocation_Relations is new Table.Table
136     (Table_Index_Type     => Invocation_Relation_Id,
137      Table_Component_Type => Invocation_Relation_Record,
138      Table_Low_Bound      => First_Invocation_Relation,
139      Table_Initial        => 2500,
140      Table_Increment      => 200,
141      Table_Name           => "Invocation_Relation");
142
143   package Invocation_Signatures is new Table.Table
144     (Table_Index_Type     => Invocation_Signature_Id,
145      Table_Component_Type => Invocation_Signature_Record,
146      Table_Low_Bound      => First_Invocation_Signature,
147      Table_Initial        => 2500,
148      Table_Increment      => 200,
149      Table_Name           => "Invocation_Signatures");
150
151   procedure Destroy (IS_Id : in out Invocation_Signature_Id);
152   --  Destroy an invocation signature with id IS_Id
153
154   function Hash
155     (IS_Rec : Invocation_Signature_Record) return Bucket_Range_Type;
156   --  Obtain the hash of key IS_Rec
157
158   package Sig_Map is new Dynamic_Hash_Tables
159     (Key_Type              => Invocation_Signature_Record,
160      Value_Type            => Invocation_Signature_Id,
161      No_Value              => No_Invocation_Signature,
162      Expansion_Threshold   => 1.5,
163      Expansion_Factor      => 2,
164      Compression_Threshold => 0.3,
165      Compression_Factor    => 2,
166      "="                   => "=",
167      Destroy_Value         => Destroy,
168      Hash                  => Hash);
169
170   --  The following map relates invocation signature records to invocation
171   --  signature ids.
172
173   Sig_To_Sig_Map : constant Sig_Map.Dynamic_Hash_Table :=
174                      Sig_Map.Create (500);
175
176   --  The folowing table maps declaration placement kinds to character codes
177   --  for invocation construct encoding in ALI files.
178
179   Declaration_Placement_Codes :
180     constant array (Declaration_Placement_Kind) of Character :=
181       (In_Body                  => 'b',
182        In_Spec                  => 's',
183        No_Declaration_Placement => 'Z');
184
185   Compile_Time_Invocation_Graph_Encoding : Invocation_Graph_Encoding_Kind :=
186                                              No_Encoding;
187   --  The invocation-graph encoding format as specified at compile time. Do
188   --  not manipulate this value directly.
189
190   --  The following table maps invocation kinds to character codes for
191   --  invocation relation encoding in ALI files.
192
193   Invocation_Codes :
194     constant array (Invocation_Kind) of Character :=
195       (Accept_Alternative                     => 'a',
196        Access_Taken                           => 'b',
197        Call                                   => 'c',
198        Controlled_Adjustment                  => 'd',
199        Controlled_Finalization                => 'e',
200        Controlled_Initialization              => 'f',
201        Default_Initial_Condition_Verification => 'g',
202        Initial_Condition_Verification         => 'h',
203        Instantiation                          => 'i',
204        Internal_Controlled_Adjustment         => 'j',
205        Internal_Controlled_Finalization       => 'k',
206        Internal_Controlled_Initialization     => 'l',
207        Invariant_Verification                 => 'm',
208        Postcondition_Verification             => 'n',
209        Protected_Entry_Call                   => 'o',
210        Protected_Subprogram_Call              => 'p',
211        Task_Activation                        => 'q',
212        Task_Entry_Call                        => 'r',
213        Type_Initialization                    => 's',
214        No_Invocation                          => 'Z');
215
216   --  The following table maps invocation construct kinds to character codes
217   --  for invocation construct encoding in ALI files.
218
219   Invocation_Construct_Codes :
220     constant array (Invocation_Construct_Kind) of Character :=
221       (Elaborate_Body_Procedure => 'b',
222        Elaborate_Spec_Procedure => 's',
223        Regular_Construct        => 'Z');
224
225   --  The following table maps invocation-graph encoding kinds to character
226   --  codes for invocation-graph encoding in ALI files.
227
228   Invocation_Graph_Encoding_Codes :
229     constant array (Invocation_Graph_Encoding_Kind) of Character :=
230       (Full_Path_Encoding => 'f',
231        Endpoints_Encoding => 'e',
232        No_Encoding        => 'Z');
233
234   --  The following table maps invocation-graph line kinds to character codes
235   --  used in ALI files.
236
237   Invocation_Graph_Line_Codes :
238     constant array (Invocation_Graph_Line_Kind) of Character :=
239       (Invocation_Construct_Line        => 'c',
240        Invocation_Graph_Attributes_Line => 'a',
241        Invocation_Relation_Line         => 'r');
242
243   --  The following variable records which characters currently are used as
244   --  line type markers in the ALI file. This is used in Scan_ALI to detect
245   --  (or skip) invalid lines. The following letters are still available:
246   --
247   --    B F H J K O Q Z
248
249   Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean :=
250     ('A'    => True,  --  argument
251      'C'    => True,  --  SCO information
252      'D'    => True,  --  dependency
253      'E'    => True,  --  external
254      'G'    => True,  --  invocation graph
255      'I'    => True,  --  interrupt
256      'L'    => True,  --  linker option
257      'M'    => True,  --  main program
258      'N'    => True,  --  notes
259      'P'    => True,  --  program
260      'R'    => True,  --  restriction
261      'S'    => True,  --  specific dispatching
262      'T'    => True,  --  task stack information
263      'U'    => True,  --  unit
264      'V'    => True,  --  version
265      'W'    => True,  --  with
266      'X'    => True,  --  xref
267      'Y'    => True,  --  limited_with
268      'Z'    => True,  --  implicit with from instantiation
269      others => False);
270
271   ------------------------------
272   -- Add_Invocation_Construct --
273   ------------------------------
274
275   procedure Add_Invocation_Construct
276     (Body_Placement : Declaration_Placement_Kind;
277      Kind           : Invocation_Construct_Kind;
278      Signature      : Invocation_Signature_Id;
279      Spec_Placement : Declaration_Placement_Kind;
280      Update_Units   : Boolean := True)
281   is
282   begin
283      pragma Assert (Present (Signature));
284
285      --  Create a invocation construct from the scanned attributes
286
287      Invocation_Constructs.Append
288        ((Body_Placement => Body_Placement,
289          Kind           => Kind,
290          Signature      => Signature,
291          Spec_Placement => Spec_Placement));
292
293      --  Update the invocation construct counter of the current unit only when
294      --  requested by the caller.
295
296      if Update_Units then
297         declare
298            Curr_Unit : Unit_Record renames Units.Table (Units.Last);
299
300         begin
301            Curr_Unit.Last_Invocation_Construct := Invocation_Constructs.Last;
302         end;
303      end if;
304   end Add_Invocation_Construct;
305
306   -----------------------------
307   -- Add_Invocation_Relation --
308   -----------------------------
309
310   procedure Add_Invocation_Relation
311     (Extra        : Name_Id;
312      Invoker      : Invocation_Signature_Id;
313      Kind         : Invocation_Kind;
314      Target       : Invocation_Signature_Id;
315      Update_Units : Boolean := True)
316   is
317   begin
318      pragma Assert (Present (Invoker));
319      pragma Assert (Kind /= No_Invocation);
320      pragma Assert (Present (Target));
321
322      --  Create an invocation relation from the scanned attributes
323
324      Invocation_Relations.Append
325        ((Extra   => Extra,
326          Invoker => Invoker,
327          Kind    => Kind,
328          Target  => Target));
329
330      --  Update the invocation relation counter of the current unit only when
331      --  requested by the caller.
332
333      if Update_Units then
334         declare
335            Curr_Unit : Unit_Record renames Units.Table (Units.Last);
336
337         begin
338            Curr_Unit.Last_Invocation_Relation := Invocation_Relations.Last;
339         end;
340      end if;
341   end Add_Invocation_Relation;
342
343   --------------------
344   -- Body_Placement --
345   --------------------
346
347   function Body_Placement
348     (IC_Id : Invocation_Construct_Id) return Declaration_Placement_Kind
349   is
350   begin
351      pragma Assert (Present (IC_Id));
352      return Invocation_Constructs.Table (IC_Id).Body_Placement;
353   end Body_Placement;
354
355   ----------------------------------------
356   -- Code_To_Declaration_Placement_Kind --
357   ----------------------------------------
358
359   function Code_To_Declaration_Placement_Kind
360     (Code : Character) return Declaration_Placement_Kind
361   is
362   begin
363      --  Determine which placement kind corresponds to the character code by
364      --  traversing the contents of the mapping table.
365
366      for Kind in Declaration_Placement_Kind loop
367         if Declaration_Placement_Codes (Kind) = Code then
368            return Kind;
369         end if;
370      end loop;
371
372      raise Program_Error;
373   end Code_To_Declaration_Placement_Kind;
374
375   ---------------------------------------
376   -- Code_To_Invocation_Construct_Kind --
377   ---------------------------------------
378
379   function Code_To_Invocation_Construct_Kind
380     (Code : Character) return Invocation_Construct_Kind
381   is
382   begin
383      --  Determine which invocation construct kind matches the character code
384      --  by traversing the contents of the mapping table.
385
386      for Kind in Invocation_Construct_Kind loop
387         if Invocation_Construct_Codes (Kind) = Code then
388            return Kind;
389         end if;
390      end loop;
391
392      raise Program_Error;
393   end Code_To_Invocation_Construct_Kind;
394
395   --------------------------------------------
396   -- Code_To_Invocation_Graph_Encoding_Kind --
397   --------------------------------------------
398
399   function Code_To_Invocation_Graph_Encoding_Kind
400     (Code : Character) return Invocation_Graph_Encoding_Kind
401   is
402   begin
403      --  Determine which invocation-graph encoding kind matches the character
404      --  code by traversing the contents of the mapping table.
405
406      for Kind in Invocation_Graph_Encoding_Kind loop
407         if Invocation_Graph_Encoding_Codes (Kind) = Code then
408            return Kind;
409         end if;
410      end loop;
411
412      raise Program_Error;
413   end Code_To_Invocation_Graph_Encoding_Kind;
414
415   -----------------------------
416   -- Code_To_Invocation_Kind --
417   -----------------------------
418
419   function Code_To_Invocation_Kind
420     (Code : Character) return Invocation_Kind
421   is
422   begin
423      --  Determine which invocation kind corresponds to the character code by
424      --  traversing the contents of the mapping table.
425
426      for Kind in Invocation_Kind loop
427         if Invocation_Codes (Kind) = Code then
428            return Kind;
429         end if;
430      end loop;
431
432      raise Program_Error;
433   end Code_To_Invocation_Kind;
434
435   ----------------------------------------
436   -- Code_To_Invocation_Graph_Line_Kind --
437   ----------------------------------------
438
439   function Code_To_Invocation_Graph_Line_Kind
440     (Code : Character) return Invocation_Graph_Line_Kind
441   is
442   begin
443      --  Determine which invocation-graph line kind matches the character
444      --  code by traversing the contents of the mapping table.
445
446      for Kind in Invocation_Graph_Line_Kind loop
447         if Invocation_Graph_Line_Codes (Kind) = Code then
448            return Kind;
449         end if;
450      end loop;
451
452      raise Program_Error;
453   end Code_To_Invocation_Graph_Line_Kind;
454
455   ------------
456   -- Column --
457   ------------
458
459   function Column (IS_Id : Invocation_Signature_Id) return Nat is
460   begin
461      pragma Assert (Present (IS_Id));
462      return Invocation_Signatures.Table (IS_Id).Column;
463   end Column;
464
465   ----------------------------------------
466   -- Declaration_Placement_Kind_To_Code --
467   ----------------------------------------
468
469   function Declaration_Placement_Kind_To_Code
470     (Kind : Declaration_Placement_Kind) return Character
471   is
472   begin
473      return Declaration_Placement_Codes (Kind);
474   end Declaration_Placement_Kind_To_Code;
475
476   -------------
477   -- Destroy --
478   -------------
479
480   procedure Destroy (IS_Id : in out Invocation_Signature_Id) is
481      pragma Unreferenced (IS_Id);
482   begin
483      null;
484   end Destroy;
485
486   -----------
487   -- Extra --
488   -----------
489
490   function Extra (IR_Id : Invocation_Relation_Id) return Name_Id is
491   begin
492      pragma Assert (Present (IR_Id));
493      return Invocation_Relations.Table (IR_Id).Extra;
494   end Extra;
495
496   -----------------------------------
497   -- For_Each_Invocation_Construct --
498   -----------------------------------
499
500   procedure For_Each_Invocation_Construct
501     (Processor : Invocation_Construct_Processor_Ptr)
502   is
503   begin
504      pragma Assert (Processor /= null);
505
506      for IC_Id in Invocation_Constructs.First ..
507                   Invocation_Constructs.Last
508      loop
509         Processor.all (IC_Id);
510      end loop;
511   end For_Each_Invocation_Construct;
512
513   -----------------------------------
514   -- For_Each_Invocation_Construct --
515   -----------------------------------
516
517   procedure For_Each_Invocation_Construct
518     (U_Id      : Unit_Id;
519      Processor : Invocation_Construct_Processor_Ptr)
520   is
521      pragma Assert (Present (U_Id));
522      pragma Assert (Processor /= null);
523
524      U_Rec : Unit_Record renames Units.Table (U_Id);
525
526   begin
527      for IC_Id in U_Rec.First_Invocation_Construct ..
528                   U_Rec.Last_Invocation_Construct
529      loop
530         Processor.all (IC_Id);
531      end loop;
532   end For_Each_Invocation_Construct;
533
534   ----------------------------------
535   -- For_Each_Invocation_Relation --
536   ----------------------------------
537
538   procedure For_Each_Invocation_Relation
539     (Processor : Invocation_Relation_Processor_Ptr)
540   is
541   begin
542      pragma Assert (Processor /= null);
543
544      for IR_Id in Invocation_Relations.First ..
545                   Invocation_Relations.Last
546      loop
547         Processor.all (IR_Id);
548      end loop;
549   end For_Each_Invocation_Relation;
550
551   ----------------------------------
552   -- For_Each_Invocation_Relation --
553   ----------------------------------
554
555   procedure For_Each_Invocation_Relation
556     (U_Id      : Unit_Id;
557      Processor : Invocation_Relation_Processor_Ptr)
558   is
559      pragma Assert (Present (U_Id));
560      pragma Assert (Processor /= null);
561
562      U_Rec : Unit_Record renames Units.Table (U_Id);
563
564   begin
565      for IR_Id in U_Rec.First_Invocation_Relation ..
566                   U_Rec.Last_Invocation_Relation
567      loop
568         Processor.all (IR_Id);
569      end loop;
570   end For_Each_Invocation_Relation;
571
572   ----------
573   -- Hash --
574   ----------
575
576   function Hash
577     (IS_Rec : Invocation_Signature_Record) return Bucket_Range_Type
578   is
579      Buffer : Bounded_String (2052);
580      IS_Nam : Name_Id;
581
582   begin
583      --  The hash is obtained in the following manner:
584      --
585      --    * A String signature based on the scope, name, line number, column
586      --      number, and locations, in the following format:
587      --
588      --         scope__name__line_column__locations
589      --
590      --    * The String is converted into a Name_Id
591      --    * The Name_Id is used as the hash
592
593      Append (Buffer, IS_Rec.Scope);
594      Append (Buffer, "__");
595      Append (Buffer, IS_Rec.Name);
596      Append (Buffer, "__");
597      Append (Buffer, IS_Rec.Line);
598      Append (Buffer, '_');
599      Append (Buffer, IS_Rec.Column);
600
601      if IS_Rec.Locations /= No_Name then
602         Append (Buffer, "__");
603         Append (Buffer, IS_Rec.Locations);
604      end if;
605
606      IS_Nam := Name_Find (Buffer);
607      return Bucket_Range_Type (IS_Nam);
608   end Hash;
609
610   --------------------
611   -- Initialize_ALI --
612   --------------------
613
614   procedure Initialize_ALI is
615   begin
616      --  When (re)initializing ALI data structures the ALI user expects to
617      --  get a fresh set of data structures. Thus we first need to erase the
618      --  marks put in the name table by the previous set of ALI routine calls.
619      --  These two loops are empty and harmless the first time in.
620
621      for J in ALIs.First .. ALIs.Last loop
622         Set_Name_Table_Int (ALIs.Table (J).Afile, 0);
623      end loop;
624
625      for J in Units.First .. Units.Last loop
626         Set_Name_Table_Int (Units.Table (J).Uname, 0);
627      end loop;
628
629      --  Free argument table strings
630
631      for J in Args.First .. Args.Last loop
632         Free (Args.Table (J));
633      end loop;
634
635      --  Initialize all tables
636
637      ALIs.Init;
638      Invocation_Constructs.Init;
639      Invocation_Relations.Init;
640      Invocation_Signatures.Init;
641      Linker_Options.Init;
642      No_Deps.Init;
643      Notes.Init;
644      Sdep.Init;
645      Units.Init;
646      Version_Ref.Reset;
647      Withs.Init;
648      Xref_Entity.Init;
649      Xref.Init;
650      Xref_Section.Init;
651
652      --  Add dummy zeroth item in Linker_Options and Notes for sort calls
653
654      Linker_Options.Increment_Last;
655      Notes.Increment_Last;
656
657      --  Initialize global variables recording cumulative options in all
658      --  ALI files that are read for a given processing run in gnatbind.
659
660      Dynamic_Elaboration_Checks_Specified   := False;
661      Locking_Policy_Specified               := ' ';
662      No_Normalize_Scalars_Specified         := False;
663      No_Object_Specified                    := False;
664      No_Component_Reordering_Specified      := False;
665      GNATprove_Mode_Specified               := False;
666      Normalize_Scalars_Specified            := False;
667      Partition_Elaboration_Policy_Specified := ' ';
668      Queuing_Policy_Specified               := ' ';
669      SSO_Default_Specified                  := False;
670      Task_Dispatching_Policy_Specified      := ' ';
671      Unreserve_All_Interrupts_Specified     := False;
672      Frontend_Exceptions_Specified          := False;
673      Zero_Cost_Exceptions_Specified         := False;
674   end Initialize_ALI;
675
676   ---------------------------------------
677   -- Invocation_Construct_Kind_To_Code --
678   ---------------------------------------
679
680   function Invocation_Construct_Kind_To_Code
681     (Kind : Invocation_Construct_Kind) return Character
682   is
683   begin
684      return Invocation_Construct_Codes (Kind);
685   end Invocation_Construct_Kind_To_Code;
686
687   -------------------------------
688   -- Invocation_Graph_Encoding --
689   -------------------------------
690
691   function Invocation_Graph_Encoding return Invocation_Graph_Encoding_Kind is
692   begin
693      return Compile_Time_Invocation_Graph_Encoding;
694   end Invocation_Graph_Encoding;
695
696   --------------------------------------------
697   -- Invocation_Graph_Encoding_Kind_To_Code --
698   --------------------------------------------
699
700   function Invocation_Graph_Encoding_Kind_To_Code
701     (Kind : Invocation_Graph_Encoding_Kind) return Character
702   is
703   begin
704      return Invocation_Graph_Encoding_Codes (Kind);
705   end Invocation_Graph_Encoding_Kind_To_Code;
706
707   ----------------------------------------
708   -- Invocation_Graph_Line_Kind_To_Code --
709   ----------------------------------------
710
711   function Invocation_Graph_Line_Kind_To_Code
712     (Kind : Invocation_Graph_Line_Kind) return Character
713   is
714   begin
715      return Invocation_Graph_Line_Codes (Kind);
716   end Invocation_Graph_Line_Kind_To_Code;
717
718   -----------------------------
719   -- Invocation_Kind_To_Code --
720   -----------------------------
721
722   function Invocation_Kind_To_Code
723     (Kind : Invocation_Kind) return Character
724   is
725   begin
726      return Invocation_Codes (Kind);
727   end Invocation_Kind_To_Code;
728
729   -----------------------------
730   -- Invocation_Signature_Of --
731   -----------------------------
732
733   function Invocation_Signature_Of
734     (Column    : Nat;
735      Line      : Nat;
736      Locations : Name_Id;
737      Name      : Name_Id;
738      Scope     : Name_Id) return Invocation_Signature_Id
739   is
740      IS_Rec : constant Invocation_Signature_Record :=
741                 (Column    => Column,
742                  Line      => Line,
743                  Locations => Locations,
744                  Name      => Name,
745                  Scope     => Scope);
746      IS_Id  : Invocation_Signature_Id;
747
748   begin
749      IS_Id := Sig_Map.Get (Sig_To_Sig_Map, IS_Rec);
750
751      --  The invocation signature lacks an id. This indicates that it
752      --  is encountered for the first time during the construction of
753      --  the graph.
754
755      if not Present (IS_Id) then
756         Invocation_Signatures.Append (IS_Rec);
757         IS_Id := Invocation_Signatures.Last;
758
759         --  Map the invocation signature record to its corresponding id
760
761         Sig_Map.Put (Sig_To_Sig_Map, IS_Rec, IS_Id);
762      end if;
763
764      return IS_Id;
765   end Invocation_Signature_Of;
766
767   -------------
768   -- Invoker --
769   -------------
770
771   function Invoker
772     (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id
773   is
774   begin
775      pragma Assert (Present (IR_Id));
776      return Invocation_Relations.Table (IR_Id).Invoker;
777   end Invoker;
778
779   ----------
780   -- Kind --
781   ----------
782
783   function Kind
784     (IC_Id : Invocation_Construct_Id) return Invocation_Construct_Kind
785   is
786   begin
787      pragma Assert (Present (IC_Id));
788      return Invocation_Constructs.Table (IC_Id).Kind;
789   end Kind;
790
791   ----------
792   -- Kind --
793   ----------
794
795   function Kind (IR_Id : Invocation_Relation_Id) return Invocation_Kind is
796   begin
797      pragma Assert (Present (IR_Id));
798      return Invocation_Relations.Table (IR_Id).Kind;
799   end Kind;
800
801   ----------
802   -- Line --
803   ----------
804
805   function Line (IS_Id : Invocation_Signature_Id) return Nat is
806   begin
807      pragma Assert (Present (IS_Id));
808      return Invocation_Signatures.Table (IS_Id).Line;
809   end Line;
810
811   ---------------
812   -- Locations --
813   ---------------
814
815   function Locations (IS_Id : Invocation_Signature_Id) return Name_Id is
816   begin
817      pragma Assert (Present (IS_Id));
818      return Invocation_Signatures.Table (IS_Id).Locations;
819   end Locations;
820
821   ----------
822   -- Name --
823   ----------
824
825   function Name (IS_Id : Invocation_Signature_Id) return Name_Id is
826   begin
827      pragma Assert (Present (IS_Id));
828      return Invocation_Signatures.Table (IS_Id).Name;
829   end Name;
830
831   -------------
832   -- Present --
833   -------------
834
835   function Present (IC_Id : Invocation_Construct_Id) return Boolean is
836   begin
837      return IC_Id /= No_Invocation_Construct;
838   end Present;
839
840   -------------
841   -- Present --
842   -------------
843
844   function Present (IR_Id : Invocation_Relation_Id) return Boolean is
845   begin
846      return IR_Id /= No_Invocation_Relation;
847   end Present;
848
849   -------------
850   -- Present --
851   -------------
852
853   function Present (IS_Id : Invocation_Signature_Id) return Boolean is
854   begin
855      return IS_Id /= No_Invocation_Signature;
856   end Present;
857
858   -------------
859   -- Present --
860   -------------
861
862   function Present (Dep : Sdep_Id) return Boolean is
863   begin
864      return Dep /= No_Sdep_Id;
865   end Present;
866
867   -------------
868   -- Present --
869   -------------
870
871   function Present (U_Id : Unit_Id) return Boolean is
872   begin
873      return U_Id /= No_Unit_Id;
874   end Present;
875
876   -------------
877   -- Present --
878   -------------
879
880   function Present (W_Id : With_Id) return Boolean is
881   begin
882      return W_Id /= No_With_Id;
883   end Present;
884
885   --------------
886   -- Scan_ALI --
887   --------------
888
889   function Scan_ALI
890     (F                : File_Name_Type;
891      T                : Text_Buffer_Ptr;
892      Ignore_ED        : Boolean;
893      Err              : Boolean;
894      Read_Xref        : Boolean := False;
895      Read_Lines       : String  := "";
896      Ignore_Lines     : String  := "X";
897      Ignore_Errors    : Boolean := False;
898      Directly_Scanned : Boolean := False) return ALI_Id
899   is
900      P         : Text_Ptr            := T'First;
901      Line      : Logical_Line_Number := 1;
902      Id        : ALI_Id;
903      C         : Character;
904      NS_Found  : Boolean;
905      First_Arg : Arg_Id;
906
907      Ignore : array (Character range 'A' .. 'Z') of Boolean;
908      --  Ignore (X) is set to True if lines starting with X are to
909      --  be ignored by Scan_ALI and skipped, and False if the lines
910      --  are to be read and processed.
911
912      Bad_ALI_Format : exception;
913      --  Exception raised by Fatal_Error if Err is True
914
915      function At_Eol return Boolean;
916      --  Test if at end of line
917
918      function At_End_Of_Field return Boolean;
919      --  Test if at end of line, or if at blank or horizontal tab
920
921      procedure Check_At_End_Of_Field;
922      --  Check if we are at end of field, fatal error if not
923
924      procedure Checkc (C : Character);
925      --  Check next character is C. If so bump past it, if not fatal error
926
927      procedure Check_Unknown_Line;
928      --  If Ignore_Errors mode, then checks C to make sure that it is not
929      --  an unknown ALI line type characters, and if so, skips lines
930      --  until the first character of the line is one of these characters,
931      --  at which point it does a Getc to put that character in C. The
932      --  call has no effect if C is already an appropriate character.
933      --  If not in Ignore_Errors mode, a fatal error is signalled if the
934      --  line is unknown. Note that if C is an EOL on entry, the line is
935      --  skipped (it is assumed that blank lines are never significant).
936      --  If C is EOF on entry, the call has no effect (it is assumed that
937      --  the caller will properly handle this case).
938
939      procedure Fatal_Error;
940      --  Generate fatal error message for badly formatted ALI file if
941      --  Err is false, or raise Bad_ALI_Format if Err is True.
942
943      procedure Fatal_Error_Ignore;
944      pragma Inline (Fatal_Error_Ignore);
945      --  In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error
946
947      function Getc return Character;
948      --  Get next character, bumping P past the character obtained
949
950      function Get_File_Name
951        (Lower         : Boolean := False;
952         May_Be_Quoted : Boolean := False) return File_Name_Type;
953      --  Skip blanks, then scan out a file name (name is left in Name_Buffer
954      --  with length in Name_Len, as well as returning a File_Name_Type value.
955      --  If May_Be_Quoted is True and the first non blank character is '"',
956      --  then remove starting and ending quotes and undoubled internal quotes.
957      --  If lower is false, the case is unchanged, if Lower is True then the
958      --  result is forced to all lower case for systems where file names are
959      --  not case sensitive. This ensures that gnatbind works correctly
960      --  regardless of the case of the file name on all systems. The scan
961      --  is terminated by a end of line, space or horizontal tab. Any other
962      --  special characters are included in the returned name.
963
964      function Get_Name
965        (Ignore_Spaces  : Boolean := False;
966         Ignore_Special : Boolean := False;
967         May_Be_Quoted  : Boolean := False) return Name_Id;
968      --  Skip blanks, then scan out a name (name is left in Name_Buffer with
969      --  length in Name_Len, as well as being returned in Name_Id form).
970      --  If Lower is set to True then the Name_Buffer will be converted to
971      --  all lower case, for systems where file names are not case sensitive.
972      --  This ensures that gnatbind works correctly regardless of the case
973      --  of the file name on all systems. The termination condition depends
974      --  on the settings of Ignore_Spaces and Ignore_Special:
975      --
976      --    If Ignore_Spaces is False (normal case), then scan is terminated
977      --    by the normal end of field condition (EOL, space, horizontal tab)
978      --
979      --    If Ignore_Special is False (normal case), the scan is terminated by
980      --    a typeref bracket or an equal sign except for the special case of
981      --    an operator name starting with a double quote that is terminated
982      --    by another double quote.
983      --
984      --    If May_Be_Quoted is True and the first non blank character is '"'
985      --    the name is 'unquoted'. In this case Ignore_Special is ignored and
986      --    assumed to be True.
987      --
988      --  It is an error to set both Ignore_Spaces and Ignore_Special to True.
989      --  This function handles wide characters properly.
990
991      function Get_Nat return Nat;
992      --  Skip blanks, then scan out an unsigned integer value in Nat range
993      --  raises ALI_Reading_Error if the encoutered type is not natural.
994
995      function Get_Stamp return Time_Stamp_Type;
996      --  Skip blanks, then scan out a time stamp
997
998      function Get_Unit_Name return Unit_Name_Type;
999      --  Skip blanks, then scan out a file name (name is left in Name_Buffer
1000      --  with length in Name_Len, as well as returning a Unit_Name_Type value.
1001      --  The case is unchanged and terminated by a normal end of field.
1002
1003      function Nextc return Character;
1004      --  Return current character without modifying pointer P
1005
1006      procedure Get_Typeref
1007        (Current_File_Num : Sdep_Id;
1008         Ref             : out Tref_Kind;
1009         File_Num        : out Sdep_Id;
1010         Line            : out Nat;
1011         Ref_Type        : out Character;
1012         Col             : out Nat;
1013         Standard_Entity : out Name_Id);
1014      --  Parse the definition of a typeref (<...>, {...} or (...))
1015
1016      procedure Scan_Invocation_Graph_Line;
1017      --  Parse a single line that encodes a piece of the invocation graph
1018
1019      procedure Skip_Eol;
1020      --  Skip past spaces, then skip past end of line (fatal error if not
1021      --  at end of line). Also skips past any following blank lines.
1022
1023      procedure Skip_Line;
1024      --  Skip rest of current line and any following blank lines
1025
1026      procedure Skip_Space;
1027      --  Skip past white space (blanks or horizontal tab)
1028
1029      procedure Skipc;
1030      --  Skip past next character, does not affect value in C. This call
1031      --  is like calling Getc and ignoring the returned result.
1032
1033      ---------------------
1034      -- At_End_Of_Field --
1035      ---------------------
1036
1037      function At_End_Of_Field return Boolean is
1038      begin
1039         return Nextc <= ' ';
1040      end At_End_Of_Field;
1041
1042      ------------
1043      -- At_Eol --
1044      ------------
1045
1046      function At_Eol return Boolean is
1047      begin
1048         return Nextc = EOF or else Nextc = CR or else Nextc = LF;
1049      end At_Eol;
1050
1051      ---------------------------
1052      -- Check_At_End_Of_Field --
1053      ---------------------------
1054
1055      procedure Check_At_End_Of_Field is
1056      begin
1057         if not At_End_Of_Field then
1058            if Ignore_Errors then
1059               while Nextc > ' ' loop
1060                  P := P + 1;
1061               end loop;
1062            else
1063               Fatal_Error;
1064            end if;
1065         end if;
1066      end Check_At_End_Of_Field;
1067
1068      ------------------------
1069      -- Check_Unknown_Line --
1070      ------------------------
1071
1072      procedure Check_Unknown_Line is
1073      begin
1074         while C not in 'A' .. 'Z'
1075           or else not Known_ALI_Lines (C)
1076         loop
1077            if C = CR or else C = LF then
1078               Skip_Line;
1079               C := Nextc;
1080
1081            elsif C = EOF then
1082               return;
1083
1084            elsif Ignore_Errors then
1085               Skip_Line;
1086               C := Getc;
1087
1088            else
1089               Fatal_Error;
1090            end if;
1091         end loop;
1092      end Check_Unknown_Line;
1093
1094      ------------
1095      -- Checkc --
1096      ------------
1097
1098      procedure Checkc (C : Character) is
1099      begin
1100         if Nextc = C then
1101            P := P + 1;
1102         elsif Ignore_Errors then
1103            P := P + 1;
1104         else
1105            Fatal_Error;
1106         end if;
1107      end Checkc;
1108
1109      -----------------
1110      -- Fatal_Error --
1111      -----------------
1112
1113      procedure Fatal_Error is
1114         Ptr1 : Text_Ptr;
1115         Ptr2 : Text_Ptr;
1116         Col  : Int;
1117
1118         procedure Wchar (C : Character);
1119         --  Write a single character, replacing horizontal tab by spaces
1120
1121         procedure Wchar (C : Character) is
1122         begin
1123            if C = HT then
1124               loop
1125                  Wchar (' ');
1126                  exit when Col mod 8 = 0;
1127               end loop;
1128
1129            else
1130               Write_Char (C);
1131               Col := Col + 1;
1132            end if;
1133         end Wchar;
1134
1135      --  Start of processing for Fatal_Error
1136
1137      begin
1138         if Err then
1139            raise Bad_ALI_Format;
1140         end if;
1141
1142         Set_Standard_Error;
1143         Write_Str ("fatal error: file ");
1144         Write_Name (F);
1145         Write_Str (" is incorrectly formatted");
1146         Write_Eol;
1147
1148         Write_Str ("make sure you are using consistent versions " &
1149
1150         --  Split the following line so that it can easily be transformed for
1151         --  other back-ends where the compiler might have a different name.
1152
1153                    "of gcc/gnatbind");
1154
1155         Write_Eol;
1156
1157         --  Find start of line
1158
1159         Ptr1 := P;
1160         while Ptr1 > T'First
1161           and then T (Ptr1 - 1) /= CR
1162           and then T (Ptr1 - 1) /= LF
1163         loop
1164            Ptr1 := Ptr1 - 1;
1165         end loop;
1166
1167         Write_Int (Int (Line));
1168         Write_Str (". ");
1169
1170         if Line < 100 then
1171            Write_Char (' ');
1172         end if;
1173
1174         if Line < 10 then
1175            Write_Char (' ');
1176         end if;
1177
1178         Col := 0;
1179         Ptr2 := Ptr1;
1180
1181         while Ptr2 < T'Last
1182           and then T (Ptr2) /= CR
1183           and then T (Ptr2) /= LF
1184         loop
1185            Wchar (T (Ptr2));
1186            Ptr2 := Ptr2 + 1;
1187         end loop;
1188
1189         Write_Eol;
1190
1191         Write_Str ("     ");
1192         Col := 0;
1193
1194         while Ptr1 < P loop
1195            if T (Ptr1) = HT then
1196               Wchar (HT);
1197            else
1198               Wchar (' ');
1199            end if;
1200
1201            Ptr1 := Ptr1 + 1;
1202         end loop;
1203
1204         Wchar ('|');
1205         Write_Eol;
1206
1207         Exit_Program (E_Fatal);
1208      end Fatal_Error;
1209
1210      ------------------------
1211      -- Fatal_Error_Ignore --
1212      ------------------------
1213
1214      procedure Fatal_Error_Ignore is
1215      begin
1216         if not Ignore_Errors then
1217            Fatal_Error;
1218         end if;
1219      end Fatal_Error_Ignore;
1220
1221      -------------------
1222      -- Get_File_Name --
1223      -------------------
1224
1225      function Get_File_Name
1226        (Lower         : Boolean := False;
1227         May_Be_Quoted : Boolean := False) return File_Name_Type
1228      is
1229         F : Name_Id;
1230
1231      begin
1232         F := Get_Name (Ignore_Special => True,
1233                        May_Be_Quoted  => May_Be_Quoted);
1234
1235         --  Convert file name to all lower case if file names are not case
1236         --  sensitive. This ensures that we handle names in the canonical
1237         --  lower case format, regardless of the actual case.
1238
1239         if Lower and not File_Names_Case_Sensitive then
1240            Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1241            return Name_Find;
1242         else
1243            return File_Name_Type (F);
1244         end if;
1245      end Get_File_Name;
1246
1247      --------------
1248      -- Get_Name --
1249      --------------
1250
1251      function Get_Name
1252        (Ignore_Spaces  : Boolean := False;
1253         Ignore_Special : Boolean := False;
1254         May_Be_Quoted  : Boolean := False) return Name_Id
1255      is
1256         Char : Character;
1257
1258      begin
1259         Name_Len := 0;
1260         Skip_Space;
1261
1262         if At_Eol then
1263            if Ignore_Errors then
1264               return Error_Name;
1265            else
1266               Fatal_Error;
1267            end if;
1268         end if;
1269
1270         Char := Getc;
1271
1272         --  Deal with quoted characters
1273
1274         if May_Be_Quoted and then Char = '"' then
1275            loop
1276               if At_Eol then
1277                  if Ignore_Errors then
1278                     return Error_Name;
1279                  else
1280                     Fatal_Error;
1281                  end if;
1282               end if;
1283
1284               Char := Getc;
1285
1286               if Char = '"' then
1287                  if At_Eol then
1288                     exit;
1289
1290                  else
1291                     Char := Getc;
1292
1293                     if Char /= '"' then
1294                        P := P - 1;
1295                        exit;
1296                     end if;
1297                  end if;
1298               end if;
1299
1300               Add_Char_To_Name_Buffer (Char);
1301            end loop;
1302
1303         --  Other than case of quoted character
1304
1305         else
1306            P := P - 1;
1307            loop
1308               Add_Char_To_Name_Buffer (Getc);
1309
1310               exit when At_End_Of_Field and then not Ignore_Spaces;
1311
1312               if not Ignore_Special then
1313                  if Name_Buffer (1) = '"' then
1314                     exit when Name_Len > 1
1315                               and then Name_Buffer (Name_Len) = '"';
1316
1317                  else
1318                     --  Terminate on parens or angle brackets or equal sign
1319
1320                     exit when Nextc = '(' or else Nextc = ')'
1321                       or else Nextc = '{' or else Nextc = '}'
1322                       or else Nextc = '<' or else Nextc = '>'
1323                       or else Nextc = '=';
1324
1325                     --  Terminate on comma
1326
1327                     exit when Nextc = ',';
1328
1329                     --  Terminate if left bracket not part of wide char
1330                     --  sequence Note that we only recognize brackets
1331                     --  notation so far ???
1332
1333                     exit when Nextc = '[' and then T (P + 1) /= '"';
1334
1335                     --  Terminate if right bracket not part of wide char
1336                     --  sequence.
1337
1338                     exit when Nextc = ']' and then T (P - 1) /= '"';
1339                  end if;
1340               end if;
1341            end loop;
1342         end if;
1343
1344         return Name_Find;
1345      end Get_Name;
1346
1347      -------------------
1348      -- Get_Unit_Name --
1349      -------------------
1350
1351      function Get_Unit_Name return Unit_Name_Type is
1352      begin
1353         return Unit_Name_Type (Get_Name);
1354      end Get_Unit_Name;
1355
1356      -------------
1357      -- Get_Nat --
1358      -------------
1359
1360      function Get_Nat return Nat is
1361         V : Nat;
1362
1363      begin
1364         Skip_Space;
1365
1366         --  Check if we are on a number. In the case of bad ALI files, this
1367         --  may not be true.
1368
1369         if not (Nextc in '0' .. '9') then
1370            Fatal_Error;
1371         end if;
1372
1373         V := 0;
1374         loop
1375            V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0'));
1376
1377            exit when At_End_Of_Field;
1378            exit when Nextc < '0' or else Nextc > '9';
1379         end loop;
1380
1381         return V;
1382      end Get_Nat;
1383
1384      ---------------
1385      -- Get_Stamp --
1386      ---------------
1387
1388      function Get_Stamp return Time_Stamp_Type is
1389         T     : Time_Stamp_Type;
1390         Start : Integer;
1391
1392      begin
1393         Skip_Space;
1394
1395         if At_Eol then
1396            if Ignore_Errors then
1397               return Dummy_Time_Stamp;
1398            else
1399               Fatal_Error;
1400            end if;
1401         end if;
1402
1403         --  Following reads old style time stamp missing first two digits
1404
1405         if Nextc in '7' .. '9' then
1406            T (1) := '1';
1407            T (2) := '9';
1408            Start := 3;
1409
1410         --  Normal case of full year in time stamp
1411
1412         else
1413            Start := 1;
1414         end if;
1415
1416         for J in Start .. T'Last loop
1417            T (J) := Getc;
1418         end loop;
1419
1420         return T;
1421      end Get_Stamp;
1422
1423      -----------------
1424      -- Get_Typeref --
1425      -----------------
1426
1427      procedure Get_Typeref
1428        (Current_File_Num : Sdep_Id;
1429         Ref              : out Tref_Kind;
1430         File_Num         : out Sdep_Id;
1431         Line             : out Nat;
1432         Ref_Type         : out Character;
1433         Col              : out Nat;
1434         Standard_Entity  : out Name_Id)
1435      is
1436         N : Nat;
1437      begin
1438         case Nextc is
1439            when '<'    => Ref := Tref_Derived;
1440            when '('    => Ref := Tref_Access;
1441            when '{'    => Ref := Tref_Type;
1442            when others => Ref := Tref_None;
1443         end case;
1444
1445         --  Case of typeref field present
1446
1447         if Ref /= Tref_None then
1448            P := P + 1; -- skip opening bracket
1449
1450            if Nextc in 'a' .. 'z' then
1451               File_Num        := No_Sdep_Id;
1452               Line            := 0;
1453               Ref_Type        := ' ';
1454               Col             := 0;
1455               Standard_Entity := Get_Name (Ignore_Spaces => True);
1456            else
1457               N := Get_Nat;
1458
1459               if Nextc = '|' then
1460                  File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
1461                  P := P + 1;
1462                  N := Get_Nat;
1463               else
1464                  File_Num := Current_File_Num;
1465               end if;
1466
1467               Line            := N;
1468               Ref_Type        := Getc;
1469               Col             := Get_Nat;
1470               Standard_Entity := No_Name;
1471            end if;
1472
1473            --  ??? Temporary workaround for nested generics case:
1474            --     4i4 Directories{1|4I9[4|6[3|3]]}
1475            --  See C918-002
1476
1477            declare
1478               Nested_Brackets : Natural := 0;
1479
1480            begin
1481               loop
1482                  case Nextc is
1483                     when '[' =>
1484                        Nested_Brackets := Nested_Brackets + 1;
1485                     when ']' =>
1486                        Nested_Brackets := Nested_Brackets - 1;
1487                     when others =>
1488                        if Nested_Brackets = 0 then
1489                           exit;
1490                        end if;
1491                  end case;
1492
1493                  Skipc;
1494               end loop;
1495            end;
1496
1497            P := P + 1; -- skip closing bracket
1498            Skip_Space;
1499
1500         --  No typeref entry present
1501
1502         else
1503            File_Num        := No_Sdep_Id;
1504            Line            := 0;
1505            Ref_Type        := ' ';
1506            Col             := 0;
1507            Standard_Entity := No_Name;
1508         end if;
1509      end Get_Typeref;
1510
1511      ----------
1512      -- Getc --
1513      ----------
1514
1515      function Getc return Character is
1516      begin
1517         if P = T'Last then
1518            return EOF;
1519         else
1520            P := P + 1;
1521            return T (P - 1);
1522         end if;
1523      end Getc;
1524
1525      -----------
1526      -- Nextc --
1527      -----------
1528
1529      function Nextc return Character is
1530      begin
1531         return T (P);
1532      end Nextc;
1533
1534      --------------------------------
1535      -- Scan_Invocation_Graph_Line --
1536      --------------------------------
1537
1538      procedure Scan_Invocation_Graph_Line is
1539         procedure Scan_Invocation_Construct_Line;
1540         pragma Inline (Scan_Invocation_Construct_Line);
1541         --  Parse an invocation construct line and construct the corresponding
1542         --  construct. The following data structures are updated:
1543         --
1544         --    * Invocation_Constructs
1545         --    * Units
1546
1547         procedure Scan_Invocation_Graph_Attributes_Line;
1548         pragma Inline (Scan_Invocation_Graph_Attributes_Line);
1549         --  Parse an invocation-graph attributes line. The following data
1550         --  structures are updated:
1551         --
1552         --    * Units
1553
1554         procedure Scan_Invocation_Relation_Line;
1555         pragma Inline (Scan_Invocation_Relation_Line);
1556         --  Parse an invocation relation line and construct the corresponding
1557         --  relation. The following data structures are updated:
1558         --
1559         --    * Invocation_Relations
1560         --    * Units
1561
1562         function Scan_Invocation_Signature return Invocation_Signature_Id;
1563         pragma Inline (Scan_Invocation_Signature);
1564         --  Parse a single invocation signature while populating the following
1565         --  data structures:
1566         --
1567         --    * Invocation_Signatures
1568         --    * Sig_To_Sig_Map
1569
1570         ------------------------------------
1571         -- Scan_Invocation_Construct_Line --
1572         ------------------------------------
1573
1574         procedure Scan_Invocation_Construct_Line is
1575            Body_Placement : Declaration_Placement_Kind;
1576            Kind           : Invocation_Construct_Kind;
1577            Signature      : Invocation_Signature_Id;
1578            Spec_Placement : Declaration_Placement_Kind;
1579
1580         begin
1581            --  construct-kind
1582
1583            Kind := Code_To_Invocation_Construct_Kind (Getc);
1584            Checkc (' ');
1585            Skip_Space;
1586
1587            --  construct-spec-placement
1588
1589            Spec_Placement := Code_To_Declaration_Placement_Kind (Getc);
1590            Checkc (' ');
1591            Skip_Space;
1592
1593            --  construct-body-placement
1594
1595            Body_Placement := Code_To_Declaration_Placement_Kind (Getc);
1596            Checkc (' ');
1597            Skip_Space;
1598
1599            --  construct-signature
1600
1601            Signature := Scan_Invocation_Signature;
1602            Skip_Eol;
1603
1604            Add_Invocation_Construct
1605              (Body_Placement => Body_Placement,
1606               Kind           => Kind,
1607               Signature      => Signature,
1608               Spec_Placement => Spec_Placement);
1609         end Scan_Invocation_Construct_Line;
1610
1611         -------------------------------------------
1612         -- Scan_Invocation_Graph_Attributes_Line --
1613         -------------------------------------------
1614
1615         procedure Scan_Invocation_Graph_Attributes_Line is
1616         begin
1617            --  encoding-kind
1618
1619            Set_Invocation_Graph_Encoding
1620              (Code_To_Invocation_Graph_Encoding_Kind (Getc));
1621            Skip_Eol;
1622         end Scan_Invocation_Graph_Attributes_Line;
1623
1624         -----------------------------------
1625         -- Scan_Invocation_Relation_Line --
1626         -----------------------------------
1627
1628         procedure Scan_Invocation_Relation_Line is
1629            Extra   : Name_Id;
1630            Invoker : Invocation_Signature_Id;
1631            Kind    : Invocation_Kind;
1632            Target  : Invocation_Signature_Id;
1633
1634         begin
1635            --  relation-kind
1636
1637            Kind := Code_To_Invocation_Kind (Getc);
1638            Checkc (' ');
1639            Skip_Space;
1640
1641            --  (extra-name | "none")
1642
1643            Extra := Get_Name;
1644
1645            if Extra = Name_None then
1646               Extra := No_Name;
1647            end if;
1648
1649            Checkc (' ');
1650            Skip_Space;
1651
1652            --  invoker-signature
1653
1654            Invoker := Scan_Invocation_Signature;
1655            Checkc (' ');
1656            Skip_Space;
1657
1658            --  target-signature
1659
1660            Target := Scan_Invocation_Signature;
1661            Skip_Eol;
1662
1663            Add_Invocation_Relation
1664              (Extra   => Extra,
1665               Invoker => Invoker,
1666               Kind    => Kind,
1667               Target  => Target);
1668         end Scan_Invocation_Relation_Line;
1669
1670         -------------------------------
1671         -- Scan_Invocation_Signature --
1672         -------------------------------
1673
1674         function Scan_Invocation_Signature return Invocation_Signature_Id is
1675            Column    : Nat;
1676            Line      : Nat;
1677            Locations : Name_Id;
1678            Name      : Name_Id;
1679            Scope     : Name_Id;
1680
1681         begin
1682            --  [
1683
1684            Checkc ('[');
1685
1686            --  name
1687
1688            Name := Get_Name;
1689            Checkc (' ');
1690            Skip_Space;
1691
1692            --  scope
1693
1694            Scope := Get_Name;
1695            Checkc (' ');
1696            Skip_Space;
1697
1698            --  line
1699
1700            Line := Get_Nat;
1701            Checkc (' ');
1702            Skip_Space;
1703
1704            --  column
1705
1706            Column := Get_Nat;
1707            Checkc (' ');
1708            Skip_Space;
1709
1710            --  (locations | "none")
1711
1712            Locations := Get_Name;
1713
1714            if Locations = Name_None then
1715               Locations := No_Name;
1716            end if;
1717
1718            --  ]
1719
1720            Checkc (']');
1721
1722            --  Create an invocation signature from the scanned attributes
1723
1724            return
1725              Invocation_Signature_Of
1726                (Column    => Column,
1727                 Line      => Line,
1728                 Locations => Locations,
1729                 Name      => Name,
1730                 Scope     => Scope);
1731         end Scan_Invocation_Signature;
1732
1733         --  Local variables
1734
1735         Line : Invocation_Graph_Line_Kind;
1736
1737      --  Start of processing for Scan_Invocation_Graph_Line
1738
1739      begin
1740         if Ignore ('G') then
1741            return;
1742         end if;
1743
1744         Checkc (' ');
1745         Skip_Space;
1746
1747         --  line-kind
1748
1749         Line := Code_To_Invocation_Graph_Line_Kind (Getc);
1750         Checkc (' ');
1751         Skip_Space;
1752
1753         --  line-attributes
1754
1755         case Line is
1756            when Invocation_Construct_Line =>
1757               Scan_Invocation_Construct_Line;
1758
1759            when Invocation_Graph_Attributes_Line =>
1760               Scan_Invocation_Graph_Attributes_Line;
1761
1762            when Invocation_Relation_Line =>
1763               Scan_Invocation_Relation_Line;
1764         end case;
1765      end Scan_Invocation_Graph_Line;
1766
1767      --------------
1768      -- Skip_Eol --
1769      --------------
1770
1771      procedure Skip_Eol is
1772      begin
1773         Skip_Space;
1774
1775         if not At_Eol then
1776            if Ignore_Errors then
1777               while not At_Eol loop
1778                  P := P + 1;
1779               end loop;
1780            else
1781               Fatal_Error;
1782            end if;
1783         end if;
1784
1785         --  Loop to skip past blank lines (first time through skips this EOL)
1786
1787         while Nextc < ' ' and then Nextc /= EOF loop
1788            if Nextc = LF then
1789               Line := Line + 1;
1790            end if;
1791
1792            P := P + 1;
1793         end loop;
1794      end Skip_Eol;
1795
1796      ---------------
1797      -- Skip_Line --
1798      ---------------
1799
1800      procedure Skip_Line is
1801      begin
1802         while not At_Eol loop
1803            P := P + 1;
1804         end loop;
1805
1806         Skip_Eol;
1807      end Skip_Line;
1808
1809      ----------------
1810      -- Skip_Space --
1811      ----------------
1812
1813      procedure Skip_Space is
1814      begin
1815         while Nextc = ' ' or else Nextc = HT loop
1816            P := P + 1;
1817         end loop;
1818      end Skip_Space;
1819
1820      -----------
1821      -- Skipc --
1822      -----------
1823
1824      procedure Skipc is
1825      begin
1826         if P /= T'Last then
1827            P := P + 1;
1828         end if;
1829      end Skipc;
1830
1831   --  Start of processing for Scan_ALI
1832
1833   begin
1834      First_Sdep_Entry := Sdep.Last + 1;
1835
1836      --  Acquire lines to be ignored
1837
1838      if Read_Xref then
1839         Ignore :=
1840           ('T' | 'U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True);
1841
1842      --  Read_Lines parameter given
1843
1844      elsif Read_Lines /= "" then
1845         Ignore := ('U' => False, others => True);
1846
1847         for J in Read_Lines'Range loop
1848            Ignore (Read_Lines (J)) := False;
1849         end loop;
1850
1851      --  Process Ignore_Lines parameter
1852
1853      else
1854         Ignore := (others => False);
1855
1856         for J in Ignore_Lines'Range loop
1857            pragma Assert (Ignore_Lines (J) /= 'U');
1858            Ignore (Ignore_Lines (J)) := True;
1859         end loop;
1860      end if;
1861
1862      --  Setup ALI Table entry with appropriate defaults
1863
1864      ALIs.Increment_Last;
1865      Id := ALIs.Last;
1866      Set_Name_Table_Int (F, Int (Id));
1867
1868      ALIs.Table (Id) := (
1869        Afile                        => F,
1870        Compile_Errors               => False,
1871        First_Interrupt_State        => Interrupt_States.Last + 1,
1872        First_Sdep                   => No_Sdep_Id,
1873        First_Specific_Dispatching   => Specific_Dispatching.Last + 1,
1874        First_Unit                   => No_Unit_Id,
1875        GNATprove_Mode               => False,
1876        Invocation_Graph_Encoding    => No_Encoding,
1877        Last_Interrupt_State         => Interrupt_States.Last,
1878        Last_Sdep                    => No_Sdep_Id,
1879        Last_Specific_Dispatching    => Specific_Dispatching.Last,
1880        Last_Unit                    => No_Unit_Id,
1881        Locking_Policy               => ' ',
1882        Main_Priority                => -1,
1883        Main_CPU                     => -1,
1884        Main_Program                 => None,
1885        No_Component_Reordering      => False,
1886        No_Object                    => False,
1887        Normalize_Scalars            => False,
1888        Ofile_Full_Name              => Full_Object_File_Name,
1889        Partition_Elaboration_Policy => ' ',
1890        Queuing_Policy               => ' ',
1891        Restrictions                 => No_Restrictions,
1892        SAL_Interface                => False,
1893        Sfile                        => No_File,
1894        SSO_Default                  => ' ',
1895        Task_Dispatching_Policy      => ' ',
1896        Time_Slice_Value             => -1,
1897        WC_Encoding                  => 'b',
1898        Unit_Exception_Table         => False,
1899        Ver                          => (others => ' '),
1900        Ver_Len                      => 0,
1901        Frontend_Exceptions          => False,
1902        Zero_Cost_Exceptions         => False);
1903
1904      --  Now we acquire the input lines from the ALI file. Note that the
1905      --  convention in the following code is that as we enter each section,
1906      --  C is set to contain the first character of the following line.
1907
1908      C := Getc;
1909      Check_Unknown_Line;
1910
1911      --  Acquire library version
1912
1913      if C /= 'V' then
1914
1915         --  The V line missing really indicates trouble, most likely it
1916         --  means we don't have an ALI file at all, so here we give a
1917         --  fatal error even if we are in Ignore_Errors mode.
1918
1919         Fatal_Error;
1920
1921      elsif Ignore ('V') then
1922         Skip_Line;
1923
1924      else
1925         Checkc (' ');
1926         Skip_Space;
1927         Checkc ('"');
1928
1929         for J in 1 .. Ver_Len_Max loop
1930            C := Getc;
1931            exit when C = '"';
1932            ALIs.Table (Id).Ver (J) := C;
1933            ALIs.Table (Id).Ver_Len := J;
1934         end loop;
1935
1936         Skip_Eol;
1937      end if;
1938
1939      C := Getc;
1940      Check_Unknown_Line;
1941
1942      --  Acquire main program line if present
1943
1944      if C = 'M' then
1945         if Ignore ('M') then
1946            Skip_Line;
1947
1948         else
1949            Checkc (' ');
1950            Skip_Space;
1951
1952            C := Getc;
1953
1954            if C = 'F' then
1955               ALIs.Table (Id).Main_Program := Func;
1956            elsif C = 'P' then
1957               ALIs.Table (Id).Main_Program := Proc;
1958            else
1959               P := P - 1;
1960               Fatal_Error;
1961            end if;
1962
1963            Skip_Space;
1964
1965            if not At_Eol then
1966               if Nextc < 'A' then
1967                  ALIs.Table (Id).Main_Priority := Get_Nat;
1968               end if;
1969
1970               Skip_Space;
1971
1972               if Nextc = 'T' then
1973                  P := P + 1;
1974                  Checkc ('=');
1975                  ALIs.Table (Id).Time_Slice_Value := Get_Nat;
1976               end if;
1977
1978               Skip_Space;
1979
1980               if Nextc = 'C' then
1981                  P := P + 1;
1982                  Checkc ('=');
1983                  ALIs.Table (Id).Main_CPU := Get_Nat;
1984               end if;
1985
1986               Skip_Space;
1987
1988               Checkc ('W');
1989               Checkc ('=');
1990               ALIs.Table (Id).WC_Encoding := Getc;
1991            end if;
1992
1993            Skip_Eol;
1994         end if;
1995
1996         C := Getc;
1997      end if;
1998
1999      --  Acquire argument lines
2000
2001      First_Arg := Args.Last + 1;
2002
2003      A_Loop : loop
2004         Check_Unknown_Line;
2005         exit A_Loop when C /= 'A';
2006
2007         if Ignore ('A') then
2008            Skip_Line;
2009
2010         else
2011            Checkc (' ');
2012
2013            --  Scan out argument
2014
2015            Name_Len := 0;
2016            while not At_Eol loop
2017               Add_Char_To_Name_Buffer (Getc);
2018            end loop;
2019
2020            --  If -fstack-check, record that it occurred. Note that an
2021            --  additional string parameter can be specified, in the form of
2022            --  -fstack-check={no|generic|specific}. "no" means no checking,
2023            --  "generic" means force the use of old-style checking, and
2024            --  "specific" means use the best checking method.
2025
2026            if Name_Len >= 13
2027              and then Name_Buffer (1 .. 13) = "-fstack-check"
2028              and then Name_Buffer (1 .. Name_Len) /= "-fstack-check=no"
2029            then
2030               Stack_Check_Switch_Set := True;
2031            end if;
2032
2033            --  Store the argument
2034
2035            Args.Increment_Last;
2036            Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len));
2037
2038            Skip_Eol;
2039         end if;
2040
2041         C := Getc;
2042      end loop A_Loop;
2043
2044      --  Acquire P line
2045
2046      Check_Unknown_Line;
2047
2048      while C /= 'P' loop
2049         if Ignore_Errors then
2050            if C = EOF then
2051               Fatal_Error;
2052            else
2053               Skip_Line;
2054               C := Nextc;
2055            end if;
2056         else
2057            Fatal_Error;
2058         end if;
2059      end loop;
2060
2061      if Ignore ('P') then
2062         Skip_Line;
2063
2064      --  Process P line
2065
2066      else
2067         NS_Found := False;
2068
2069         while not At_Eol loop
2070            Checkc (' ');
2071            Skip_Space;
2072            C := Getc;
2073
2074            --  Processing for CE
2075
2076            if C = 'C' then
2077               Checkc ('E');
2078               ALIs.Table (Id).Compile_Errors := True;
2079
2080            --  Processing for DB
2081
2082            elsif C = 'D' then
2083               Checkc ('B');
2084               Detect_Blocking := True;
2085
2086            --  Processing for Ex
2087
2088            elsif C = 'E' then
2089               Partition_Elaboration_Policy_Specified := Getc;
2090               ALIs.Table (Id).Partition_Elaboration_Policy :=
2091                 Partition_Elaboration_Policy_Specified;
2092
2093            --  Processing for FX
2094
2095            elsif C = 'F' then
2096               C := Getc;
2097
2098               if C = 'X' then
2099                  ALIs.Table (Id).Frontend_Exceptions := True;
2100                  Frontend_Exceptions_Specified := True;
2101               else
2102                  Fatal_Error_Ignore;
2103               end if;
2104
2105            --  Processing for GP
2106
2107            elsif C = 'G' then
2108               Checkc ('P');
2109               GNATprove_Mode_Specified := True;
2110               ALIs.Table (Id).GNATprove_Mode := True;
2111
2112            --  Processing for Lx
2113
2114            elsif C = 'L' then
2115               Locking_Policy_Specified := Getc;
2116               ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
2117
2118            --  Processing for flags starting with N
2119
2120            elsif C = 'N' then
2121               C := Getc;
2122
2123               --  Processing for NC
2124
2125               if C = 'C' then
2126                  ALIs.Table (Id).No_Component_Reordering := True;
2127                  No_Component_Reordering_Specified := True;
2128
2129               --  Processing for NO
2130
2131               elsif C = 'O' then
2132                  ALIs.Table (Id).No_Object := True;
2133                  No_Object_Specified := True;
2134
2135               --  Processing for NR
2136
2137               elsif C = 'R' then
2138                  No_Run_Time_Mode           := True;
2139                  Configurable_Run_Time_Mode := True;
2140
2141               --  Processing for NS
2142
2143               elsif C = 'S' then
2144                  ALIs.Table (Id).Normalize_Scalars := True;
2145                  Normalize_Scalars_Specified := True;
2146                  NS_Found := True;
2147
2148               --  Invalid switch starting with N
2149
2150               else
2151                  Fatal_Error_Ignore;
2152               end if;
2153
2154            --  Processing for OH/OL
2155
2156            elsif C = 'O' then
2157               C := Getc;
2158
2159               if C = 'L' or else C = 'H' then
2160                  ALIs.Table (Id).SSO_Default := C;
2161                  SSO_Default_Specified := True;
2162
2163               else
2164                  Fatal_Error_Ignore;
2165               end if;
2166
2167            --  Processing for Qx
2168
2169            elsif C = 'Q' then
2170               Queuing_Policy_Specified := Getc;
2171               ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
2172
2173            --  Processing for flags starting with S
2174
2175            elsif C = 'S' then
2176               C := Getc;
2177
2178               --  Processing for SL
2179
2180               if C = 'L' then
2181                  ALIs.Table (Id).SAL_Interface := True;
2182
2183               --  Processing for SS
2184
2185               elsif C = 'S' then
2186                  Opt.Sec_Stack_Used := True;
2187
2188               --  Invalid switch starting with S
2189
2190               else
2191                  Fatal_Error_Ignore;
2192               end if;
2193
2194            --  Processing for Tx
2195
2196            elsif C = 'T' then
2197               Task_Dispatching_Policy_Specified := Getc;
2198               ALIs.Table (Id).Task_Dispatching_Policy :=
2199                 Task_Dispatching_Policy_Specified;
2200
2201            --  Processing for switch starting with U
2202
2203            elsif C = 'U' then
2204               C := Getc;
2205
2206               --  Processing for UA
2207
2208               if C  = 'A' then
2209                  Unreserve_All_Interrupts_Specified := True;
2210
2211               --  Processing for UX
2212
2213               elsif C = 'X' then
2214                  ALIs.Table (Id).Unit_Exception_Table := True;
2215
2216               --  Invalid switches starting with U
2217
2218               else
2219                  Fatal_Error_Ignore;
2220               end if;
2221
2222            --  Processing for ZX
2223
2224            elsif C = 'Z' then
2225               C := Getc;
2226
2227               if C = 'X' then
2228                  ALIs.Table (Id).Zero_Cost_Exceptions := True;
2229                  Zero_Cost_Exceptions_Specified := True;
2230               else
2231                  Fatal_Error_Ignore;
2232               end if;
2233
2234            --  Invalid parameter
2235
2236            else
2237               C := Getc;
2238               Fatal_Error_Ignore;
2239            end if;
2240         end loop;
2241
2242         if not NS_Found then
2243            No_Normalize_Scalars_Specified := True;
2244         end if;
2245
2246         Skip_Eol;
2247      end if;
2248
2249      C := Getc;
2250      Check_Unknown_Line;
2251
2252      --  Loop to skip to first restrictions line
2253
2254      while C /= 'R' loop
2255         if Ignore_Errors then
2256            if C = EOF then
2257               Fatal_Error;
2258            else
2259               Skip_Line;
2260               C := Nextc;
2261            end if;
2262         else
2263            Fatal_Error;
2264         end if;
2265      end loop;
2266
2267      --  Ignore all 'R' lines if that is required
2268
2269      if Ignore ('R') then
2270         while C = 'R' loop
2271            Skip_Line;
2272            C := Getc;
2273         end loop;
2274
2275      --  Here we process the restrictions lines (other than unit name cases)
2276
2277      else
2278         Scan_Restrictions : declare
2279            Save_R : constant Restrictions_Info := Cumulative_Restrictions;
2280            --  Save cumulative restrictions in case we have a fatal error
2281
2282            Bad_R_Line : exception;
2283            --  Signal bad restrictions line (raised on unexpected character)
2284
2285            Typ : Character;
2286            R   : Restriction_Id;
2287            N   : Natural;
2288
2289         begin
2290            --  Named restriction case
2291
2292            if Nextc = 'N' then
2293               Skip_Line;
2294               C := Getc;
2295
2296               --  Loop through RR and RV lines
2297
2298               while C = 'R' and then Nextc /= ' ' loop
2299                  Typ := Getc;
2300                  Checkc (' ');
2301
2302                  --  Acquire restriction name
2303
2304                  Name_Len := 0;
2305                  while not At_Eol and then Nextc /= '=' loop
2306                     Name_Len := Name_Len + 1;
2307                     Name_Buffer (Name_Len) := Getc;
2308                  end loop;
2309
2310                  --  Now search list of restrictions to find match
2311
2312                  declare
2313                     RN : String renames Name_Buffer (1 .. Name_Len);
2314
2315                  begin
2316                     R := Restriction_Id'First;
2317                     while R /= Not_A_Restriction_Id loop
2318                        if Restriction_Id'Image (R) = RN then
2319                           goto R_Found;
2320                        end if;
2321
2322                        R := Restriction_Id'Succ (R);
2323                     end loop;
2324
2325                     --  We don't recognize the restriction. This might be
2326                     --  thought of as an error, and it really is, but we
2327                     --  want to allow building with inconsistent versions
2328                     --  of the binder and ali files (see comments at the
2329                     --  start of package System.Rident), so we just ignore
2330                     --  this situation.
2331
2332                     goto Done_With_Restriction_Line;
2333                  end;
2334
2335                  <<R_Found>>
2336
2337                  case R is
2338
2339                     --  Boolean restriction case
2340
2341                     when All_Boolean_Restrictions =>
2342                        case Typ is
2343                           when 'V' =>
2344                              ALIs.Table (Id).Restrictions.Violated (R) :=
2345                                True;
2346                              Cumulative_Restrictions.Violated (R) := True;
2347
2348                           when 'R' =>
2349                              ALIs.Table (Id).Restrictions.Set (R) := True;
2350                              Cumulative_Restrictions.Set (R) := True;
2351
2352                           when others =>
2353                              raise Bad_R_Line;
2354                        end case;
2355
2356                     --  Parameter restriction case
2357
2358                     when All_Parameter_Restrictions =>
2359                        if At_Eol or else Nextc /= '=' then
2360                           raise Bad_R_Line;
2361                        else
2362                           Skipc;
2363                        end if;
2364
2365                        N := Natural (Get_Nat);
2366
2367                        case Typ is
2368
2369                           --  Restriction set
2370
2371                           when 'R' =>
2372                              ALIs.Table (Id).Restrictions.Set (R) := True;
2373                              ALIs.Table (Id).Restrictions.Value (R) := N;
2374
2375                              if Cumulative_Restrictions.Set (R) then
2376                                 Cumulative_Restrictions.Value (R) :=
2377                                   Integer'Min
2378                                     (Cumulative_Restrictions.Value (R), N);
2379                              else
2380                                 Cumulative_Restrictions.Set (R) := True;
2381                                 Cumulative_Restrictions.Value (R) := N;
2382                              end if;
2383
2384                           --  Restriction violated
2385
2386                           when 'V' =>
2387                              ALIs.Table (Id).Restrictions.Violated (R) :=
2388                                True;
2389                              Cumulative_Restrictions.Violated (R) := True;
2390                              ALIs.Table (Id).Restrictions.Count (R) := N;
2391
2392                              --  Checked Max_Parameter case
2393
2394                              if R in Checked_Max_Parameter_Restrictions then
2395                                 Cumulative_Restrictions.Count (R) :=
2396                                   Integer'Max
2397                                     (Cumulative_Restrictions.Count (R), N);
2398
2399                              --  Other checked parameter cases
2400
2401                              else
2402                                 declare
2403                                    pragma Unsuppress (Overflow_Check);
2404
2405                                 begin
2406                                    Cumulative_Restrictions.Count (R) :=
2407                                      Cumulative_Restrictions.Count (R) + N;
2408
2409                                 exception
2410                                    when Constraint_Error =>
2411
2412                                       --  A constraint error comes from the
2413                                       --  addition. We reset to the maximum
2414                                       --  and indicate that the real value
2415                                       --  is now unknown.
2416
2417                                       Cumulative_Restrictions.Value (R) :=
2418                                         Integer'Last;
2419                                       Cumulative_Restrictions.Unknown (R) :=
2420                                         True;
2421                                 end;
2422                              end if;
2423
2424                              --  Deal with + case
2425
2426                              if Nextc = '+' then
2427                                 Skipc;
2428                                 ALIs.Table (Id).Restrictions.Unknown (R) :=
2429                                   True;
2430                                 Cumulative_Restrictions.Unknown (R) := True;
2431                              end if;
2432
2433                           --  Other than 'R' or 'V'
2434
2435                           when others =>
2436                              raise Bad_R_Line;
2437                        end case;
2438
2439                        if not At_Eol then
2440                           raise Bad_R_Line;
2441                        end if;
2442
2443                     --  Bizarre error case NOT_A_RESTRICTION
2444
2445                     when Not_A_Restriction_Id =>
2446                        raise Bad_R_Line;
2447                  end case;
2448
2449                  if not At_Eol then
2450                     raise Bad_R_Line;
2451                  end if;
2452
2453               <<Done_With_Restriction_Line>>
2454                  Skip_Line;
2455                  C := Getc;
2456               end loop;
2457
2458            --  Positional restriction case
2459
2460            else
2461               Checkc (' ');
2462               Skip_Space;
2463
2464               --  Acquire information for boolean restrictions
2465
2466               for R in All_Boolean_Restrictions loop
2467                  C := Getc;
2468
2469                  case C is
2470                     when 'v' =>
2471                        ALIs.Table (Id).Restrictions.Violated (R) := True;
2472                        Cumulative_Restrictions.Violated (R) := True;
2473
2474                     when 'r' =>
2475                        ALIs.Table (Id).Restrictions.Set (R) := True;
2476                        Cumulative_Restrictions.Set (R) := True;
2477
2478                     when 'n' =>
2479                        null;
2480
2481                     when others =>
2482                        raise Bad_R_Line;
2483                  end case;
2484               end loop;
2485
2486               --  Acquire information for parameter restrictions
2487
2488               for RP in All_Parameter_Restrictions loop
2489                  case Getc is
2490                     when 'n' =>
2491                        null;
2492
2493                     when 'r' =>
2494                        ALIs.Table (Id).Restrictions.Set (RP) := True;
2495
2496                        declare
2497                           N : constant Integer := Integer (Get_Nat);
2498                        begin
2499                           ALIs.Table (Id).Restrictions.Value (RP) := N;
2500
2501                           if Cumulative_Restrictions.Set (RP) then
2502                              Cumulative_Restrictions.Value (RP) :=
2503                                Integer'Min
2504                                  (Cumulative_Restrictions.Value (RP), N);
2505                           else
2506                              Cumulative_Restrictions.Set (RP) := True;
2507                              Cumulative_Restrictions.Value (RP) := N;
2508                           end if;
2509                        end;
2510
2511                     when others =>
2512                        raise Bad_R_Line;
2513                  end case;
2514
2515                  --  Acquire restrictions violations information
2516
2517                  case Getc is
2518
2519                  when 'n' =>
2520                     null;
2521
2522                  when 'v' =>
2523                     ALIs.Table (Id).Restrictions.Violated (RP) := True;
2524                     Cumulative_Restrictions.Violated (RP) := True;
2525
2526                     declare
2527                        N : constant Integer := Integer (Get_Nat);
2528
2529                     begin
2530                        ALIs.Table (Id).Restrictions.Count (RP) := N;
2531
2532                        if RP in Checked_Max_Parameter_Restrictions then
2533                           Cumulative_Restrictions.Count (RP) :=
2534                             Integer'Max
2535                               (Cumulative_Restrictions.Count (RP), N);
2536
2537                        else
2538                           declare
2539                              pragma Unsuppress (Overflow_Check);
2540
2541                           begin
2542                              Cumulative_Restrictions.Count (RP) :=
2543                                Cumulative_Restrictions.Count (RP) + N;
2544
2545                           exception
2546                              when Constraint_Error =>
2547
2548                                 --  A constraint error comes from the add. We
2549                                 --  reset to the maximum and indicate that the
2550                                 --  real value is now unknown.
2551
2552                                 Cumulative_Restrictions.Value (RP) :=
2553                                   Integer'Last;
2554                                 Cumulative_Restrictions.Unknown (RP) := True;
2555                           end;
2556                        end if;
2557
2558                        if Nextc = '+' then
2559                           Skipc;
2560                           ALIs.Table (Id).Restrictions.Unknown (RP) := True;
2561                           Cumulative_Restrictions.Unknown (RP) := True;
2562                        end if;
2563                     end;
2564
2565                  when others =>
2566                     raise Bad_R_Line;
2567                  end case;
2568               end loop;
2569
2570               if not At_Eol then
2571                  raise Bad_R_Line;
2572               else
2573                  Skip_Line;
2574                  C := Getc;
2575               end if;
2576            end if;
2577
2578         --  Here if error during scanning of restrictions line
2579
2580         exception
2581            when Bad_R_Line =>
2582
2583               --  In Ignore_Errors mode, undo any changes to restrictions
2584               --  from this unit, and continue on, skipping remaining R
2585               --  lines for this unit.
2586
2587               if Ignore_Errors then
2588                  Cumulative_Restrictions := Save_R;
2589                  ALIs.Table (Id).Restrictions := No_Restrictions;
2590
2591                  loop
2592                     Skip_Eol;
2593                     C := Getc;
2594                     exit when C /= 'R';
2595                  end loop;
2596
2597               --  In normal mode, this is a fatal error
2598
2599               else
2600                  Fatal_Error;
2601               end if;
2602         end Scan_Restrictions;
2603      end if;
2604
2605      --  Acquire additional restrictions (No_Dependence) lines if present
2606
2607      while C = 'R' loop
2608         if Ignore ('R') then
2609            Skip_Line;
2610         else
2611            Skip_Space;
2612            No_Deps.Append ((Id, Get_Name));
2613            Skip_Eol;
2614         end if;
2615
2616         C := Getc;
2617      end loop;
2618
2619      --  Acquire 'I' lines if present
2620
2621      Check_Unknown_Line;
2622
2623      while C = 'I' loop
2624         if Ignore ('I') then
2625            Skip_Line;
2626
2627         else
2628            declare
2629               Int_Num : Nat;
2630               I_State : Character;
2631               Line_No : Nat;
2632
2633            begin
2634               Int_Num := Get_Nat;
2635               Skip_Space;
2636               I_State := Getc;
2637               Line_No := Get_Nat;
2638
2639               Interrupt_States.Append (
2640                 (Interrupt_Id    => Int_Num,
2641                  Interrupt_State => I_State,
2642                  IS_Pragma_Line  => Line_No));
2643
2644               ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last;
2645               Skip_Eol;
2646            end;
2647         end if;
2648
2649         C := Getc;
2650      end loop;
2651
2652      --  Acquire 'S' lines if present
2653
2654      Check_Unknown_Line;
2655
2656      while C = 'S' loop
2657         if Ignore ('S') then
2658            Skip_Line;
2659
2660         else
2661            declare
2662               Policy     : Character;
2663               First_Prio : Nat;
2664               Last_Prio  : Nat;
2665               Line_No    : Nat;
2666
2667            begin
2668               Checkc (' ');
2669               Skip_Space;
2670
2671               Policy := Getc;
2672               Skip_Space;
2673               First_Prio := Get_Nat;
2674               Last_Prio := Get_Nat;
2675               Line_No := Get_Nat;
2676
2677               Specific_Dispatching.Append (
2678                 (Dispatching_Policy => Policy,
2679                  First_Priority     => First_Prio,
2680                  Last_Priority      => Last_Prio,
2681                  PSD_Pragma_Line    => Line_No));
2682
2683               ALIs.Table (Id).Last_Specific_Dispatching :=
2684                 Specific_Dispatching.Last;
2685
2686               Skip_Eol;
2687            end;
2688         end if;
2689
2690         C := Getc;
2691      end loop;
2692
2693      --  Loop to acquire unit entries
2694
2695      U_Loop : loop
2696         Check_Unknown_Line;
2697         exit U_Loop when C /= 'U';
2698
2699         --  Note: as per spec, we never ignore U lines
2700
2701         Checkc (' ');
2702         Skip_Space;
2703         Units.Increment_Last;
2704
2705         if ALIs.Table (Id).First_Unit = No_Unit_Id then
2706            ALIs.Table (Id).First_Unit := Units.Last;
2707         end if;
2708
2709         declare
2710            UL : Unit_Record renames Units.Table (Units.Last);
2711
2712         begin
2713            UL.Uname                      := Get_Unit_Name;
2714            UL.Predefined                 := Is_Predefined_Unit;
2715            UL.Internal                   := Is_Internal_Unit;
2716            UL.My_ALI                     := Id;
2717            UL.Sfile                      := Get_File_Name (Lower => True);
2718            UL.Pure                       := False;
2719            UL.Preelab                    := False;
2720            UL.No_Elab                    := False;
2721            UL.Shared_Passive             := False;
2722            UL.RCI                        := False;
2723            UL.Remote_Types               := False;
2724            UL.Serious_Errors             := False;
2725            UL.Has_RACW                   := False;
2726            UL.Init_Scalars               := False;
2727            UL.Is_Generic                 := False;
2728            UL.Icasing                    := Mixed_Case;
2729            UL.Kcasing                    := All_Lower_Case;
2730            UL.Dynamic_Elab               := False;
2731            UL.Elaborate_Body             := False;
2732            UL.Set_Elab_Entity            := False;
2733            UL.Version                    := "00000000";
2734            UL.First_With                 := Withs.Last + 1;
2735            UL.First_Arg                  := First_Arg;
2736            UL.First_Invocation_Construct := Invocation_Constructs.Last + 1;
2737            UL.Last_Invocation_Construct  := No_Invocation_Construct;
2738            UL.First_Invocation_Relation  := Invocation_Relations.Last + 1;
2739            UL.Last_Invocation_Relation   := No_Invocation_Relation;
2740            UL.Elab_Position              := 0;
2741            UL.SAL_Interface              := ALIs.Table (Id).SAL_Interface;
2742            UL.Directly_Scanned           := Directly_Scanned;
2743            UL.Body_Needed_For_SAL        := False;
2744            UL.Elaborate_Body_Desirable   := False;
2745            UL.Optimize_Alignment         := 'O';
2746            UL.Has_Finalizer              := False;
2747            UL.Primary_Stack_Count        := 0;
2748            UL.Sec_Stack_Count            := 0;
2749
2750            if Debug_Flag_U then
2751               Write_Str (" ----> reading unit ");
2752               Write_Int (Int (Units.Last));
2753               Write_Str ("  ");
2754               Write_Unit_Name (UL.Uname);
2755               Write_Str (" from file ");
2756               Write_Name (UL.Sfile);
2757               Write_Eol;
2758            end if;
2759         end;
2760
2761         --  Check for duplicated unit in different files
2762
2763         declare
2764            Info : constant Int := Get_Name_Table_Int
2765                                     (Units.Table (Units.Last).Uname);
2766         begin
2767            if Info /= 0
2768              and then Units.Table (Units.Last).Sfile /=
2769                       Units.Table (Unit_Id (Info)).Sfile
2770            then
2771               --  If Err is set then ignore duplicate unit name. This is the
2772               --  case of a call from gnatmake, where the situation can arise
2773               --  from substitution of source files. In such situations, the
2774               --  processing in gnatmake will always result in any required
2775               --  recompilations in any case, and if we consider this to be
2776               --  an error we get strange cases (for example when a generic
2777               --  instantiation is replaced by a normal package) where we
2778               --  read the old ali file, decide to recompile, and then decide
2779               --  that the old and new ali files are incompatible.
2780
2781               if Err then
2782                  null;
2783
2784               --  If Err is not set, then this is a fatal error. This is
2785               --  the case of being called from the binder, where we must
2786               --  definitely diagnose this as an error.
2787
2788               else
2789                  Set_Standard_Error;
2790                  Write_Str ("error: duplicate unit name: ");
2791                  Write_Eol;
2792
2793                  Write_Str ("error: unit """);
2794                  Write_Unit_Name (Units.Table (Units.Last).Uname);
2795                  Write_Str (""" found in file """);
2796                  Write_Name_Decoded (Units.Table (Units.Last).Sfile);
2797                  Write_Char ('"');
2798                  Write_Eol;
2799
2800                  Write_Str ("error: unit """);
2801                  Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
2802                  Write_Str (""" found in file """);
2803                  Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
2804                  Write_Char ('"');
2805                  Write_Eol;
2806
2807                  Exit_Program (E_Fatal);
2808               end if;
2809            end if;
2810         end;
2811
2812         Set_Name_Table_Int
2813           (Units.Table (Units.Last).Uname, Int (Units.Last));
2814
2815         --  Scan out possible version and other parameters
2816
2817         loop
2818            Skip_Space;
2819            exit when At_Eol;
2820            C := Getc;
2821
2822            --  Version field
2823
2824            if C in '0' .. '9' or else C in 'a' .. 'f' then
2825               Units.Table (Units.Last).Version (1) := C;
2826
2827               for J in 2 .. 8 loop
2828                  C := Getc;
2829                  Units.Table (Units.Last).Version (J) := C;
2830               end loop;
2831
2832            --  BD/BN parameters
2833
2834            elsif C = 'B' then
2835               C := Getc;
2836
2837               if C = 'D' then
2838                  Check_At_End_Of_Field;
2839                  Units.Table (Units.Last).Elaborate_Body_Desirable := True;
2840
2841               elsif C = 'N' then
2842                  Check_At_End_Of_Field;
2843                  Units.Table (Units.Last).Body_Needed_For_SAL := True;
2844
2845               else
2846                  Fatal_Error_Ignore;
2847               end if;
2848
2849            --  DE parameter (Dynamic elaboration checks)
2850
2851            elsif C = 'D' then
2852               C := Getc;
2853
2854               if C = 'E' then
2855                  Check_At_End_Of_Field;
2856                  Units.Table (Units.Last).Dynamic_Elab := True;
2857                  Dynamic_Elaboration_Checks_Specified := True;
2858               else
2859                  Fatal_Error_Ignore;
2860               end if;
2861
2862            --  EB/EE parameters
2863
2864            elsif C = 'E' then
2865               C := Getc;
2866
2867               if C = 'B' then
2868                  Units.Table (Units.Last).Elaborate_Body := True;
2869               elsif C = 'E' then
2870                  Units.Table (Units.Last).Set_Elab_Entity := True;
2871               else
2872                  Fatal_Error_Ignore;
2873               end if;
2874
2875               Check_At_End_Of_Field;
2876
2877            --  GE parameter (generic)
2878
2879            elsif C = 'G' then
2880               C := Getc;
2881
2882               if C = 'E' then
2883                  Check_At_End_Of_Field;
2884                  Units.Table (Units.Last).Is_Generic := True;
2885               else
2886                  Fatal_Error_Ignore;
2887               end if;
2888
2889            --  IL/IS/IU parameters
2890
2891            elsif C = 'I' then
2892               C := Getc;
2893
2894               if C = 'L' then
2895                  Units.Table (Units.Last).Icasing := All_Lower_Case;
2896               elsif C = 'S' then
2897                  Units.Table (Units.Last).Init_Scalars := True;
2898                  Initialize_Scalars_Used := True;
2899               elsif C = 'U' then
2900                  Units.Table (Units.Last).Icasing := All_Upper_Case;
2901               else
2902                  Fatal_Error_Ignore;
2903               end if;
2904
2905               Check_At_End_Of_Field;
2906
2907            --  KM/KU parameters
2908
2909            elsif C = 'K' then
2910               C := Getc;
2911
2912               if C = 'M' then
2913                  Units.Table (Units.Last).Kcasing := Mixed_Case;
2914               elsif C = 'U' then
2915                  Units.Table (Units.Last).Kcasing := All_Upper_Case;
2916               else
2917                  Fatal_Error_Ignore;
2918               end if;
2919
2920               Check_At_End_Of_Field;
2921
2922            --  NE parameter
2923
2924            elsif C = 'N' then
2925               C := Getc;
2926
2927               if C = 'E' then
2928                  Units.Table (Units.Last).No_Elab := True;
2929                  Check_At_End_Of_Field;
2930               else
2931                  Fatal_Error_Ignore;
2932               end if;
2933
2934            --  PF/PR/PU/PK parameters
2935
2936            elsif C = 'P' then
2937               C := Getc;
2938
2939               if C = 'F' then
2940                  Units.Table (Units.Last).Has_Finalizer := True;
2941               elsif C = 'R' then
2942                  Units.Table (Units.Last).Preelab := True;
2943               elsif C = 'U' then
2944                  Units.Table (Units.Last).Pure := True;
2945               elsif C = 'K' then
2946                  Units.Table (Units.Last).Unit_Kind := 'p';
2947               else
2948                  Fatal_Error_Ignore;
2949               end if;
2950
2951               Check_At_End_Of_Field;
2952
2953            --  OL/OO/OS/OT parameters
2954
2955            elsif C = 'O' then
2956               C := Getc;
2957
2958               if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then
2959                  Units.Table (Units.Last).Optimize_Alignment := C;
2960               else
2961                  Fatal_Error_Ignore;
2962               end if;
2963
2964               Check_At_End_Of_Field;
2965
2966            --  RC/RT parameters
2967
2968            elsif C = 'R' then
2969               C := Getc;
2970
2971               if C = 'C' then
2972                  Units.Table (Units.Last).RCI := True;
2973               elsif C = 'T' then
2974                  Units.Table (Units.Last).Remote_Types := True;
2975               elsif C = 'A' then
2976                  Units.Table (Units.Last).Has_RACW := True;
2977               else
2978                  Fatal_Error_Ignore;
2979               end if;
2980
2981               Check_At_End_Of_Field;
2982
2983            --  SE/SP/SU parameters
2984
2985            elsif C = 'S' then
2986               C := Getc;
2987
2988               if C = 'E' then
2989                  Units.Table (Units.Last).Serious_Errors := True;
2990               elsif C = 'P' then
2991                  Units.Table (Units.Last).Shared_Passive := True;
2992               elsif C = 'U' then
2993                  Units.Table (Units.Last).Unit_Kind := 's';
2994               else
2995                  Fatal_Error_Ignore;
2996               end if;
2997
2998               Check_At_End_Of_Field;
2999
3000            else
3001               C := Getc;
3002               Fatal_Error_Ignore;
3003            end if;
3004         end loop;
3005
3006         Skip_Eol;
3007
3008         C := Getc;
3009
3010         --  Scan out With lines for this unit
3011
3012         With_Loop : loop
3013            Check_Unknown_Line;
3014            exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z';
3015
3016            if Ignore ('W') then
3017               Skip_Line;
3018
3019            else
3020               Checkc (' ');
3021               Skip_Space;
3022               Withs.Increment_Last;
3023               Withs.Table (Withs.Last).Uname              := Get_Unit_Name;
3024               Withs.Table (Withs.Last).Elaborate          := False;
3025               Withs.Table (Withs.Last).Elaborate_All      := False;
3026               Withs.Table (Withs.Last).Elab_Desirable     := False;
3027               Withs.Table (Withs.Last).Elab_All_Desirable := False;
3028               Withs.Table (Withs.Last).SAL_Interface      := False;
3029               Withs.Table (Withs.Last).Limited_With       := (C = 'Y');
3030               Withs.Table (Withs.Last).Implicit_With      := (C = 'Z');
3031
3032               --  Generic case with no object file available
3033
3034               if At_Eol then
3035                  Withs.Table (Withs.Last).Sfile := No_File;
3036                  Withs.Table (Withs.Last).Afile := No_File;
3037
3038               --  Normal case
3039
3040               else
3041                  Withs.Table (Withs.Last).Sfile := Get_File_Name
3042                                                      (Lower => True);
3043                  Withs.Table (Withs.Last).Afile := Get_File_Name
3044                                                      (Lower => True);
3045
3046                  --  Scan out possible E, EA, ED, and AD parameters
3047
3048                  while not At_Eol loop
3049                     Skip_Space;
3050
3051                     if Nextc = 'A' then
3052                        P := P + 1;
3053                        Checkc ('D');
3054                        Check_At_End_Of_Field;
3055
3056                        --  Store AD indication unless ignore required
3057
3058                        if not Ignore_ED then
3059                           Withs.Table (Withs.Last).Elab_All_Desirable := True;
3060                        end if;
3061
3062                     elsif Nextc = 'E' then
3063                        P := P + 1;
3064
3065                        if At_End_Of_Field then
3066                           Withs.Table (Withs.Last).Elaborate := True;
3067
3068                        elsif Nextc = 'A' then
3069                           P := P + 1;
3070                           Check_At_End_Of_Field;
3071                           Withs.Table (Withs.Last).Elaborate_All := True;
3072
3073                        else
3074                           Checkc ('D');
3075                           Check_At_End_Of_Field;
3076
3077                           --  Store ED indication unless ignore required
3078
3079                           if not Ignore_ED then
3080                              Withs.Table (Withs.Last).Elab_Desirable :=
3081                                True;
3082                           end if;
3083                        end if;
3084
3085                     else
3086                        Fatal_Error;
3087                     end if;
3088                  end loop;
3089               end if;
3090
3091               Skip_Eol;
3092            end if;
3093
3094            C := Getc;
3095         end loop With_Loop;
3096
3097         Units.Table (Units.Last).Last_With := Withs.Last;
3098         Units.Table (Units.Last).Last_Arg  := Args.Last;
3099
3100         --  Scan out task stack information for the unit if present
3101
3102         Check_Unknown_Line;
3103
3104         if C = 'T' then
3105            if Ignore ('T') then
3106               Skip_Line;
3107
3108            else
3109               Checkc (' ');
3110               Skip_Space;
3111
3112               Units.Table (Units.Last).Primary_Stack_Count := Get_Nat;
3113               Skip_Space;
3114               Units.Table (Units.Last).Sec_Stack_Count := Get_Nat;
3115               Skip_Space;
3116               Skip_Eol;
3117            end if;
3118
3119            C := Getc;
3120         end if;
3121
3122         --  If there are linker options lines present, scan them
3123
3124         Name_Len := 0;
3125
3126         Linker_Options_Loop : loop
3127            Check_Unknown_Line;
3128            exit Linker_Options_Loop when C /= 'L';
3129
3130            if Ignore ('L') then
3131               Skip_Line;
3132
3133            else
3134               Checkc (' ');
3135               Skip_Space;
3136               Checkc ('"');
3137
3138               loop
3139                  C := Getc;
3140
3141                  if C < Character'Val (16#20#)
3142                    or else C > Character'Val (16#7E#)
3143                  then
3144                     Fatal_Error_Ignore;
3145
3146                  elsif C = '{' then
3147                     C := Character'Val (0);
3148
3149                     declare
3150                        V : Natural;
3151
3152                     begin
3153                        V := 0;
3154                        for J in 1 .. 2 loop
3155                           C := Getc;
3156
3157                           if C in '0' .. '9' then
3158                              V := V * 16 +
3159                                     Character'Pos (C) -
3160                                       Character'Pos ('0');
3161
3162                           elsif C in 'A' .. 'F' then
3163                              V := V * 16 +
3164                                     Character'Pos (C) -
3165                                       Character'Pos ('A') +
3166                                         10;
3167
3168                           else
3169                              Fatal_Error_Ignore;
3170                           end if;
3171                        end loop;
3172
3173                        Checkc ('}');
3174                        Add_Char_To_Name_Buffer (Character'Val (V));
3175                     end;
3176
3177                  else
3178                     if C = '"' then
3179                        exit when Nextc /= '"';
3180                        C := Getc;
3181                     end if;
3182
3183                     Add_Char_To_Name_Buffer (C);
3184                  end if;
3185               end loop;
3186
3187               Add_Char_To_Name_Buffer (NUL);
3188               Skip_Eol;
3189            end if;
3190
3191            C := Getc;
3192         end loop Linker_Options_Loop;
3193
3194         --  Store the linker options entry if one was found
3195
3196         if Name_Len /= 0 then
3197            Linker_Options.Increment_Last;
3198
3199            Linker_Options.Table (Linker_Options.Last).Name :=
3200              Name_Enter;
3201
3202            Linker_Options.Table (Linker_Options.Last).Unit :=
3203              Units.Last;
3204
3205            Linker_Options.Table (Linker_Options.Last).Internal_File :=
3206              Is_Internal_File_Name (F);
3207         end if;
3208
3209         --  If there are notes present, scan them
3210
3211         Notes_Loop : loop
3212            Check_Unknown_Line;
3213            exit Notes_Loop when C /= 'N';
3214
3215            if Ignore ('N') then
3216               Skip_Line;
3217
3218            else
3219               Checkc (' ');
3220
3221               Notes.Increment_Last;
3222               Notes.Table (Notes.Last).Pragma_Type := Getc;
3223               Notes.Table (Notes.Last).Pragma_Line := Get_Nat;
3224               Checkc (':');
3225               Notes.Table (Notes.Last).Pragma_Col  := Get_Nat;
3226
3227               if not At_Eol and then Nextc = ':' then
3228                  Checkc (':');
3229                  Notes.Table (Notes.Last).Pragma_Source_File :=
3230                    Get_File_Name (Lower => True);
3231               else
3232                  Notes.Table (Notes.Last).Pragma_Source_File :=
3233                    Units.Table (Units.Last).Sfile;
3234               end if;
3235
3236               if At_Eol then
3237                  Notes.Table (Notes.Last).Pragma_Args := No_Name;
3238
3239               else
3240                  --  Note: can't use Get_Name here as the remainder of the
3241                  --  line is unstructured text whose syntax depends on the
3242                  --  particular pragma used.
3243
3244                  Checkc (' ');
3245
3246                  Name_Len := 0;
3247                  while not At_Eol loop
3248                     Add_Char_To_Name_Buffer (Getc);
3249                  end loop;
3250               end if;
3251
3252               Skip_Eol;
3253            end if;
3254
3255            C := Getc;
3256         end loop Notes_Loop;
3257      end loop U_Loop;
3258
3259      --  End loop through units for one ALI file
3260
3261      ALIs.Table (Id).Last_Unit := Units.Last;
3262      ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile;
3263
3264      --  Set types of the units (there can be at most 2 of them)
3265
3266      if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then
3267         Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body;
3268         Units.Table (ALIs.Table (Id).Last_Unit).Utype  := Is_Spec;
3269
3270      else
3271         --  Deal with body only and spec only cases, note that the reason we
3272         --  do our own checking of the name (rather than using Is_Body_Name)
3273         --  is that Uname drags in far too much compiler junk.
3274
3275         Get_Name_String (Units.Table (Units.Last).Uname);
3276
3277         if Name_Buffer (Name_Len) = 'b' then
3278            Units.Table (Units.Last).Utype := Is_Body_Only;
3279         else
3280            Units.Table (Units.Last).Utype := Is_Spec_Only;
3281         end if;
3282      end if;
3283
3284      --  Scan out external version references and put in hash table
3285
3286      E_Loop : loop
3287         Check_Unknown_Line;
3288         exit E_Loop when C /= 'E';
3289
3290         if Ignore ('E') then
3291            Skip_Line;
3292
3293         else
3294            Checkc (' ');
3295            Skip_Space;
3296
3297            Name_Len := 0;
3298            Name_Len := 0;
3299            loop
3300               C := Getc;
3301
3302               if C < ' ' then
3303                  Fatal_Error;
3304               end if;
3305
3306               exit when At_End_Of_Field;
3307               Add_Char_To_Name_Buffer (C);
3308            end loop;
3309
3310            Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
3311            Skip_Eol;
3312         end if;
3313
3314         C := Getc;
3315      end loop E_Loop;
3316
3317      --  Scan out source dependency lines for this ALI file
3318
3319      ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
3320
3321      D_Loop : loop
3322         Check_Unknown_Line;
3323         exit D_Loop when C /= 'D';
3324
3325         if Ignore ('D') then
3326            Skip_Line;
3327
3328         else
3329            Checkc (' ');
3330            Skip_Space;
3331            Sdep.Increment_Last;
3332
3333            --  In the following call, Lower is not set to True, this is either
3334            --  a bug, or it deserves a special comment as to why this is so???
3335
3336            --  The file/path name may be quoted
3337
3338            Sdep.Table (Sdep.Last).Sfile :=
3339              Get_File_Name (May_Be_Quoted => True);
3340
3341            Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
3342            Sdep.Table (Sdep.Last).Dummy_Entry :=
3343              (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
3344
3345            --  Acquire checksum value
3346
3347            Skip_Space;
3348
3349            declare
3350               Ctr : Natural;
3351               Chk : Word;
3352
3353            begin
3354               Ctr := 0;
3355               Chk := 0;
3356
3357               loop
3358                  exit when At_Eol or else Ctr = 8;
3359
3360                  if Nextc in '0' .. '9' then
3361                     Chk := Chk * 16 +
3362                              Character'Pos (Nextc) - Character'Pos ('0');
3363
3364                  elsif Nextc in 'a' .. 'f' then
3365                     Chk := Chk * 16 +
3366                              Character'Pos (Nextc) - Character'Pos ('a') + 10;
3367
3368                  else
3369                     exit;
3370                  end if;
3371
3372                  Ctr := Ctr + 1;
3373                  P := P + 1;
3374               end loop;
3375
3376               if Ctr = 8 and then At_End_Of_Field then
3377                  Sdep.Table (Sdep.Last).Checksum := Chk;
3378               else
3379                  Fatal_Error;
3380               end if;
3381            end;
3382
3383            --  Acquire (sub)unit and reference file name entries
3384
3385            Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
3386            Sdep.Table (Sdep.Last).Unit_Name    := No_Name;
3387            Sdep.Table (Sdep.Last).Rfile        :=
3388              Sdep.Table (Sdep.Last).Sfile;
3389            Sdep.Table (Sdep.Last).Start_Line   := 1;
3390
3391            if not At_Eol then
3392               Skip_Space;
3393
3394               --  Here for (sub)unit name
3395
3396               if Nextc not in '0' .. '9' then
3397                  Name_Len := 0;
3398                  while not At_End_Of_Field loop
3399                     Add_Char_To_Name_Buffer (Getc);
3400                  end loop;
3401
3402                  --  Set the (sub)unit name. Note that we use Name_Find rather
3403                  --  than Name_Enter here as the subunit name may already
3404                  --  have been put in the name table by the Project Manager.
3405
3406                  if Name_Len <= 2
3407                    or else Name_Buffer (Name_Len - 1) /= '%'
3408                  then
3409                     Sdep.Table (Sdep.Last).Subunit_Name := Name_Find;
3410                  else
3411                     Name_Len := Name_Len - 2;
3412                     Sdep.Table (Sdep.Last).Unit_Name := Name_Find;
3413                  end if;
3414
3415                  Skip_Space;
3416               end if;
3417
3418               --  Here for reference file name entry
3419
3420               if Nextc in '0' .. '9' then
3421                  Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
3422                  Checkc (':');
3423
3424                  Name_Len := 0;
3425
3426                  while not At_End_Of_Field loop
3427                     Add_Char_To_Name_Buffer (Getc);
3428                  end loop;
3429
3430                  Sdep.Table (Sdep.Last).Rfile := Name_Enter;
3431               end if;
3432            end if;
3433
3434            Skip_Eol;
3435         end if;
3436
3437         C := Getc;
3438      end loop D_Loop;
3439
3440      ALIs.Table (Id).Last_Sdep := Sdep.Last;
3441
3442      --  Loop through invocation-graph lines
3443
3444      G_Loop : loop
3445         Check_Unknown_Line;
3446         exit G_Loop when C /= 'G';
3447
3448         Scan_Invocation_Graph_Line;
3449
3450         C := Getc;
3451      end loop G_Loop;
3452
3453      --  We must at this stage be at an Xref line or the end of file
3454
3455      if C = EOF then
3456         return Id;
3457      end if;
3458
3459      Check_Unknown_Line;
3460
3461      if C /= 'X' then
3462         Fatal_Error;
3463      end if;
3464
3465      --  If we are ignoring Xref sections we are done (we ignore all
3466      --  remaining lines since only xref related lines follow X).
3467
3468      if Ignore ('X') and then not Debug_Flag_X then
3469         return Id;
3470      end if;
3471
3472      --  Loop through Xref sections
3473
3474      X_Loop : loop
3475         Check_Unknown_Line;
3476         exit X_Loop when C /= 'X';
3477
3478         --  Make new entry in section table
3479
3480         Xref_Section.Increment_Last;
3481
3482         Read_Refs_For_One_File : declare
3483            XS : Xref_Section_Record renames
3484                   Xref_Section.Table (Xref_Section.Last);
3485
3486            Current_File_Num : Sdep_Id;
3487            --  Keeps track of the current file number (changed by nn|)
3488
3489         begin
3490            XS.File_Num     := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
3491            XS.File_Name    := Get_File_Name;
3492            XS.First_Entity := Xref_Entity.Last + 1;
3493
3494            Current_File_Num := XS.File_Num;
3495
3496            Skip_Space;
3497
3498            Skip_Eol;
3499            C := Nextc;
3500
3501            --  Loop through Xref entities
3502
3503            while C /= 'X' and then C /= EOF loop
3504               Xref_Entity.Increment_Last;
3505
3506               Read_Refs_For_One_Entity : declare
3507                  XE : Xref_Entity_Record renames
3508                         Xref_Entity.Table (Xref_Entity.Last);
3509                  N  : Nat;
3510
3511                  procedure Read_Instantiation_Reference;
3512                  --  Acquire instantiation reference. Caller has checked
3513                  --  that current character is '[' and on return the cursor
3514                  --  is skipped past the corresponding closing ']'.
3515
3516                  ----------------------------------
3517                  -- Read_Instantiation_Reference --
3518                  ----------------------------------
3519
3520                  procedure Read_Instantiation_Reference is
3521                     Local_File_Num : Sdep_Id := Current_File_Num;
3522
3523                  begin
3524                     Xref.Increment_Last;
3525
3526                     declare
3527                        XR : Xref_Record renames Xref.Table (Xref.Last);
3528
3529                     begin
3530                        P := P + 1; -- skip [
3531                        N := Get_Nat;
3532
3533                        if Nextc = '|' then
3534                           XR.File_Num :=
3535                             Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
3536                           Local_File_Num := XR.File_Num;
3537                           P := P + 1;
3538                           N := Get_Nat;
3539
3540                        else
3541                           XR.File_Num := Local_File_Num;
3542                        end if;
3543
3544                        XR.Line  := N;
3545                        XR.Rtype := ' ';
3546                        XR.Col   := 0;
3547
3548                        --  Recursive call for next reference
3549
3550                        if Nextc = '[' then
3551                           pragma Warnings (Off); -- kill recursion warning
3552                           Read_Instantiation_Reference;
3553                           pragma Warnings (On);
3554                        end if;
3555
3556                        --  Skip closing bracket after recursive call
3557
3558                        P := P + 1;
3559                     end;
3560                  end Read_Instantiation_Reference;
3561
3562               --  Start of processing for Read_Refs_For_One_Entity
3563
3564               begin
3565                  XE.Line  := Get_Nat;
3566                  XE.Etype := Getc;
3567                  XE.Col   := Get_Nat;
3568
3569                  case Getc is
3570                     when '*' =>
3571                        XE.Visibility := Global;
3572                     when '+' =>
3573                        XE.Visibility := Static;
3574                     when others =>
3575                        XE.Visibility := Other;
3576                  end case;
3577
3578                  XE.Entity := Get_Name;
3579
3580                  --  Handle the information about generic instantiations
3581
3582                  if Nextc = '[' then
3583                     Skipc; --  Opening '['
3584                     N := Get_Nat;
3585
3586                     if Nextc /= '|' then
3587                        XE.Iref_File_Num := Current_File_Num;
3588                        XE.Iref_Line     := N;
3589                     else
3590                        XE.Iref_File_Num :=
3591                          Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
3592                        Skipc;
3593                        XE.Iref_Line := Get_Nat;
3594                     end if;
3595
3596                     if Getc /= ']' then
3597                        Fatal_Error;
3598                     end if;
3599
3600                  else
3601                     XE.Iref_File_Num := No_Sdep_Id;
3602                     XE.Iref_Line     := 0;
3603                  end if;
3604
3605                  Current_File_Num := XS.File_Num;
3606
3607                  --  Renaming reference is present
3608
3609                  if Nextc = '=' then
3610                     P := P + 1;
3611                     XE.Rref_Line := Get_Nat;
3612
3613                     if Getc /= ':' then
3614                        Fatal_Error;
3615                     end if;
3616
3617                     XE.Rref_Col := Get_Nat;
3618
3619                  --  No renaming reference present
3620
3621                  else
3622                     XE.Rref_Line := 0;
3623                     XE.Rref_Col  := 0;
3624                  end if;
3625
3626                  Skip_Space;
3627
3628                  XE.Oref_File_Num := No_Sdep_Id;
3629                  XE.Tref_File_Num := No_Sdep_Id;
3630                  XE.Tref          := Tref_None;
3631                  XE.First_Xref    := Xref.Last + 1;
3632
3633                  --  Loop to check for additional info present
3634
3635                  loop
3636                     declare
3637                        Ref  : Tref_Kind;
3638                        File : Sdep_Id;
3639                        Line : Nat;
3640                        Typ  : Character;
3641                        Col  : Nat;
3642                        Std  : Name_Id;
3643
3644                     begin
3645                        Get_Typeref
3646                          (Current_File_Num, Ref, File, Line, Typ, Col, Std);
3647                        exit when Ref = Tref_None;
3648
3649                        --  Do we have an overriding procedure?
3650
3651                        if Ref = Tref_Derived and then Typ = 'p' then
3652                           XE.Oref_File_Num := File;
3653                           XE.Oref_Line     := Line;
3654                           XE.Oref_Col      := Col;
3655
3656                        --  Arrays never override anything, and <> points to
3657                        --  the index types instead
3658
3659                        elsif Ref = Tref_Derived and then XE.Etype = 'A' then
3660
3661                           --  Index types are stored in the list of references
3662
3663                           Xref.Increment_Last;
3664
3665                           declare
3666                              XR : Xref_Record renames Xref.Table (Xref.Last);
3667                           begin
3668                              XR.File_Num := File;
3669                              XR.Line     := Line;
3670                              XR.Rtype    := Array_Index_Reference;
3671                              XR.Col      := Col;
3672                              XR.Name     := Std;
3673                           end;
3674
3675                        --  Interfaces are stored in the list of references,
3676                        --  although the parent type itself is stored in XE.
3677                        --  The first interface (when there are only
3678                        --  interfaces) is stored in XE.Tref*)
3679
3680                        elsif Ref = Tref_Derived
3681                          and then Typ = 'R'
3682                          and then XE.Tref_File_Num /= No_Sdep_Id
3683                        then
3684                           Xref.Increment_Last;
3685
3686                           declare
3687                              XR : Xref_Record renames Xref.Table (Xref.Last);
3688                           begin
3689                              XR.File_Num := File;
3690                              XR.Line     := Line;
3691                              XR.Rtype    := Interface_Reference;
3692                              XR.Col      := Col;
3693                              XR.Name     := Std;
3694                           end;
3695
3696                        else
3697                           XE.Tref                 := Ref;
3698                           XE.Tref_File_Num        := File;
3699                           XE.Tref_Line            := Line;
3700                           XE.Tref_Type            := Typ;
3701                           XE.Tref_Col             := Col;
3702                           XE.Tref_Standard_Entity := Std;
3703                        end if;
3704                     end;
3705                  end loop;
3706
3707                  --  Loop through cross-references for this entity
3708
3709                  loop
3710                     Skip_Space;
3711
3712                     if At_Eol then
3713                        Skip_Eol;
3714                        exit when Nextc /= '.';
3715                        P := P + 1;
3716                     end if;
3717
3718                     Xref.Increment_Last;
3719
3720                     declare
3721                        XR : Xref_Record renames Xref.Table (Xref.Last);
3722
3723                     begin
3724                        N := Get_Nat;
3725
3726                        if Nextc = '|' then
3727                           XR.File_Num :=
3728                             Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
3729                           Current_File_Num := XR.File_Num;
3730                           P := P + 1;
3731                           N := Get_Nat;
3732                        else
3733                           XR.File_Num := Current_File_Num;
3734                        end if;
3735
3736                        XR.Line  := N;
3737                        XR.Rtype := Getc;
3738
3739                        --  Imported entities reference as in:
3740                        --    494b<c,__gnat_copy_attribs>25
3741
3742                        if Nextc = '<' then
3743                           Skipc;
3744                           XR.Imported_Lang := Get_Name;
3745
3746                           pragma Assert (Nextc = ',');
3747                           Skipc;
3748
3749                           XR.Imported_Name := Get_Name;
3750
3751                           pragma Assert (Nextc = '>');
3752                           Skipc;
3753
3754                        else
3755                           XR.Imported_Lang := No_Name;
3756                           XR.Imported_Name := No_Name;
3757                        end if;
3758
3759                        XR.Col   := Get_Nat;
3760
3761                        if Nextc = '[' then
3762                           Read_Instantiation_Reference;
3763                        end if;
3764                     end;
3765                  end loop;
3766
3767                  --  Record last cross-reference
3768
3769                  XE.Last_Xref := Xref.Last;
3770                  C := Nextc;
3771
3772               exception
3773                  when Bad_ALI_Format =>
3774
3775                     --  If ignoring errors, then we skip a line with an
3776                     --  unexpected error, and try to continue subsequent
3777                     --  xref lines.
3778
3779                     if Ignore_Errors then
3780                        Xref_Entity.Decrement_Last;
3781                        Skip_Line;
3782                        C := Nextc;
3783
3784                     --  Otherwise, we reraise the fatal exception
3785
3786                     else
3787                        raise;
3788                     end if;
3789               end Read_Refs_For_One_Entity;
3790            end loop;
3791
3792            --  Record last entity
3793
3794            XS.Last_Entity := Xref_Entity.Last;
3795         end Read_Refs_For_One_File;
3796
3797         C := Getc;
3798      end loop X_Loop;
3799
3800      --  Here after dealing with xref sections
3801
3802      --  Ignore remaining lines, which belong to an additional section of the
3803      --  ALI file not considered here (like SCO or SPARK information).
3804
3805      Check_Unknown_Line;
3806
3807      return Id;
3808
3809   exception
3810      when Bad_ALI_Format =>
3811         return No_ALI_Id;
3812   end Scan_ALI;
3813
3814   -----------
3815   -- Scope --
3816   -----------
3817
3818   function Scope (IS_Id : Invocation_Signature_Id) return Name_Id is
3819   begin
3820      pragma Assert (Present (IS_Id));
3821      return Invocation_Signatures.Table (IS_Id).Scope;
3822   end Scope;
3823
3824   ---------
3825   -- SEq --
3826   ---------
3827
3828   function SEq (F1, F2 : String_Ptr) return Boolean is
3829   begin
3830      return F1.all = F2.all;
3831   end SEq;
3832
3833   -----------------------------------
3834   -- Set_Invocation_Graph_Encoding --
3835   -----------------------------------
3836
3837   procedure Set_Invocation_Graph_Encoding
3838     (Kind         : Invocation_Graph_Encoding_Kind;
3839      Update_Units : Boolean := True)
3840   is
3841   begin
3842      Compile_Time_Invocation_Graph_Encoding := Kind;
3843
3844      --  Update the invocation-graph encoding of the current unit only when
3845      --  requested by the caller.
3846
3847      if Update_Units then
3848         declare
3849            Curr_Unit : Unit_Record renames Units.Table (Units.Last);
3850            Curr_ALI  : ALIs_Record renames ALIs.Table  (Curr_Unit.My_ALI);
3851
3852         begin
3853            Curr_ALI.Invocation_Graph_Encoding := Kind;
3854         end;
3855      end if;
3856   end Set_Invocation_Graph_Encoding;
3857
3858   -----------
3859   -- SHash --
3860   -----------
3861
3862   function SHash (S : String_Ptr) return Vindex is
3863      H : Word;
3864
3865   begin
3866      H := 0;
3867      for J in S.all'Range loop
3868         H := H * 2 + Character'Pos (S (J));
3869      end loop;
3870
3871      return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));
3872   end SHash;
3873
3874   ---------------
3875   -- Signature --
3876   ---------------
3877
3878   function Signature
3879     (IC_Id : Invocation_Construct_Id) return Invocation_Signature_Id
3880   is
3881   begin
3882      pragma Assert (Present (IC_Id));
3883      return Invocation_Constructs.Table (IC_Id).Signature;
3884   end Signature;
3885
3886   --------------------
3887   -- Spec_Placement --
3888   --------------------
3889
3890   function Spec_Placement
3891     (IC_Id : Invocation_Construct_Id) return Declaration_Placement_Kind
3892   is
3893   begin
3894      pragma Assert (Present (IC_Id));
3895      return Invocation_Constructs.Table (IC_Id).Spec_Placement;
3896   end Spec_Placement;
3897
3898   ------------
3899   -- Target --
3900   ------------
3901
3902   function Target
3903     (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id
3904   is
3905   begin
3906      pragma Assert (Present (IR_Id));
3907      return Invocation_Relations.Table (IR_Id).Target;
3908   end Target;
3909
3910end ALI;
3911