1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 1997-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
27 ------------------------------------------------------------------------------
29 with Atree; use Atree;
30 with Einfo; use Einfo;
31 with Errout; use Errout;
32 with Namet; use Namet;
33 with Nlists; use Nlists;
34 with Sinfo; use Sinfo;
35 with Snames; use Snames;
36 with Stand; use Stand;
37 with Stringt; use Stringt;
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 Hash_Link : Access_Elim_Data;
87 -- Link for hash table use
89 Homonym : Access_Elim_Data;
90 -- Pointer to next entry with same key
98 -- Setup hash table using the Entity_Name field as the hash key
100 subtype Element is Elim_Data;
101 subtype Elmt_Ptr is Access_Elim_Data;
103 subtype Key is Name_Id;
105 type Header_Num is range 0 .. 1023;
107 Null_Ptr : constant Elmt_Ptr := null;
109 ----------------------
110 -- Hash_Subprograms --
111 ----------------------
113 package Hash_Subprograms is
115 function Equal (F1, F2 : Key) return Boolean;
116 pragma Inline (Equal);
118 function Get_Key (E : Elmt_Ptr) return Key;
119 pragma Inline (Get_Key);
121 function Hash (F : Key) return Header_Num;
122 pragma Inline (Hash);
124 function Next (E : Elmt_Ptr) return Elmt_Ptr;
125 pragma Inline (Next);
127 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
128 pragma Inline (Set_Next);
130 end Hash_Subprograms;
132 package body Hash_Subprograms is
138 function Equal (F1, F2 : Key) return Boolean is
147 function Get_Key (E : Elmt_Ptr) return Key is
149 return E.Entity_Name;
156 function Hash (F : Key) return Header_Num is
158 return Header_Num (Int (F) mod 1024);
165 function Next (E : Elmt_Ptr) return Elmt_Ptr is
174 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
178 end Hash_Subprograms;
180 package Elim_Hash_Table is new Static_HTable (
181 Header_Num => Header_Num,
183 Elmt_Ptr => Elmt_Ptr,
184 Null_Ptr => Null_Ptr,
185 Set_Next => Hash_Subprograms.Set_Next,
186 Next => Hash_Subprograms.Next,
188 Get_Key => Hash_Subprograms.Get_Key,
189 Hash => Hash_Subprograms.Hash,
190 Equal => Hash_Subprograms.Equal);
192 ----------------------
193 -- Check_Eliminated --
194 ----------------------
196 procedure Check_Eliminated (E : Entity_Id) is
197 Elmt : Access_Elim_Data;
202 if No_Elimination then
205 -- Elimination of objects and types is not implemented yet.
207 elsif Ekind (E) not in Subprogram_Kind then
211 Elmt := Elim_Hash_Table.Get (Chars (E));
213 -- Loop through homonyms for this key
215 while Elmt /= null loop
217 -- First we check that the name of the entity matches
219 if Elmt.Entity_Name /= Chars (E) then
223 -- Then we need to see if the static scope matches within the
227 if Elmt.Entity_Scope /= null then
228 for J in reverse Elmt.Entity_Scope'Range loop
229 if Elmt.Entity_Scope (J) /= Chars (Scop) then
233 Scop := Scope (Scop);
235 if not Is_Compilation_Unit (Scop) and then J = 1 then
241 -- Now see if compilation unit matches
243 for J in reverse Elmt.Unit_Name'Range loop
244 if Elmt.Unit_Name (J) /= Chars (Scop) then
248 Scop := Scope (Scop);
250 if Scop /= Standard_Standard and then J = 1 then
255 if Scop /= Standard_Standard then
259 -- Check for case of given entity is a library level subprogram
260 -- and we have the single parameter Eliminate case, a match!
262 if Is_Compilation_Unit (E)
263 and then Is_Subprogram (E)
264 and then No (Elmt.Entity_Node)
266 Set_Is_Eliminated (E);
269 -- Check for case of type or object with two parameter case
271 elsif (Is_Type (E) or else Is_Object (E))
272 and then Elmt.Result_Type = No_Name
273 and then Elmt.Parameter_Types = null
275 Set_Is_Eliminated (E);
278 -- Check for case of subprogram
280 elsif Ekind (E) = E_Function
281 or else Ekind (E) = E_Procedure
283 -- Two parameter case always matches
285 if Elmt.Result_Type = No_Name
286 and then Elmt.Parameter_Types = null
288 Set_Is_Eliminated (E);
291 -- Here we have a profile, so see if it matches
294 if Ekind (E) = E_Function then
295 if Chars (Etype (E)) /= Elmt.Result_Type then
300 Form := First_Formal (E);
302 if No (Form) and then Elmt.Parameter_Types = null then
303 Set_Is_Eliminated (E);
306 elsif Elmt.Parameter_Types = null then
310 for J in Elmt.Parameter_Types'Range loop
312 or else Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
320 if Present (Form) then
323 Set_Is_Eliminated (E);
330 <<Continue>> Elmt := Elmt.Homonym;
334 end Check_Eliminated;
340 procedure Initialize is
342 Elim_Hash_Table.Reset;
343 No_Elimination := True;
346 ------------------------------
347 -- Process_Eliminate_Pragma --
348 ------------------------------
350 procedure Process_Eliminate_Pragma
351 (Arg_Unit_Name : Node_Id;
352 Arg_Entity : Node_Id;
353 Arg_Parameter_Types : Node_Id;
354 Arg_Result_Type : Node_Id)
356 Argx_Unit_Name : Node_Id;
357 Argx_Entity : Node_Id;
358 Argx_Parameter_Types : Node_Id;
359 Argx_Result_Type : Node_Id;
361 Data : constant Access_Elim_Data := new Elim_Data;
362 -- Build result data here
364 Elmt : Access_Elim_Data;
366 Num_Names : Nat := 0;
367 -- Number of names in unit name
371 function OK_Selected_Component (N : Node_Id) return Boolean;
372 -- Test if N is a selected component with all identifiers, or a
373 -- selected component whose selector is an operator symbol. As a
374 -- side effect if result is True, sets Num_Names to the number
375 -- of names present (identifiers and operator if any).
377 ---------------------------
378 -- OK_Selected_Component --
379 ---------------------------
381 function OK_Selected_Component (N : Node_Id) return Boolean is
383 if Nkind (N) = N_Identifier
384 or else Nkind (N) = N_Operator_Symbol
386 Num_Names := Num_Names + 1;
389 elsif Nkind (N) = N_Selected_Component then
390 return OK_Selected_Component (Prefix (N))
391 and then OK_Selected_Component (Selector_Name (N));
396 end OK_Selected_Component;
398 -- Start of processing for Process_Eliminate_Pragma
401 Error_Msg_Name_1 := Name_Eliminate;
403 -- Process Unit_Name argument
405 Argx_Unit_Name := Expression (Arg_Unit_Name);
407 if Nkind (Argx_Unit_Name) = N_Identifier then
408 Data.Unit_Name := new Names'(1 => Chars (Argx_Unit_Name));
411 elsif OK_Selected_Component (Argx_Unit_Name) then
412 Data.Unit_Name := new Names (1 .. Num_Names);
414 for J in reverse 2 .. Num_Names loop
415 Data.Unit_Name (J) := Chars (Selector_Name (Argx_Unit_Name));
416 Argx_Unit_Name := Prefix (Argx_Unit_Name);
419 Data.Unit_Name (1) := Chars (Argx_Unit_Name);
423 ("wrong form for Unit_Name parameter of pragma%",
428 -- Process Entity argument
430 if Present (Arg_Entity) then
431 Argx_Entity := Expression (Arg_Entity);
434 if Nkind (Argx_Entity) = N_Identifier
435 or else Nkind (Argx_Entity) = N_Operator_Symbol
437 Data.Entity_Name := Chars (Argx_Entity);
438 Data.Entity_Node := Argx_Entity;
439 Data.Entity_Scope := null;
441 elsif OK_Selected_Component (Argx_Entity) then
442 Data.Entity_Scope := new Names (1 .. Num_Names - 1);
443 Data.Entity_Name := Chars (Selector_Name (Argx_Entity));
444 Data.Entity_Node := Argx_Entity;
446 Argx_Entity := Prefix (Argx_Entity);
447 for J in reverse 2 .. Num_Names - 1 loop
448 Data.Entity_Scope (J) := Chars (Selector_Name (Argx_Entity));
449 Argx_Entity := Prefix (Argx_Entity);
452 Data.Entity_Scope (1) := Chars (Argx_Entity);
454 elsif Nkind (Argx_Entity) = N_String_Literal then
455 String_To_Name_Buffer (Strval (Argx_Entity));
456 Data.Entity_Name := Name_Find;
457 Data.Entity_Node := Argx_Entity;
461 ("wrong form for Entity_Argument parameter of pragma%",
466 Data.Entity_Node := Empty;
467 Data.Entity_Name := Data.Unit_Name (Num_Names);
470 -- Process Parameter_Types argument
472 if Present (Arg_Parameter_Types) then
473 Argx_Parameter_Types := Expression (Arg_Parameter_Types);
475 -- Case of one name, which looks like a parenthesized literal
476 -- rather than an aggregate.
478 if Nkind (Argx_Parameter_Types) = N_String_Literal
479 and then Paren_Count (Argx_Parameter_Types) = 1
481 String_To_Name_Buffer (Strval (Argx_Parameter_Types));
482 Data.Parameter_Types := new Names'(1 => Name_Find);
484 -- Otherwise must be an aggregate
486 elsif Nkind (Argx_Parameter_Types) /= N_Aggregate
487 or else Present (Component_Associations (Argx_Parameter_Types))
488 or else No (Expressions (Argx_Parameter_Types))
491 ("Parameter_Types for pragma% must be list of string literals",
492 Argx_Parameter_Types);
495 -- Here for aggregate case
498 Data.Parameter_Types :=
500 (1 .. List_Length (Expressions (Argx_Parameter_Types)));
502 Lit := First (Expressions (Argx_Parameter_Types));
503 for J in Data.Parameter_Types'Range loop
504 if Nkind (Lit) /= N_String_Literal then
506 ("parameter types for pragma% must be string literals",
511 String_To_Name_Buffer (Strval (Lit));
512 Data.Parameter_Types (J) := Name_Find;
518 -- Process Result_Types argument
520 if Present (Arg_Result_Type) then
521 Argx_Result_Type := Expression (Arg_Result_Type);
523 if Nkind (Argx_Result_Type) /= N_String_Literal then
525 ("Result_Type argument for pragma% must be string literal",
530 String_To_Name_Buffer (Strval (Argx_Result_Type));
531 Data.Result_Type := Name_Find;
534 Data.Result_Type := No_Name;
537 -- Now link this new entry into the hash table
539 Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data));
541 -- If we already have an entry with this same key, then link
542 -- it into the chain of entries for this key.
545 Data.Homonym := Elmt.Homonym;
546 Elmt.Homonym := Data;
548 -- Otherwise create a new entry
551 Elim_Hash_Table.Set (Data);
554 No_Elimination := False;
555 end Process_Eliminate_Pragma;