Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/ali.adb @ 145:1830386684a0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc-9.2.0
author anatofuz
date Thu, 13 Feb 2020 11:34:05 +0900
parents 84e7813d76e9
children
comparison
equal deleted inserted replaced
131:84e7813d76e9 145:1830386684a0
4 -- -- 4 -- --
5 -- A L I -- 5 -- A L I --
6 -- -- 6 -- --
7 -- B o d y -- 7 -- B o d y --
8 -- -- 8 -- --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. -- 9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
10 -- -- 10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under -- 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- -- 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- -- 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- -- 14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
27 with Debug; use Debug; 27 with Debug; use Debug;
28 with Fname; use Fname; 28 with Fname; use Fname;
29 with Opt; use Opt; 29 with Opt; use Opt;
30 with Osint; use Osint; 30 with Osint; use Osint;
31 with Output; use Output; 31 with Output; use Output;
32 with Snames; use Snames;
33
34 with GNAT; use GNAT;
35 with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
32 36
33 package body ALI is 37 package body ALI is
34 38
35 use ASCII; 39 use ASCII;
36 -- Make control characters visible 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');
37 242
38 -- The following variable records which characters currently are used as 243 -- The following variable records which characters currently are used as
39 -- line type markers in the ALI file. This is used in Scan_ALI to detect 244 -- line type markers in the ALI file. This is used in Scan_ALI to detect
40 -- (or skip) invalid lines. The following letters are still available: 245 -- (or skip) invalid lines. The following letters are still available:
41 -- 246 --
42 -- B F G H J K O Q Z 247 -- B F H J K O Q Z
43 248
44 Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean := 249 Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean :=
45 ('V' => True, -- version 250 ('A' => True, -- argument
46 'M' => True, -- main program 251 'C' => True, -- SCO information
47 'A' => True, -- argument 252 'D' => True, -- dependency
48 'P' => True, -- program 253 'E' => True, -- external
49 'R' => True, -- restriction 254 'G' => True, -- invocation graph
50 'I' => True, -- interrupt 255 'I' => True, -- interrupt
51 'U' => True, -- unit 256 'L' => True, -- linker option
52 'W' => True, -- with 257 'M' => True, -- main program
53 'L' => True, -- linker option 258 'N' => True, -- notes
54 'N' => True, -- notes 259 'P' => True, -- program
55 'E' => True, -- external 260 'R' => True, -- restriction
56 'D' => True, -- dependency 261 'S' => True, -- specific dispatching
57 'X' => True, -- xref 262 'T' => True, -- task stack information
58 'S' => True, -- specific dispatching 263 'U' => True, -- unit
59 'Y' => True, -- limited_with 264 'V' => True, -- version
60 'Z' => True, -- implicit with from instantiation 265 'W' => True, -- with
61 'C' => True, -- SCO information 266 'X' => True, -- xref
62 'T' => True, -- task stack information 267 'Y' => True, -- limited_with
268 'Z' => True, -- implicit with from instantiation
63 others => False); 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;
64 609
65 -------------------- 610 --------------------
66 -- Initialize_ALI -- 611 -- Initialize_ALI --
67 -------------------- 612 --------------------
68 613
88 end loop; 633 end loop;
89 634
90 -- Initialize all tables 635 -- Initialize all tables
91 636
92 ALIs.Init; 637 ALIs.Init;
638 Invocation_Constructs.Init;
639 Invocation_Relations.Init;
640 Invocation_Signatures.Init;
641 Linker_Options.Init;
93 No_Deps.Init; 642 No_Deps.Init;
643 Notes.Init;
644 Sdep.Init;
94 Units.Init; 645 Units.Init;
646 Version_Ref.Reset;
95 Withs.Init; 647 Withs.Init;
96 Sdep.Init;
97 Linker_Options.Init;
98 Notes.Init;
99 Xref_Section.Init;
100 Xref_Entity.Init; 648 Xref_Entity.Init;
101 Xref.Init; 649 Xref.Init;
102 Version_Ref.Reset; 650 Xref_Section.Init;
103 651
104 -- Add dummy zero'th item in Linker_Options and Notes for sort calls 652 -- Add dummy zeroth item in Linker_Options and Notes for sort calls
105 653
106 Linker_Options.Increment_Last; 654 Linker_Options.Increment_Last;
107 Notes.Increment_Last; 655 Notes.Increment_Last;
108 656
109 -- Initialize global variables recording cumulative options in all 657 -- Initialize global variables recording cumulative options in all
122 Task_Dispatching_Policy_Specified := ' '; 670 Task_Dispatching_Policy_Specified := ' ';
123 Unreserve_All_Interrupts_Specified := False; 671 Unreserve_All_Interrupts_Specified := False;
124 Frontend_Exceptions_Specified := False; 672 Frontend_Exceptions_Specified := False;
125 Zero_Cost_Exceptions_Specified := False; 673 Zero_Cost_Exceptions_Specified := False;
126 end Initialize_ALI; 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;
127 884
128 -------------- 885 --------------
129 -- Scan_ALI -- 886 -- Scan_ALI --
130 -------------- 887 --------------
131 888
219 -- If Ignore_Spaces is False (normal case), then scan is terminated 976 -- If Ignore_Spaces is False (normal case), then scan is terminated
220 -- by the normal end of field condition (EOL, space, horizontal tab) 977 -- by the normal end of field condition (EOL, space, horizontal tab)
221 -- 978 --
222 -- If Ignore_Special is False (normal case), the scan is terminated by 979 -- If Ignore_Special is False (normal case), the scan is terminated by
223 -- a typeref bracket or an equal sign except for the special case of 980 -- a typeref bracket or an equal sign except for the special case of
224 -- an operator name starting with a double quote which is terminated 981 -- an operator name starting with a double quote that is terminated
225 -- by another double quote. 982 -- by another double quote.
226 -- 983 --
227 -- If May_Be_Quoted is True and the first non blank character is '"' 984 -- If May_Be_Quoted is True and the first non blank character is '"'
228 -- the name is 'unquoted'. In this case Ignore_Special is ignored and 985 -- the name is 'unquoted'. In this case Ignore_Special is ignored and
229 -- assumed to be True. 986 -- assumed to be True.
253 Line : out Nat; 1010 Line : out Nat;
254 Ref_Type : out Character; 1011 Ref_Type : out Character;
255 Col : out Nat; 1012 Col : out Nat;
256 Standard_Entity : out Name_Id); 1013 Standard_Entity : out Name_Id);
257 -- Parse the definition of a typeref (<...>, {...} or (...)) 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
258 1018
259 procedure Skip_Eol; 1019 procedure Skip_Eol;
260 -- Skip past spaces, then skip past end of line (fatal error if not 1020 -- Skip past spaces, then skip past end of line (fatal error if not
261 -- at end of line). Also skips past any following blank lines. 1021 -- at end of line). Also skips past any following blank lines.
262 1022
769 function Nextc return Character is 1529 function Nextc return Character is
770 begin 1530 begin
771 return T (P); 1531 return T (P);
772 end Nextc; 1532 end Nextc;
773 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
774 -------------- 1767 --------------
775 -- Skip_Eol -- 1768 -- Skip_Eol --
776 -------------- 1769 --------------
777 1770
778 procedure Skip_Eol is 1771 procedure Skip_Eol is
878 First_Interrupt_State => Interrupt_States.Last + 1, 1871 First_Interrupt_State => Interrupt_States.Last + 1,
879 First_Sdep => No_Sdep_Id, 1872 First_Sdep => No_Sdep_Id,
880 First_Specific_Dispatching => Specific_Dispatching.Last + 1, 1873 First_Specific_Dispatching => Specific_Dispatching.Last + 1,
881 First_Unit => No_Unit_Id, 1874 First_Unit => No_Unit_Id,
882 GNATprove_Mode => False, 1875 GNATprove_Mode => False,
1876 Invocation_Graph_Encoding => No_Encoding,
883 Last_Interrupt_State => Interrupt_States.Last, 1877 Last_Interrupt_State => Interrupt_States.Last,
884 Last_Sdep => No_Sdep_Id, 1878 Last_Sdep => No_Sdep_Id,
885 Last_Specific_Dispatching => Specific_Dispatching.Last, 1879 Last_Specific_Dispatching => Specific_Dispatching.Last,
886 Last_Unit => No_Unit_Id, 1880 Last_Unit => No_Unit_Id,
887 Locking_Policy => ' ', 1881 Locking_Policy => ' ',
1714 2708
1715 declare 2709 declare
1716 UL : Unit_Record renames Units.Table (Units.Last); 2710 UL : Unit_Record renames Units.Table (Units.Last);
1717 2711
1718 begin 2712 begin
1719 UL.Uname := Get_Unit_Name; 2713 UL.Uname := Get_Unit_Name;
1720 UL.Predefined := Is_Predefined_Unit; 2714 UL.Predefined := Is_Predefined_Unit;
1721 UL.Internal := Is_Internal_Unit; 2715 UL.Internal := Is_Internal_Unit;
1722 UL.My_ALI := Id; 2716 UL.My_ALI := Id;
1723 UL.Sfile := Get_File_Name (Lower => True); 2717 UL.Sfile := Get_File_Name (Lower => True);
1724 UL.Pure := False; 2718 UL.Pure := False;
1725 UL.Preelab := False; 2719 UL.Preelab := False;
1726 UL.No_Elab := False; 2720 UL.No_Elab := False;
1727 UL.Shared_Passive := False; 2721 UL.Shared_Passive := False;
1728 UL.RCI := False; 2722 UL.RCI := False;
1729 UL.Remote_Types := False; 2723 UL.Remote_Types := False;
1730 UL.Serious_Errors := False; 2724 UL.Serious_Errors := False;
1731 UL.Has_RACW := False; 2725 UL.Has_RACW := False;
1732 UL.Init_Scalars := False; 2726 UL.Init_Scalars := False;
1733 UL.Is_Generic := False; 2727 UL.Is_Generic := False;
1734 UL.Icasing := Mixed_Case; 2728 UL.Icasing := Mixed_Case;
1735 UL.Kcasing := All_Lower_Case; 2729 UL.Kcasing := All_Lower_Case;
1736 UL.Dynamic_Elab := False; 2730 UL.Dynamic_Elab := False;
1737 UL.Elaborate_Body := False; 2731 UL.Elaborate_Body := False;
1738 UL.Set_Elab_Entity := False; 2732 UL.Set_Elab_Entity := False;
1739 UL.Version := "00000000"; 2733 UL.Version := "00000000";
1740 UL.First_With := Withs.Last + 1; 2734 UL.First_With := Withs.Last + 1;
1741 UL.First_Arg := First_Arg; 2735 UL.First_Arg := First_Arg;
1742 UL.Elab_Position := 0; 2736 UL.First_Invocation_Construct := Invocation_Constructs.Last + 1;
1743 UL.SAL_Interface := ALIs.Table (Id).SAL_Interface; 2737 UL.Last_Invocation_Construct := No_Invocation_Construct;
1744 UL.Directly_Scanned := Directly_Scanned; 2738 UL.First_Invocation_Relation := Invocation_Relations.Last + 1;
1745 UL.Body_Needed_For_SAL := False; 2739 UL.Last_Invocation_Relation := No_Invocation_Relation;
1746 UL.Elaborate_Body_Desirable := False; 2740 UL.Elab_Position := 0;
1747 UL.Optimize_Alignment := 'O'; 2741 UL.SAL_Interface := ALIs.Table (Id).SAL_Interface;
1748 UL.Has_Finalizer := False; 2742 UL.Directly_Scanned := Directly_Scanned;
1749 UL.Primary_Stack_Count := 0; 2743 UL.Body_Needed_For_SAL := False;
1750 UL.Sec_Stack_Count := 0; 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;
1751 2749
1752 if Debug_Flag_U then 2750 if Debug_Flag_U then
1753 Write_Str (" ----> reading unit "); 2751 Write_Str (" ----> reading unit ");
1754 Write_Int (Int (Units.Last)); 2752 Write_Int (Int (Units.Last));
1755 Write_Str (" "); 2753 Write_Str (" ");
2204 Linker_Options.Table (Linker_Options.Last).Unit := 3202 Linker_Options.Table (Linker_Options.Last).Unit :=
2205 Units.Last; 3203 Units.Last;
2206 3204
2207 Linker_Options.Table (Linker_Options.Last).Internal_File := 3205 Linker_Options.Table (Linker_Options.Last).Internal_File :=
2208 Is_Internal_File_Name (F); 3206 Is_Internal_File_Name (F);
2209
2210 Linker_Options.Table (Linker_Options.Last).Original_Pos :=
2211 Linker_Options.Last;
2212 end if; 3207 end if;
2213 3208
2214 -- If there are notes present, scan them 3209 -- If there are notes present, scan them
2215 3210
2216 Notes_Loop : loop 3211 Notes_Loop : loop
2441 3436
2442 C := Getc; 3437 C := Getc;
2443 end loop D_Loop; 3438 end loop D_Loop;
2444 3439
2445 ALIs.Table (Id).Last_Sdep := Sdep.Last; 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;
2446 3452
2447 -- We must at this stage be at an Xref line or the end of file 3453 -- We must at this stage be at an Xref line or the end of file
2448 3454
2449 if C = EOF then 3455 if C = EOF then
2450 return Id; 3456 return Id;
2784 end loop; 3790 end loop;
2785 3791
2786 -- Record last entity 3792 -- Record last entity
2787 3793
2788 XS.Last_Entity := Xref_Entity.Last; 3794 XS.Last_Entity := Xref_Entity.Last;
2789
2790 end Read_Refs_For_One_File; 3795 end Read_Refs_For_One_File;
2791 3796
2792 C := Getc; 3797 C := Getc;
2793 end loop X_Loop; 3798 end loop X_Loop;
2794 3799
2804 exception 3809 exception
2805 when Bad_ALI_Format => 3810 when Bad_ALI_Format =>
2806 return No_ALI_Id; 3811 return No_ALI_Id;
2807 end Scan_ALI; 3812 end Scan_ALI;
2808 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
2809 --------- 3824 ---------
2810 -- SEq -- 3825 -- SEq --
2811 --------- 3826 ---------
2812 3827
2813 function SEq (F1, F2 : String_Ptr) return Boolean is 3828 function SEq (F1, F2 : String_Ptr) return Boolean is
2814 begin 3829 begin
2815 return F1.all = F2.all; 3830 return F1.all = F2.all;
2816 end SEq; 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;
2817 3857
2818 ----------- 3858 -----------
2819 -- SHash -- 3859 -- SHash --
2820 ----------- 3860 -----------
2821 3861
2829 end loop; 3869 end loop;
2830 3870
2831 return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length)); 3871 return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));
2832 end SHash; 3872 end SHash;
2833 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
2834 end ALI; 3910 end ALI;