|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- A L I --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
|
17 -- for more details. You should have received a copy of the GNU General --
|
|
|
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
|
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 with Butil; use Butil;
|
|
|
27 with Debug; use Debug;
|
|
|
28 with Fname; use Fname;
|
|
|
29 with Opt; use Opt;
|
|
|
30 with Osint; use Osint;
|
|
|
31 with Output; use Output;
|
|
145
|
32 with Snames; use Snames;
|
|
|
33
|
|
|
34 with GNAT; use GNAT;
|
|
|
35 with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
|
|
111
|
36
|
|
|
37 package body ALI is
|
|
|
38
|
|
|
39 use ASCII;
|
|
|
40 -- Make control characters visible
|
|
|
41
|
|
145
|
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
|
|
131
|
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 --
|
|
145
|
247 -- B F H J K O Q Z
|
|
111
|
248
|
|
|
249 Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean :=
|
|
145
|
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
|
|
111
|
269 others => False);
|
|
|
270
|
|
145
|
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
|
|
111
|
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;
|
|
145
|
638 Invocation_Constructs.Init;
|
|
|
639 Invocation_Relations.Init;
|
|
|
640 Invocation_Signatures.Init;
|
|
|
641 Linker_Options.Init;
|
|
111
|
642 No_Deps.Init;
|
|
145
|
643 Notes.Init;
|
|
111
|
644 Sdep.Init;
|
|
145
|
645 Units.Init;
|
|
|
646 Version_Ref.Reset;
|
|
|
647 Withs.Init;
|
|
111
|
648 Xref_Entity.Init;
|
|
|
649 Xref.Init;
|
|
145
|
650 Xref_Section.Init;
|
|
|
651
|
|
|
652 -- Add dummy zeroth item in Linker_Options and Notes for sort calls
|
|
111
|
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
|
|
145
|
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
|
|
111
|
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
|
|
145
|
981 -- an operator name starting with a double quote that is terminated
|
|
111
|
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
|
|
145
|
1016 procedure Scan_Invocation_Graph_Line;
|
|
|
1017 -- Parse a single line that encodes a piece of the invocation graph
|
|
|
1018
|
|
111
|
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
|
|
145
|
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
|
|
111
|
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,
|
|
145
|
1876 Invocation_Graph_Encoding => No_Encoding,
|
|
111
|
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
|
|
145
|
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;
|
|
111
|
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');
|
|
131
|
3030 Withs.Table (Withs.Last).Implicit_With := (C = 'Z');
|
|
111
|
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 :=
|
|
131
|
3339 Get_File_Name (May_Be_Quoted => True);
|
|
111
|
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
|
|
145
|
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
|
|
111
|
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
|
|
145
|
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
|
|
111
|
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
|
|
145
|
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
|
|
111
|
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
|
|
145
|
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
|
|
111
|
3910 end ALI;
|
