|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S E M _ E L I M --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 1997-2017, Free Software Foundation, Inc. --
|
|
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
|
17 -- for more details. You should have received a copy of the GNU General --
|
|
|
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
|
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 with Atree; use Atree;
|
|
|
27 with Einfo; use Einfo;
|
|
|
28 with Errout; use Errout;
|
|
|
29 with Lib; use Lib;
|
|
|
30 with Namet; use Namet;
|
|
|
31 with Nlists; use Nlists;
|
|
|
32 with Opt; use Opt;
|
|
|
33 with Sem; use Sem;
|
|
|
34 with Sem_Aux; use Sem_Aux;
|
|
|
35 with Sem_Prag; use Sem_Prag;
|
|
|
36 with Sem_Util; use Sem_Util;
|
|
|
37 with Sinput; use Sinput;
|
|
|
38 with Sinfo; use Sinfo;
|
|
|
39 with Snames; use Snames;
|
|
|
40 with Stand; use Stand;
|
|
|
41 with Stringt; use Stringt;
|
|
|
42 with Table;
|
|
|
43
|
|
|
44 with GNAT.HTable; use GNAT.HTable;
|
|
|
45
|
|
|
46 package body Sem_Elim is
|
|
|
47
|
|
|
48 No_Elimination : Boolean;
|
|
|
49 -- Set True if no Eliminate pragmas active
|
|
|
50
|
|
|
51 ---------------------
|
|
|
52 -- Data Structures --
|
|
|
53 ---------------------
|
|
|
54
|
|
|
55 -- A single pragma Eliminate is represented by the following record
|
|
|
56
|
|
|
57 type Elim_Data;
|
|
|
58 type Access_Elim_Data is access Elim_Data;
|
|
|
59
|
|
|
60 type Names is array (Nat range <>) of Name_Id;
|
|
|
61 -- Type used to represent set of names. Used for names in Unit_Name
|
|
|
62 -- and also the set of names in Argument_Types.
|
|
|
63
|
|
|
64 type Access_Names is access Names;
|
|
|
65
|
|
|
66 type Elim_Data is record
|
|
|
67
|
|
|
68 Unit_Name : Access_Names;
|
|
|
69 -- Unit name, broken down into a set of names (e.g. A.B.C is
|
|
|
70 -- represented as Name_Id values for A, B, C in sequence).
|
|
|
71
|
|
|
72 Entity_Name : Name_Id;
|
|
|
73 -- Entity name if Entity parameter if present. If no Entity parameter
|
|
|
74 -- was supplied, then Entity_Node is set to Empty, and the Entity_Name
|
|
|
75 -- field contains the last identifier name in the Unit_Name.
|
|
|
76
|
|
|
77 Entity_Scope : Access_Names;
|
|
|
78 -- Static scope of the entity within the compilation unit represented by
|
|
|
79 -- Unit_Name.
|
|
|
80
|
|
|
81 Entity_Node : Node_Id;
|
|
|
82 -- Save node of entity argument, for posting error messages. Set
|
|
|
83 -- to Empty if there is no entity argument.
|
|
|
84
|
|
|
85 Parameter_Types : Access_Names;
|
|
|
86 -- Set to set of names given for parameter types. If no parameter
|
|
|
87 -- types argument is present, this argument is set to null.
|
|
|
88
|
|
|
89 Result_Type : Name_Id;
|
|
|
90 -- Result type name if Result_Types parameter present, No_Name if not
|
|
|
91
|
|
|
92 Source_Location : Name_Id;
|
|
|
93 -- String describing the source location of subprogram defining name if
|
|
|
94 -- Source_Location parameter present, No_Name if not
|
|
|
95
|
|
|
96 Hash_Link : Access_Elim_Data;
|
|
|
97 -- Link for hash table use
|
|
|
98
|
|
|
99 Homonym : Access_Elim_Data;
|
|
|
100 -- Pointer to next entry with same key
|
|
|
101
|
|
|
102 Prag : Node_Id;
|
|
|
103 -- Node_Id for Eliminate pragma
|
|
|
104
|
|
|
105 end record;
|
|
|
106
|
|
|
107 ----------------
|
|
|
108 -- Hash_Table --
|
|
|
109 ----------------
|
|
|
110
|
|
|
111 -- Setup hash table using the Entity_Name field as the hash key
|
|
|
112
|
|
|
113 subtype Element is Elim_Data;
|
|
|
114 subtype Elmt_Ptr is Access_Elim_Data;
|
|
|
115
|
|
|
116 subtype Key is Name_Id;
|
|
|
117
|
|
|
118 type Header_Num is range 0 .. 1023;
|
|
|
119
|
|
|
120 Null_Ptr : constant Elmt_Ptr := null;
|
|
|
121
|
|
|
122 ----------------------
|
|
|
123 -- Hash_Subprograms --
|
|
|
124 ----------------------
|
|
|
125
|
|
|
126 package Hash_Subprograms is
|
|
|
127
|
|
|
128 function Equal (F1, F2 : Key) return Boolean;
|
|
|
129 pragma Inline (Equal);
|
|
|
130
|
|
|
131 function Get_Key (E : Elmt_Ptr) return Key;
|
|
|
132 pragma Inline (Get_Key);
|
|
|
133
|
|
|
134 function Hash (F : Key) return Header_Num;
|
|
|
135 pragma Inline (Hash);
|
|
|
136
|
|
|
137 function Next (E : Elmt_Ptr) return Elmt_Ptr;
|
|
|
138 pragma Inline (Next);
|
|
|
139
|
|
|
140 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
|
|
|
141 pragma Inline (Set_Next);
|
|
|
142
|
|
|
143 end Hash_Subprograms;
|
|
|
144
|
|
|
145 package body Hash_Subprograms is
|
|
|
146
|
|
|
147 -----------
|
|
|
148 -- Equal --
|
|
|
149 -----------
|
|
|
150
|
|
|
151 function Equal (F1, F2 : Key) return Boolean is
|
|
|
152 begin
|
|
|
153 return F1 = F2;
|
|
|
154 end Equal;
|
|
|
155
|
|
|
156 -------------
|
|
|
157 -- Get_Key --
|
|
|
158 -------------
|
|
|
159
|
|
|
160 function Get_Key (E : Elmt_Ptr) return Key is
|
|
|
161 begin
|
|
|
162 return E.Entity_Name;
|
|
|
163 end Get_Key;
|
|
|
164
|
|
|
165 ----------
|
|
|
166 -- Hash --
|
|
|
167 ----------
|
|
|
168
|
|
|
169 function Hash (F : Key) return Header_Num is
|
|
|
170 begin
|
|
|
171 return Header_Num (Int (F) mod 1024);
|
|
|
172 end Hash;
|
|
|
173
|
|
|
174 ----------
|
|
|
175 -- Next --
|
|
|
176 ----------
|
|
|
177
|
|
|
178 function Next (E : Elmt_Ptr) return Elmt_Ptr is
|
|
|
179 begin
|
|
|
180 return E.Hash_Link;
|
|
|
181 end Next;
|
|
|
182
|
|
|
183 --------------
|
|
|
184 -- Set_Next --
|
|
|
185 --------------
|
|
|
186
|
|
|
187 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
|
|
|
188 begin
|
|
|
189 E.Hash_Link := Next;
|
|
|
190 end Set_Next;
|
|
|
191 end Hash_Subprograms;
|
|
|
192
|
|
|
193 ------------
|
|
|
194 -- Tables --
|
|
|
195 ------------
|
|
|
196
|
|
|
197 -- The following table records the data for each pragma, using the
|
|
|
198 -- entity name as the hash key for retrieval. Entries in this table
|
|
|
199 -- are set by Process_Eliminate_Pragma and read by Check_Eliminated.
|
|
|
200
|
|
|
201 package Elim_Hash_Table is new Static_HTable (
|
|
|
202 Header_Num => Header_Num,
|
|
|
203 Element => Element,
|
|
|
204 Elmt_Ptr => Elmt_Ptr,
|
|
|
205 Null_Ptr => Null_Ptr,
|
|
|
206 Set_Next => Hash_Subprograms.Set_Next,
|
|
|
207 Next => Hash_Subprograms.Next,
|
|
|
208 Key => Key,
|
|
|
209 Get_Key => Hash_Subprograms.Get_Key,
|
|
|
210 Hash => Hash_Subprograms.Hash,
|
|
|
211 Equal => Hash_Subprograms.Equal);
|
|
|
212
|
|
|
213 -- The following table records entities for subprograms that are
|
|
|
214 -- eliminated, and corresponding eliminate pragmas that caused the
|
|
|
215 -- elimination. Entries in this table are set by Check_Eliminated
|
|
|
216 -- and read by Eliminate_Error_Msg.
|
|
|
217
|
|
|
218 type Elim_Entity_Entry is record
|
|
|
219 Prag : Node_Id;
|
|
|
220 Subp : Entity_Id;
|
|
|
221 end record;
|
|
|
222
|
|
|
223 package Elim_Entities is new Table.Table (
|
|
|
224 Table_Component_Type => Elim_Entity_Entry,
|
|
|
225 Table_Index_Type => Name_Id'Base,
|
|
|
226 Table_Low_Bound => First_Name_Id,
|
|
|
227 Table_Initial => 50,
|
|
|
228 Table_Increment => 200,
|
|
|
229 Table_Name => "Elim_Entries");
|
|
|
230
|
|
|
231 ----------------------
|
|
|
232 -- Check_Eliminated --
|
|
|
233 ----------------------
|
|
|
234
|
|
|
235 procedure Check_Eliminated (E : Entity_Id) is
|
|
|
236 Elmt : Access_Elim_Data;
|
|
|
237 Scop : Entity_Id;
|
|
|
238 Form : Entity_Id;
|
|
|
239 Up : Nat;
|
|
|
240
|
|
|
241 begin
|
|
|
242 if No_Elimination then
|
|
|
243 return;
|
|
|
244
|
|
|
245 -- Elimination of objects and types is not implemented yet
|
|
|
246
|
|
|
247 elsif Ekind (E) not in Subprogram_Kind then
|
|
|
248 return;
|
|
|
249 end if;
|
|
|
250
|
|
|
251 -- Loop through homonyms for this key
|
|
|
252
|
|
|
253 Elmt := Elim_Hash_Table.Get (Chars (E));
|
|
|
254 while Elmt /= null loop
|
|
|
255 Check_Homonyms : declare
|
|
|
256 procedure Set_Eliminated;
|
|
|
257 -- Set current subprogram entity as eliminated
|
|
|
258
|
|
|
259 --------------------
|
|
|
260 -- Set_Eliminated --
|
|
|
261 --------------------
|
|
|
262
|
|
|
263 procedure Set_Eliminated is
|
|
|
264 Overridden : Entity_Id;
|
|
|
265
|
|
|
266 begin
|
|
|
267 if Is_Dispatching_Operation (E) then
|
|
|
268
|
|
|
269 -- If an overriding dispatching primitive is eliminated then
|
|
|
270 -- its parent must have been eliminated. If the parent is an
|
|
|
271 -- inherited operation, check the operation that it renames,
|
|
|
272 -- because flag Eliminated is only set on source operations.
|
|
|
273
|
|
|
274 Overridden := Overridden_Operation (E);
|
|
|
275
|
|
|
276 if Present (Overridden)
|
|
|
277 and then not Comes_From_Source (Overridden)
|
|
|
278 and then Present (Alias (Overridden))
|
|
|
279 then
|
|
|
280 Overridden := Alias (Overridden);
|
|
|
281 end if;
|
|
|
282
|
|
|
283 if Present (Overridden)
|
|
|
284 and then not Is_Eliminated (Overridden)
|
|
|
285 and then not Is_Abstract_Subprogram (Overridden)
|
|
|
286 then
|
|
|
287 Error_Msg_Name_1 := Chars (E);
|
|
|
288 Error_Msg_N ("cannot eliminate subprogram %", E);
|
|
|
289 return;
|
|
|
290 end if;
|
|
|
291 end if;
|
|
|
292
|
|
|
293 Set_Is_Eliminated (E);
|
|
|
294 Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E));
|
|
|
295 end Set_Eliminated;
|
|
|
296
|
|
|
297 -- Start of processing for Check_Homonyms
|
|
|
298
|
|
|
299 begin
|
|
|
300 -- First we check that the name of the entity matches
|
|
|
301
|
|
|
302 if Elmt.Entity_Name /= Chars (E) then
|
|
|
303 goto Continue;
|
|
|
304 end if;
|
|
|
305
|
|
|
306 -- Find enclosing unit, and verify that its name and those of its
|
|
|
307 -- parents match.
|
|
|
308
|
|
|
309 Scop := Cunit_Entity (Current_Sem_Unit);
|
|
|
310
|
|
|
311 -- Now see if compilation unit matches
|
|
|
312
|
|
|
313 Up := Elmt.Unit_Name'Last;
|
|
|
314
|
|
|
315 -- If we are within a subunit, the name in the pragma has been
|
|
|
316 -- parsed as a child unit, but the current compilation unit is in
|
|
|
317 -- fact the parent in which the subunit is embedded. We must skip
|
|
|
318 -- the first name which is that of the subunit to match the pragma
|
|
|
319 -- specification. Body may be that of a package or subprogram.
|
|
|
320
|
|
|
321 declare
|
|
|
322 Par : Node_Id;
|
|
|
323
|
|
|
324 begin
|
|
|
325 Par := Parent (E);
|
|
|
326 while Present (Par) loop
|
|
|
327 if Nkind (Par) = N_Subunit then
|
|
|
328 if Chars (Defining_Entity (Proper_Body (Par))) =
|
|
|
329 Elmt.Unit_Name (Up)
|
|
|
330 then
|
|
|
331 Up := Up - 1;
|
|
|
332 exit;
|
|
|
333
|
|
|
334 else
|
|
|
335 goto Continue;
|
|
|
336 end if;
|
|
|
337 end if;
|
|
|
338
|
|
|
339 Par := Parent (Par);
|
|
|
340 end loop;
|
|
|
341 end;
|
|
|
342
|
|
|
343 for J in reverse Elmt.Unit_Name'First .. Up loop
|
|
|
344 if Elmt.Unit_Name (J) /= Chars (Scop) then
|
|
|
345 goto Continue;
|
|
|
346 end if;
|
|
|
347
|
|
|
348 Scop := Scope (Scop);
|
|
|
349
|
|
|
350 if Scop /= Standard_Standard and then J = 1 then
|
|
|
351 goto Continue;
|
|
|
352 end if;
|
|
|
353 end loop;
|
|
|
354
|
|
|
355 if Scop /= Standard_Standard then
|
|
|
356 goto Continue;
|
|
|
357 end if;
|
|
|
358
|
|
|
359 if Present (Elmt.Entity_Node)
|
|
|
360 and then Elmt.Entity_Scope /= null
|
|
|
361 then
|
|
|
362 -- Check that names of enclosing scopes match. Skip blocks and
|
|
|
363 -- wrapper package of subprogram instances, which do not appear
|
|
|
364 -- in the pragma.
|
|
|
365
|
|
|
366 Scop := Scope (E);
|
|
|
367
|
|
|
368 for J in reverse Elmt.Entity_Scope'Range loop
|
|
|
369 while Ekind (Scop) = E_Block
|
|
|
370 or else
|
|
|
371 (Ekind (Scop) = E_Package
|
|
|
372 and then Is_Wrapper_Package (Scop))
|
|
|
373 loop
|
|
|
374 Scop := Scope (Scop);
|
|
|
375 end loop;
|
|
|
376
|
|
|
377 if Elmt.Entity_Scope (J) /= Chars (Scop) then
|
|
|
378 if Ekind (Scop) /= E_Protected_Type
|
|
|
379 or else Comes_From_Source (Scop)
|
|
|
380 then
|
|
|
381 goto Continue;
|
|
|
382
|
|
|
383 -- For simple protected declarations, retrieve the source
|
|
|
384 -- name of the object, which appeared in the Eliminate
|
|
|
385 -- pragma.
|
|
|
386
|
|
|
387 else
|
|
|
388 declare
|
|
|
389 Decl : constant Node_Id :=
|
|
|
390 Original_Node (Parent (Scop));
|
|
|
391
|
|
|
392 begin
|
|
|
393 if Elmt.Entity_Scope (J) /=
|
|
|
394 Chars (Defining_Identifier (Decl))
|
|
|
395 then
|
|
|
396 if J > 0 then
|
|
|
397 null;
|
|
|
398 end if;
|
|
|
399 goto Continue;
|
|
|
400 end if;
|
|
|
401 end;
|
|
|
402 end if;
|
|
|
403
|
|
|
404 end if;
|
|
|
405
|
|
|
406 Scop := Scope (Scop);
|
|
|
407 end loop;
|
|
|
408 end if;
|
|
|
409
|
|
|
410 -- If given entity is a library level subprogram and pragma had a
|
|
|
411 -- single parameter, a match.
|
|
|
412
|
|
|
413 if Is_Compilation_Unit (E)
|
|
|
414 and then Is_Subprogram (E)
|
|
|
415 and then No (Elmt.Entity_Node)
|
|
|
416 then
|
|
|
417 Set_Eliminated;
|
|
|
418 return;
|
|
|
419
|
|
|
420 -- Check for case of type or object with two parameter case
|
|
|
421
|
|
|
422 elsif (Is_Type (E) or else Is_Object (E))
|
|
|
423 and then Elmt.Result_Type = No_Name
|
|
|
424 and then Elmt.Parameter_Types = null
|
|
|
425 then
|
|
|
426 Set_Eliminated;
|
|
|
427 return;
|
|
|
428
|
|
|
429 -- Check for case of subprogram
|
|
|
430
|
|
|
431 elsif Ekind_In (E, E_Function, E_Procedure) then
|
|
|
432
|
|
|
433 -- If Source_Location present, then see if it matches
|
|
|
434
|
|
|
435 if Elmt.Source_Location /= No_Name then
|
|
|
436 Get_Name_String (Elmt.Source_Location);
|
|
|
437
|
|
|
438 declare
|
|
|
439 Sloc_Trace : constant String :=
|
|
|
440 Name_Buffer (1 .. Name_Len);
|
|
|
441
|
|
|
442 Idx : Natural := Sloc_Trace'First;
|
|
|
443 -- Index in Sloc_Trace, if equals to 0, then we have
|
|
|
444 -- completely traversed Sloc_Trace
|
|
|
445
|
|
|
446 Last : constant Natural := Sloc_Trace'Last;
|
|
|
447
|
|
|
448 P : Source_Ptr;
|
|
|
449 Sindex : Source_File_Index;
|
|
|
450
|
|
|
451 function File_Name_Match return Boolean;
|
|
|
452 -- This function is supposed to be called when Idx points
|
|
|
453 -- to the beginning of the new file name, and Name_Buffer
|
|
|
454 -- is set to contain the name of the proper source file
|
|
|
455 -- from the chain corresponding to the Sloc of E. First
|
|
|
456 -- it checks that these two files have the same name. If
|
|
|
457 -- this check is successful, moves Idx to point to the
|
|
|
458 -- beginning of the column number.
|
|
|
459
|
|
|
460 function Line_Num_Match return Boolean;
|
|
|
461 -- This function is supposed to be called when Idx points
|
|
|
462 -- to the beginning of the column number, and P is
|
|
|
463 -- set to point to the proper Sloc the chain
|
|
|
464 -- corresponding to the Sloc of E. First it checks that
|
|
|
465 -- the line number Idx points on and the line number
|
|
|
466 -- corresponding to P are the same. If this check is
|
|
|
467 -- successful, moves Idx to point to the beginning of
|
|
|
468 -- the next file name in Sloc_Trace. If there is no file
|
|
|
469 -- name any more, Idx is set to 0.
|
|
|
470
|
|
|
471 function Different_Trace_Lengths return Boolean;
|
|
|
472 -- From Idx and P, defines if there are in both traces
|
|
|
473 -- more element(s) in the instantiation chains. Returns
|
|
|
474 -- False if one trace contains more element(s), but
|
|
|
475 -- another does not. If both traces contains more
|
|
|
476 -- elements (that is, the function returns False), moves
|
|
|
477 -- P ahead in the chain corresponding to E, recomputes
|
|
|
478 -- Sindex and sets the name of the corresponding file in
|
|
|
479 -- Name_Buffer
|
|
|
480
|
|
|
481 function Skip_Spaces return Natural;
|
|
|
482 -- If Sloc_Trace (Idx) is not space character, returns
|
|
|
483 -- Idx. Otherwise returns the index of the nearest
|
|
|
484 -- non-space character in Sloc_Trace to the right of Idx.
|
|
|
485 -- Returns 0 if there is no such character.
|
|
|
486
|
|
|
487 -----------------------------
|
|
|
488 -- Different_Trace_Lengths --
|
|
|
489 -----------------------------
|
|
|
490
|
|
|
491 function Different_Trace_Lengths return Boolean is
|
|
|
492 begin
|
|
|
493 P := Instantiation (Sindex);
|
|
|
494
|
|
|
495 if (P = No_Location and then Idx /= 0)
|
|
|
496 or else
|
|
|
497 (P /= No_Location and then Idx = 0)
|
|
|
498 then
|
|
|
499 return True;
|
|
|
500
|
|
|
501 else
|
|
|
502 if P /= No_Location then
|
|
|
503 Sindex := Get_Source_File_Index (P);
|
|
|
504 Get_Name_String (File_Name (Sindex));
|
|
|
505 end if;
|
|
|
506
|
|
|
507 return False;
|
|
|
508 end if;
|
|
|
509 end Different_Trace_Lengths;
|
|
|
510
|
|
|
511 ---------------------
|
|
|
512 -- File_Name_Match --
|
|
|
513 ---------------------
|
|
|
514
|
|
|
515 function File_Name_Match return Boolean is
|
|
|
516 Tmp_Idx : Natural;
|
|
|
517 End_Idx : Natural;
|
|
|
518
|
|
|
519 begin
|
|
|
520 if Idx = 0 then
|
|
|
521 return False;
|
|
|
522 end if;
|
|
|
523
|
|
|
524 -- Find first colon. If no colon, then return False.
|
|
|
525 -- If there is a colon, Tmp_Idx is set to point just
|
|
|
526 -- before the colon.
|
|
|
527
|
|
|
528 Tmp_Idx := Idx - 1;
|
|
|
529 loop
|
|
|
530 if Tmp_Idx >= Last then
|
|
|
531 return False;
|
|
|
532 elsif Sloc_Trace (Tmp_Idx + 1) = ':' then
|
|
|
533 exit;
|
|
|
534 else
|
|
|
535 Tmp_Idx := Tmp_Idx + 1;
|
|
|
536 end if;
|
|
|
537 end loop;
|
|
|
538
|
|
|
539 -- Find last non-space before this colon. If there is
|
|
|
540 -- no space character before this colon, then return
|
|
|
541 -- False. Otherwise, End_Idx is set to point to this
|
|
|
542 -- non-space character.
|
|
|
543
|
|
|
544 End_Idx := Tmp_Idx;
|
|
|
545 loop
|
|
|
546 if End_Idx < Idx then
|
|
|
547 return False;
|
|
|
548
|
|
|
549 elsif Sloc_Trace (End_Idx) /= ' ' then
|
|
|
550 exit;
|
|
|
551
|
|
|
552 else
|
|
|
553 End_Idx := End_Idx - 1;
|
|
|
554 end if;
|
|
|
555 end loop;
|
|
|
556
|
|
|
557 -- Now see if file name matches what is in Name_Buffer
|
|
|
558 -- and if so, step Idx past it and return True. If the
|
|
|
559 -- name does not match, return False.
|
|
|
560
|
|
|
561 if Sloc_Trace (Idx .. End_Idx) =
|
|
|
562 Name_Buffer (1 .. Name_Len)
|
|
|
563 then
|
|
|
564 Idx := Tmp_Idx + 2;
|
|
|
565 Idx := Skip_Spaces;
|
|
|
566 return True;
|
|
|
567 else
|
|
|
568 return False;
|
|
|
569 end if;
|
|
|
570 end File_Name_Match;
|
|
|
571
|
|
|
572 --------------------
|
|
|
573 -- Line_Num_Match --
|
|
|
574 --------------------
|
|
|
575
|
|
|
576 function Line_Num_Match return Boolean is
|
|
|
577 N : Nat := 0;
|
|
|
578
|
|
|
579 begin
|
|
|
580 if Idx = 0 then
|
|
|
581 return False;
|
|
|
582 end if;
|
|
|
583
|
|
|
584 while Idx <= Last
|
|
|
585 and then Sloc_Trace (Idx) in '0' .. '9'
|
|
|
586 loop
|
|
|
587 N := N * 10 +
|
|
|
588 (Character'Pos (Sloc_Trace (Idx)) -
|
|
|
589 Character'Pos ('0'));
|
|
|
590 Idx := Idx + 1;
|
|
|
591 end loop;
|
|
|
592
|
|
|
593 if Get_Physical_Line_Number (P) =
|
|
|
594 Physical_Line_Number (N)
|
|
|
595 then
|
|
|
596 while Idx <= Last and then
|
|
|
597 Sloc_Trace (Idx) /= '['
|
|
|
598 loop
|
|
|
599 Idx := Idx + 1;
|
|
|
600 end loop;
|
|
|
601
|
|
|
602 if Idx <= Last then
|
|
|
603 pragma Assert (Sloc_Trace (Idx) = '[');
|
|
|
604 Idx := Idx + 1;
|
|
|
605 Idx := Skip_Spaces;
|
|
|
606 else
|
|
|
607 Idx := 0;
|
|
|
608 end if;
|
|
|
609
|
|
|
610 return True;
|
|
|
611
|
|
|
612 else
|
|
|
613 return False;
|
|
|
614 end if;
|
|
|
615 end Line_Num_Match;
|
|
|
616
|
|
|
617 -----------------
|
|
|
618 -- Skip_Spaces --
|
|
|
619 -----------------
|
|
|
620
|
|
|
621 function Skip_Spaces return Natural is
|
|
|
622 Res : Natural;
|
|
|
623
|
|
|
624 begin
|
|
|
625 Res := Idx;
|
|
|
626 while Sloc_Trace (Res) = ' ' loop
|
|
|
627 Res := Res + 1;
|
|
|
628
|
|
|
629 if Res > Last then
|
|
|
630 Res := 0;
|
|
|
631 exit;
|
|
|
632 end if;
|
|
|
633 end loop;
|
|
|
634
|
|
|
635 return Res;
|
|
|
636 end Skip_Spaces;
|
|
|
637
|
|
|
638 begin
|
|
|
639 P := Sloc (E);
|
|
|
640 Sindex := Get_Source_File_Index (P);
|
|
|
641 Get_Name_String (File_Name (Sindex));
|
|
|
642
|
|
|
643 Idx := Skip_Spaces;
|
|
|
644 while Idx > 0 loop
|
|
|
645 if not File_Name_Match then
|
|
|
646 goto Continue;
|
|
|
647 elsif not Line_Num_Match then
|
|
|
648 goto Continue;
|
|
|
649 end if;
|
|
|
650
|
|
|
651 if Different_Trace_Lengths then
|
|
|
652 goto Continue;
|
|
|
653 end if;
|
|
|
654 end loop;
|
|
|
655 end;
|
|
|
656 end if;
|
|
|
657
|
|
|
658 -- If we have a Result_Type, then we must have a function with
|
|
|
659 -- the proper result type.
|
|
|
660
|
|
|
661 if Elmt.Result_Type /= No_Name then
|
|
|
662 if Ekind (E) /= E_Function
|
|
|
663 or else Chars (Etype (E)) /= Elmt.Result_Type
|
|
|
664 then
|
|
|
665 goto Continue;
|
|
|
666 end if;
|
|
|
667 end if;
|
|
|
668
|
|
|
669 -- If we have Parameter_Types, they must match
|
|
|
670
|
|
|
671 if Elmt.Parameter_Types /= null then
|
|
|
672 Form := First_Formal (E);
|
|
|
673
|
|
|
674 if No (Form)
|
|
|
675 and then Elmt.Parameter_Types'Length = 1
|
|
|
676 and then Elmt.Parameter_Types (1) = No_Name
|
|
|
677 then
|
|
|
678 -- Parameterless procedure matches
|
|
|
679
|
|
|
680 null;
|
|
|
681
|
|
|
682 elsif Elmt.Parameter_Types = null then
|
|
|
683 goto Continue;
|
|
|
684
|
|
|
685 else
|
|
|
686 for J in Elmt.Parameter_Types'Range loop
|
|
|
687 if No (Form)
|
|
|
688 or else
|
|
|
689 Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
|
|
|
690 then
|
|
|
691 goto Continue;
|
|
|
692 else
|
|
|
693 Next_Formal (Form);
|
|
|
694 end if;
|
|
|
695 end loop;
|
|
|
696
|
|
|
697 if Present (Form) then
|
|
|
698 goto Continue;
|
|
|
699 end if;
|
|
|
700 end if;
|
|
|
701 end if;
|
|
|
702
|
|
|
703 -- If we fall through, this is match
|
|
|
704
|
|
|
705 Set_Eliminated;
|
|
|
706 return;
|
|
|
707 end if;
|
|
|
708 end Check_Homonyms;
|
|
|
709
|
|
|
710 <<Continue>>
|
|
|
711 Elmt := Elmt.Homonym;
|
|
|
712 end loop;
|
|
|
713
|
|
|
714 return;
|
|
|
715 end Check_Eliminated;
|
|
|
716
|
|
|
717 -------------------------------------
|
|
|
718 -- Check_For_Eliminated_Subprogram --
|
|
|
719 -------------------------------------
|
|
|
720
|
|
|
721 procedure Check_For_Eliminated_Subprogram (N : Node_Id; S : Entity_Id) is
|
|
|
722 Ultimate_Subp : constant Entity_Id := Ultimate_Alias (S);
|
|
|
723 Enclosing_Subp : Entity_Id;
|
|
|
724
|
|
|
725 begin
|
|
|
726 -- No check needed within a default expression for a formal, since this
|
|
|
727 -- is not really a use, and the expression (a call or attribute) may
|
|
|
728 -- never be used if the enclosing subprogram is itself eliminated.
|
|
|
729
|
|
|
730 if In_Spec_Expression then
|
|
|
731 return;
|
|
|
732 end if;
|
|
|
733
|
|
|
734 if Is_Eliminated (Ultimate_Subp)
|
|
|
735 and then not Inside_A_Generic
|
|
|
736 and then not Is_Generic_Unit (Cunit_Entity (Current_Sem_Unit))
|
|
|
737 then
|
|
|
738 Enclosing_Subp := Current_Subprogram;
|
|
|
739 while Present (Enclosing_Subp) loop
|
|
|
740 if Is_Eliminated (Enclosing_Subp) then
|
|
|
741 return;
|
|
|
742 end if;
|
|
|
743
|
|
|
744 Enclosing_Subp := Enclosing_Subprogram (Enclosing_Subp);
|
|
|
745 end loop;
|
|
|
746
|
|
|
747 -- Emit error, unless we are within an instance body and the expander
|
|
|
748 -- is disabled, indicating an instance within an enclosing generic.
|
|
|
749 -- In an instance, the ultimate alias is an internal entity, so place
|
|
|
750 -- the message on the original subprogram.
|
|
|
751
|
|
|
752 if In_Instance_Body and then not Expander_Active then
|
|
|
753 null;
|
|
|
754
|
|
|
755 elsif Comes_From_Source (Ultimate_Subp) then
|
|
|
756 Eliminate_Error_Msg (N, Ultimate_Subp);
|
|
|
757
|
|
|
758 else
|
|
|
759 Eliminate_Error_Msg (N, S);
|
|
|
760 end if;
|
|
|
761 end if;
|
|
|
762 end Check_For_Eliminated_Subprogram;
|
|
|
763
|
|
|
764 -------------------------
|
|
|
765 -- Eliminate_Error_Msg --
|
|
|
766 -------------------------
|
|
|
767
|
|
|
768 procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id) is
|
|
|
769 begin
|
|
|
770 for J in Elim_Entities.First .. Elim_Entities.Last loop
|
|
|
771 if E = Elim_Entities.Table (J).Subp then
|
|
|
772 Error_Msg_Sloc := Sloc (Elim_Entities.Table (J).Prag);
|
|
|
773 Error_Msg_NE ("cannot reference subprogram & eliminated #", N, E);
|
|
|
774 return;
|
|
|
775 end if;
|
|
|
776 end loop;
|
|
|
777
|
|
|
778 -- If this is an internal operation generated for a protected operation,
|
|
|
779 -- its name does not match the source name, so just report the error.
|
|
|
780
|
|
|
781 if not Comes_From_Source (E)
|
|
|
782 and then Present (First_Entity (E))
|
|
|
783 and then Is_Concurrent_Record_Type (Etype (First_Entity (E)))
|
|
|
784 then
|
|
|
785 Error_Msg_NE
|
|
|
786 ("cannot reference eliminated protected subprogram", N, E);
|
|
|
787
|
|
|
788 -- Otherwise should not fall through, entry should be in table
|
|
|
789
|
|
|
790 else
|
|
|
791 Error_Msg_NE
|
|
|
792 ("subprogram& is called but its alias is eliminated", N, E);
|
|
|
793 -- raise Program_Error;
|
|
|
794 end if;
|
|
|
795 end Eliminate_Error_Msg;
|
|
|
796
|
|
|
797 ----------------
|
|
|
798 -- Initialize --
|
|
|
799 ----------------
|
|
|
800
|
|
|
801 procedure Initialize is
|
|
|
802 begin
|
|
|
803 Elim_Hash_Table.Reset;
|
|
|
804 Elim_Entities.Init;
|
|
|
805 No_Elimination := True;
|
|
|
806 end Initialize;
|
|
|
807
|
|
|
808 ------------------------------
|
|
|
809 -- Process_Eliminate_Pragma --
|
|
|
810 ------------------------------
|
|
|
811
|
|
|
812 procedure Process_Eliminate_Pragma
|
|
|
813 (Pragma_Node : Node_Id;
|
|
|
814 Arg_Unit_Name : Node_Id;
|
|
|
815 Arg_Entity : Node_Id;
|
|
|
816 Arg_Parameter_Types : Node_Id;
|
|
|
817 Arg_Result_Type : Node_Id;
|
|
|
818 Arg_Source_Location : Node_Id)
|
|
|
819 is
|
|
|
820 Data : constant Access_Elim_Data := new Elim_Data;
|
|
|
821 -- Build result data here
|
|
|
822
|
|
|
823 Elmt : Access_Elim_Data;
|
|
|
824
|
|
|
825 Num_Names : Nat := 0;
|
|
|
826 -- Number of names in unit name
|
|
|
827
|
|
|
828 Lit : Node_Id;
|
|
|
829 Arg_Ent : Entity_Id;
|
|
|
830 Arg_Uname : Node_Id;
|
|
|
831
|
|
|
832 function OK_Selected_Component (N : Node_Id) return Boolean;
|
|
|
833 -- Test if N is a selected component with all identifiers, or a selected
|
|
|
834 -- component whose selector is an operator symbol. As a side effect
|
|
|
835 -- if result is True, sets Num_Names to the number of names present
|
|
|
836 -- (identifiers, and operator if any).
|
|
|
837
|
|
|
838 ---------------------------
|
|
|
839 -- OK_Selected_Component --
|
|
|
840 ---------------------------
|
|
|
841
|
|
|
842 function OK_Selected_Component (N : Node_Id) return Boolean is
|
|
|
843 begin
|
|
|
844 if Nkind (N) = N_Identifier
|
|
|
845 or else Nkind (N) = N_Operator_Symbol
|
|
|
846 then
|
|
|
847 Num_Names := Num_Names + 1;
|
|
|
848 return True;
|
|
|
849
|
|
|
850 elsif Nkind (N) = N_Selected_Component then
|
|
|
851 return OK_Selected_Component (Prefix (N))
|
|
|
852 and then OK_Selected_Component (Selector_Name (N));
|
|
|
853
|
|
|
854 else
|
|
|
855 return False;
|
|
|
856 end if;
|
|
|
857 end OK_Selected_Component;
|
|
|
858
|
|
|
859 -- Start of processing for Process_Eliminate_Pragma
|
|
|
860
|
|
|
861 begin
|
|
|
862 Data.Prag := Pragma_Node;
|
|
|
863 Error_Msg_Name_1 := Name_Eliminate;
|
|
|
864
|
|
|
865 -- Process Unit_Name argument
|
|
|
866
|
|
|
867 if Nkind (Arg_Unit_Name) = N_Identifier then
|
|
|
868 Data.Unit_Name := new Names'(1 => Chars (Arg_Unit_Name));
|
|
|
869 Num_Names := 1;
|
|
|
870
|
|
|
871 elsif OK_Selected_Component (Arg_Unit_Name) then
|
|
|
872 Data.Unit_Name := new Names (1 .. Num_Names);
|
|
|
873
|
|
|
874 Arg_Uname := Arg_Unit_Name;
|
|
|
875 for J in reverse 2 .. Num_Names loop
|
|
|
876 Data.Unit_Name (J) := Chars (Selector_Name (Arg_Uname));
|
|
|
877 Arg_Uname := Prefix (Arg_Uname);
|
|
|
878 end loop;
|
|
|
879
|
|
|
880 Data.Unit_Name (1) := Chars (Arg_Uname);
|
|
|
881
|
|
|
882 else
|
|
|
883 Error_Msg_N
|
|
|
884 ("wrong form for Unit_Name parameter of pragma%", Arg_Unit_Name);
|
|
|
885 return;
|
|
|
886 end if;
|
|
|
887
|
|
|
888 -- Process Entity argument
|
|
|
889
|
|
|
890 if Present (Arg_Entity) then
|
|
|
891 Num_Names := 0;
|
|
|
892
|
|
|
893 if Nkind (Arg_Entity) = N_Identifier
|
|
|
894 or else Nkind (Arg_Entity) = N_Operator_Symbol
|
|
|
895 then
|
|
|
896 Data.Entity_Name := Chars (Arg_Entity);
|
|
|
897 Data.Entity_Node := Arg_Entity;
|
|
|
898 Data.Entity_Scope := null;
|
|
|
899
|
|
|
900 elsif OK_Selected_Component (Arg_Entity) then
|
|
|
901 Data.Entity_Scope := new Names (1 .. Num_Names - 1);
|
|
|
902 Data.Entity_Name := Chars (Selector_Name (Arg_Entity));
|
|
|
903 Data.Entity_Node := Arg_Entity;
|
|
|
904
|
|
|
905 Arg_Ent := Prefix (Arg_Entity);
|
|
|
906 for J in reverse 2 .. Num_Names - 1 loop
|
|
|
907 Data.Entity_Scope (J) := Chars (Selector_Name (Arg_Ent));
|
|
|
908 Arg_Ent := Prefix (Arg_Ent);
|
|
|
909 end loop;
|
|
|
910
|
|
|
911 Data.Entity_Scope (1) := Chars (Arg_Ent);
|
|
|
912
|
|
|
913 elsif Is_Config_Static_String (Arg_Entity) then
|
|
|
914 Data.Entity_Name := Name_Find;
|
|
|
915 Data.Entity_Node := Arg_Entity;
|
|
|
916
|
|
|
917 else
|
|
|
918 return;
|
|
|
919 end if;
|
|
|
920 else
|
|
|
921 Data.Entity_Node := Empty;
|
|
|
922 Data.Entity_Name := Data.Unit_Name (Num_Names);
|
|
|
923 end if;
|
|
|
924
|
|
|
925 -- Process Parameter_Types argument
|
|
|
926
|
|
|
927 if Present (Arg_Parameter_Types) then
|
|
|
928
|
|
|
929 -- Here for aggregate case
|
|
|
930
|
|
|
931 if Nkind (Arg_Parameter_Types) = N_Aggregate then
|
|
|
932 Data.Parameter_Types :=
|
|
|
933 new Names
|
|
|
934 (1 .. List_Length (Expressions (Arg_Parameter_Types)));
|
|
|
935
|
|
|
936 Lit := First (Expressions (Arg_Parameter_Types));
|
|
|
937 for J in Data.Parameter_Types'Range loop
|
|
|
938 if Is_Config_Static_String (Lit) then
|
|
|
939 Data.Parameter_Types (J) := Name_Find;
|
|
|
940 Next (Lit);
|
|
|
941 else
|
|
|
942 return;
|
|
|
943 end if;
|
|
|
944 end loop;
|
|
|
945
|
|
|
946 -- Otherwise we must have case of one name, which looks like a
|
|
|
947 -- parenthesized literal rather than an aggregate.
|
|
|
948
|
|
|
949 elsif Paren_Count (Arg_Parameter_Types) /= 1 then
|
|
|
950 Error_Msg_N
|
|
|
951 ("wrong form for argument of pragma Eliminate",
|
|
|
952 Arg_Parameter_Types);
|
|
|
953 return;
|
|
|
954
|
|
|
955 elsif Is_Config_Static_String (Arg_Parameter_Types) then
|
|
|
956 String_To_Name_Buffer (Strval (Arg_Parameter_Types));
|
|
|
957
|
|
|
958 if Name_Len = 0 then
|
|
|
959
|
|
|
960 -- Parameterless procedure
|
|
|
961
|
|
|
962 Data.Parameter_Types := new Names'(1 => No_Name);
|
|
|
963
|
|
|
964 else
|
|
|
965 Data.Parameter_Types := new Names'(1 => Name_Find);
|
|
|
966 end if;
|
|
|
967
|
|
|
968 else
|
|
|
969 return;
|
|
|
970 end if;
|
|
|
971 end if;
|
|
|
972
|
|
|
973 -- Process Result_Types argument
|
|
|
974
|
|
|
975 if Present (Arg_Result_Type) then
|
|
|
976 if Is_Config_Static_String (Arg_Result_Type) then
|
|
|
977 Data.Result_Type := Name_Find;
|
|
|
978 else
|
|
|
979 return;
|
|
|
980 end if;
|
|
|
981
|
|
|
982 -- Here if no Result_Types argument
|
|
|
983
|
|
|
984 else
|
|
|
985 Data.Result_Type := No_Name;
|
|
|
986 end if;
|
|
|
987
|
|
|
988 -- Process Source_Location argument
|
|
|
989
|
|
|
990 if Present (Arg_Source_Location) then
|
|
|
991 if Is_Config_Static_String (Arg_Source_Location) then
|
|
|
992 Data.Source_Location := Name_Find;
|
|
|
993 else
|
|
|
994 return;
|
|
|
995 end if;
|
|
|
996 else
|
|
|
997 Data.Source_Location := No_Name;
|
|
|
998 end if;
|
|
|
999
|
|
|
1000 Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data));
|
|
|
1001
|
|
|
1002 -- If we already have an entry with this same key, then link
|
|
|
1003 -- it into the chain of entries for this key.
|
|
|
1004
|
|
|
1005 if Elmt /= null then
|
|
|
1006 Data.Homonym := Elmt.Homonym;
|
|
|
1007 Elmt.Homonym := Data;
|
|
|
1008
|
|
|
1009 -- Otherwise create a new entry
|
|
|
1010
|
|
|
1011 else
|
|
|
1012 Elim_Hash_Table.Set (Data);
|
|
|
1013 end if;
|
|
|
1014
|
|
|
1015 No_Elimination := False;
|
|
|
1016 end Process_Eliminate_Pragma;
|
|
|
1017
|
|
|
1018 end Sem_Elim;
|
