1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1997-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 ------------------------------------------------------------------------------
28 with Atree; use Atree;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Namet; use Namet;
32 with Nlists; use Nlists;
33 with Sinfo; use Sinfo;
34 with Snames; use Snames;
35 with Stand; use Stand;
36 with Stringt; use Stringt;
37 with Uintp; use Uintp;
39 with GNAT.HTable; use GNAT.HTable;
40 package body Sem_Elim is
42 No_Elimination : Boolean;
43 -- Set True if no Eliminate pragmas active
49 -- A single pragma Eliminate is represented by the following record
52 type Access_Elim_Data is access Elim_Data;
54 type Names is array (Nat range <>) of Name_Id;
55 -- Type used to represent set of names. Used for names in Unit_Name
56 -- and also the set of names in Argument_Types.
58 type Access_Names is access Names;
60 type Elim_Data is record
62 Unit_Name : Access_Names;
63 -- Unit name, broken down into a set of names (e.g. A.B.C is
64 -- represented as Name_Id values for A, B, C in sequence).
66 Entity_Name : Name_Id;
67 -- Entity name if Entity parameter if present. If no Entity parameter
68 -- was supplied, then Entity_Node is set to Empty, and the Entity_Name
69 -- field contains the last identifier name in the Unit_Name.
71 Entity_Scope : Access_Names;
72 -- Static scope of the entity within the compilation unit represented by
75 Entity_Node : Node_Id;
76 -- Save node of entity argument, for posting error messages. Set
77 -- to Empty if there is no entity argument.
79 Parameter_Types : Access_Names;
80 -- Set to set of names given for parameter types. If no parameter
81 -- types argument is present, this argument is set to null.
83 Result_Type : Name_Id;
84 -- Result type name if Result_Types parameter present, No_Name if not
86 Homonym_Number : Uint;
87 -- Homonyn number if Homonym_Number parameter present, No_Uint if not.
89 Hash_Link : Access_Elim_Data;
90 -- Link for hash table use
92 Homonym : Access_Elim_Data;
93 -- Pointer to next entry with same key
101 -- Setup hash table using the Entity_Name field as the hash key
103 subtype Element is Elim_Data;
104 subtype Elmt_Ptr is Access_Elim_Data;
106 subtype Key is Name_Id;
108 type Header_Num is range 0 .. 1023;
110 Null_Ptr : constant Elmt_Ptr := null;
112 ----------------------
113 -- Hash_Subprograms --
114 ----------------------
116 package Hash_Subprograms is
118 function Equal (F1, F2 : Key) return Boolean;
119 pragma Inline (Equal);
121 function Get_Key (E : Elmt_Ptr) return Key;
122 pragma Inline (Get_Key);
124 function Hash (F : Key) return Header_Num;
125 pragma Inline (Hash);
127 function Next (E : Elmt_Ptr) return Elmt_Ptr;
128 pragma Inline (Next);
130 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
131 pragma Inline (Set_Next);
133 end Hash_Subprograms;
135 package body Hash_Subprograms is
141 function Equal (F1, F2 : Key) return Boolean is
150 function Get_Key (E : Elmt_Ptr) return Key is
152 return E.Entity_Name;
159 function Hash (F : Key) return Header_Num is
161 return Header_Num (Int (F) mod 1024);
168 function Next (E : Elmt_Ptr) return Elmt_Ptr is
177 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
181 end Hash_Subprograms;
183 package Elim_Hash_Table is new Static_HTable (
184 Header_Num => Header_Num,
186 Elmt_Ptr => Elmt_Ptr,
187 Null_Ptr => Null_Ptr,
188 Set_Next => Hash_Subprograms.Set_Next,
189 Next => Hash_Subprograms.Next,
191 Get_Key => Hash_Subprograms.Get_Key,
192 Hash => Hash_Subprograms.Hash,
193 Equal => Hash_Subprograms.Equal);
195 ----------------------
196 -- Check_Eliminated --
197 ----------------------
199 procedure Check_Eliminated (E : Entity_Id) is
200 Elmt : Access_Elim_Data;
207 if No_Elimination then
210 -- Elimination of objects and types is not implemented yet.
212 elsif Ekind (E) not in Subprogram_Kind then
216 Elmt := Elim_Hash_Table.Get (Chars (E));
218 -- Loop through homonyms for this key
220 while Elmt /= null loop
222 -- First we check that the name of the entity matches
224 if Elmt.Entity_Name /= Chars (E) then
228 -- Then we need to see if the static scope matches within the
232 if Elmt.Entity_Scope /= null then
233 for J in reverse Elmt.Entity_Scope'Range loop
234 if Elmt.Entity_Scope (J) /= Chars (Scop) then
238 Scop := Scope (Scop);
240 if not Is_Compilation_Unit (Scop) and then J = 1 then
246 -- Now see if compilation unit matches
248 for J in reverse Elmt.Unit_Name'Range loop
249 if Elmt.Unit_Name (J) /= Chars (Scop) then
253 Scop := Scope (Scop);
255 if Scop /= Standard_Standard and then J = 1 then
260 if Scop /= Standard_Standard then
264 -- Check for case of given entity is a library level subprogram
265 -- and we have the single parameter Eliminate case, a match!
267 if Is_Compilation_Unit (E)
268 and then Is_Subprogram (E)
269 and then No (Elmt.Entity_Node)
271 Set_Is_Eliminated (E);
274 -- Check for case of type or object with two parameter case
276 elsif (Is_Type (E) or else Is_Object (E))
277 and then Elmt.Result_Type = No_Name
278 and then Elmt.Parameter_Types = null
280 Set_Is_Eliminated (E);
283 -- Check for case of subprogram
285 elsif Ekind (E) = E_Function
286 or else Ekind (E) = E_Procedure
288 -- If Homonym_Number present, then see if it matches
290 if Elmt.Homonym_Number /= No_Uint then
294 while Present (Homonym (Ent))
295 and then Scope (Ent) = Scope (Homonym (Ent))
298 Ent := Homonym (Ent);
301 if Ctr /= Elmt.Homonym_Number then
306 -- If we have a Result_Type, then we must have a function
307 -- with the proper result type
309 if Elmt.Result_Type /= No_Name then
310 if Ekind (E) /= E_Function
311 or else Chars (Etype (E)) /= Elmt.Result_Type
317 -- If we have Parameter_Types, they must match
319 if Elmt.Parameter_Types /= null then
320 Form := First_Formal (E);
322 if No (Form) and then Elmt.Parameter_Types = null then
325 elsif Elmt.Parameter_Types = null then
329 for J in Elmt.Parameter_Types'Range loop
331 or else Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
339 if Present (Form) then
345 -- If we fall through, this is match
347 Set_Is_Eliminated (E);
351 <<Continue>> Elmt := Elmt.Homonym;
355 end Check_Eliminated;
361 procedure Initialize is
363 Elim_Hash_Table.Reset;
364 No_Elimination := True;
367 ------------------------------
368 -- Process_Eliminate_Pragma --
369 ------------------------------
371 procedure Process_Eliminate_Pragma
372 (Arg_Unit_Name : Node_Id;
373 Arg_Entity : Node_Id;
374 Arg_Parameter_Types : Node_Id;
375 Arg_Result_Type : Node_Id;
376 Arg_Homonym_Number : Node_Id)
378 Data : constant Access_Elim_Data := new Elim_Data;
379 -- Build result data here
381 Elmt : Access_Elim_Data;
383 Num_Names : Nat := 0;
384 -- Number of names in unit name
390 function OK_Selected_Component (N : Node_Id) return Boolean;
391 -- Test if N is a selected component with all identifiers, or a
392 -- selected component whose selector is an operator symbol. As a
393 -- side effect if result is True, sets Num_Names to the number
394 -- of names present (identifiers and operator if any).
396 ---------------------------
397 -- OK_Selected_Component --
398 ---------------------------
400 function OK_Selected_Component (N : Node_Id) return Boolean is
402 if Nkind (N) = N_Identifier
403 or else Nkind (N) = N_Operator_Symbol
405 Num_Names := Num_Names + 1;
408 elsif Nkind (N) = N_Selected_Component then
409 return OK_Selected_Component (Prefix (N))
410 and then OK_Selected_Component (Selector_Name (N));
415 end OK_Selected_Component;
417 -- Start of processing for Process_Eliminate_Pragma
420 Error_Msg_Name_1 := Name_Eliminate;
422 -- Process Unit_Name argument
424 if Nkind (Arg_Unit_Name) = N_Identifier then
425 Data.Unit_Name := new Names'(1 => Chars (Arg_Unit_Name));
428 elsif OK_Selected_Component (Arg_Unit_Name) then
429 Data.Unit_Name := new Names (1 .. Num_Names);
431 Arg_Uname := Arg_Unit_Name;
432 for J in reverse 2 .. Num_Names loop
433 Data.Unit_Name (J) := Chars (Selector_Name (Arg_Uname));
434 Arg_Uname := Prefix (Arg_Uname);
437 Data.Unit_Name (1) := Chars (Arg_Uname);
441 ("wrong form for Unit_Name parameter of pragma%", Arg_Unit_Name);
445 -- Process Entity argument
447 if Present (Arg_Entity) then
450 if Nkind (Arg_Entity) = N_Identifier
451 or else Nkind (Arg_Entity) = N_Operator_Symbol
453 Data.Entity_Name := Chars (Arg_Entity);
454 Data.Entity_Node := Arg_Entity;
455 Data.Entity_Scope := null;
457 elsif OK_Selected_Component (Arg_Entity) then
458 Data.Entity_Scope := new Names (1 .. Num_Names - 1);
459 Data.Entity_Name := Chars (Selector_Name (Arg_Entity));
460 Data.Entity_Node := Arg_Entity;
462 Arg_Ent := Prefix (Arg_Entity);
463 for J in reverse 2 .. Num_Names - 1 loop
464 Data.Entity_Scope (J) := Chars (Selector_Name (Arg_Ent));
465 Arg_Ent := Prefix (Arg_Ent);
468 Data.Entity_Scope (1) := Chars (Arg_Ent);
470 elsif Nkind (Arg_Entity) = N_String_Literal then
471 String_To_Name_Buffer (Strval (Arg_Entity));
472 Data.Entity_Name := Name_Find;
473 Data.Entity_Node := Arg_Entity;
477 ("wrong form for Entity_Argument parameter of pragma%",
482 Data.Entity_Node := Empty;
483 Data.Entity_Name := Data.Unit_Name (Num_Names);
486 -- Process Parameter_Types argument
488 if Present (Arg_Parameter_Types) then
490 -- Case of one name, which looks like a parenthesized literal
491 -- rather than an aggregate.
493 if Nkind (Arg_Parameter_Types) = N_String_Literal
494 and then Paren_Count (Arg_Parameter_Types) = 1
496 String_To_Name_Buffer (Strval (Arg_Parameter_Types));
497 Data.Parameter_Types := new Names'(1 => Name_Find);
499 -- Otherwise must be an aggregate
501 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
502 or else Present (Component_Associations (Arg_Parameter_Types))
503 or else No (Expressions (Arg_Parameter_Types))
506 ("Parameter_Types for pragma% must be list of string literals",
507 Arg_Parameter_Types);
510 -- Here for aggregate case
513 Data.Parameter_Types :=
515 (1 .. List_Length (Expressions (Arg_Parameter_Types)));
517 Lit := First (Expressions (Arg_Parameter_Types));
518 for J in Data.Parameter_Types'Range loop
519 if Nkind (Lit) /= N_String_Literal then
521 ("parameter types for pragma% must be string literals",
526 String_To_Name_Buffer (Strval (Lit));
527 Data.Parameter_Types (J) := Name_Find;
533 -- Process Result_Types argument
535 if Present (Arg_Result_Type) then
537 if Nkind (Arg_Result_Type) /= N_String_Literal then
539 ("Result_Type argument for pragma% must be string literal",
544 String_To_Name_Buffer (Strval (Arg_Result_Type));
545 Data.Result_Type := Name_Find;
548 Data.Result_Type := No_Name;
551 -- Process Homonym_Number argument
553 if Present (Arg_Homonym_Number) then
555 if Nkind (Arg_Homonym_Number) /= N_Integer_Literal then
557 ("Homonym_Number argument for pragma% must be integer literal",
562 Data.Homonym_Number := Intval (Arg_Homonym_Number);
565 Data.Homonym_Number := No_Uint;
568 -- Now link this new entry into the hash table
570 Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data));
572 -- If we already have an entry with this same key, then link
573 -- it into the chain of entries for this key.
576 Data.Homonym := Elmt.Homonym;
577 Elmt.Homonym := Data;
579 -- Otherwise create a new entry
582 Elim_Hash_Table.Set (Data);
585 No_Elimination := False;
586 end Process_Eliminate_Pragma;