1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2009, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Einfo
; use Einfo
;
28 with Errout
; use Errout
;
30 with Namet
; use Namet
;
31 with Nlists
; use Nlists
;
33 with Sem_Prag
; use Sem_Prag
;
34 with Sem_Util
; use Sem_Util
;
35 with Sinput
; use Sinput
;
36 with Sinfo
; use Sinfo
;
37 with Snames
; use Snames
;
38 with Stand
; use Stand
;
39 with Stringt
; use Stringt
;
42 with GNAT
.HTable
; use GNAT
.HTable
;
44 package body Sem_Elim
is
46 No_Elimination
: Boolean;
47 -- Set True if no Eliminate pragmas active
53 -- A single pragma Eliminate is represented by the following record
56 type Access_Elim_Data
is access Elim_Data
;
58 type Names
is array (Nat
range <>) of Name_Id
;
59 -- Type used to represent set of names. Used for names in Unit_Name
60 -- and also the set of names in Argument_Types.
62 type Access_Names
is access Names
;
64 type Elim_Data
is record
66 Unit_Name
: Access_Names
;
67 -- Unit name, broken down into a set of names (e.g. A.B.C is
68 -- represented as Name_Id values for A, B, C in sequence).
70 Entity_Name
: Name_Id
;
71 -- Entity name if Entity parameter if present. If no Entity parameter
72 -- was supplied, then Entity_Node is set to Empty, and the Entity_Name
73 -- field contains the last identifier name in the Unit_Name.
75 Entity_Scope
: Access_Names
;
76 -- Static scope of the entity within the compilation unit represented by
79 Entity_Node
: Node_Id
;
80 -- Save node of entity argument, for posting error messages. Set
81 -- to Empty if there is no entity argument.
83 Parameter_Types
: Access_Names
;
84 -- Set to set of names given for parameter types. If no parameter
85 -- types argument is present, this argument is set to null.
87 Result_Type
: Name_Id
;
88 -- Result type name if Result_Types parameter present, No_Name if not
90 Source_Location
: Name_Id
;
91 -- String describing the source location of subprogram defining name if
92 -- Source_Location parameter present, No_Name if not
94 Hash_Link
: Access_Elim_Data
;
95 -- Link for hash table use
97 Homonym
: Access_Elim_Data
;
98 -- Pointer to next entry with same key
101 -- Node_Id for Eliminate pragma
109 -- Setup hash table using the Entity_Name field as the hash key
111 subtype Element
is Elim_Data
;
112 subtype Elmt_Ptr
is Access_Elim_Data
;
114 subtype Key
is Name_Id
;
116 type Header_Num
is range 0 .. 1023;
118 Null_Ptr
: constant Elmt_Ptr
:= null;
120 ----------------------
121 -- Hash_Subprograms --
122 ----------------------
124 package Hash_Subprograms
is
126 function Equal
(F1
, F2
: Key
) return Boolean;
127 pragma Inline
(Equal
);
129 function Get_Key
(E
: Elmt_Ptr
) return Key
;
130 pragma Inline
(Get_Key
);
132 function Hash
(F
: Key
) return Header_Num
;
133 pragma Inline
(Hash
);
135 function Next
(E
: Elmt_Ptr
) return Elmt_Ptr
;
136 pragma Inline
(Next
);
138 procedure Set_Next
(E
: Elmt_Ptr
; Next
: Elmt_Ptr
);
139 pragma Inline
(Set_Next
);
141 end Hash_Subprograms
;
143 package body Hash_Subprograms
is
149 function Equal
(F1
, F2
: Key
) return Boolean is
158 function Get_Key
(E
: Elmt_Ptr
) return Key
is
160 return E
.Entity_Name
;
167 function Hash
(F
: Key
) return Header_Num
is
169 return Header_Num
(Int
(F
) mod 1024);
176 function Next
(E
: Elmt_Ptr
) return Elmt_Ptr
is
185 procedure Set_Next
(E
: Elmt_Ptr
; Next
: Elmt_Ptr
) is
189 end Hash_Subprograms
;
195 -- The following table records the data for each pragmas, using the
196 -- entity name as the hash key for retrieval. Entries in this table
197 -- are set by Process_Eliminate_Pragma and read by Check_Eliminated.
199 package Elim_Hash_Table
is new Static_HTable
(
200 Header_Num
=> Header_Num
,
202 Elmt_Ptr
=> Elmt_Ptr
,
203 Null_Ptr
=> Null_Ptr
,
204 Set_Next
=> Hash_Subprograms
.Set_Next
,
205 Next
=> Hash_Subprograms
.Next
,
207 Get_Key
=> Hash_Subprograms
.Get_Key
,
208 Hash
=> Hash_Subprograms
.Hash
,
209 Equal
=> Hash_Subprograms
.Equal
);
211 -- The following table records entities for subprograms that are
212 -- eliminated, and corresponding eliminate pragmas that caused the
213 -- elimination. Entries in this table are set by Check_Eliminated
214 -- and read by Eliminate_Error_Msg.
216 type Elim_Entity_Entry
is record
221 package Elim_Entities
is new Table
.Table
(
222 Table_Component_Type
=> Elim_Entity_Entry
,
223 Table_Index_Type
=> Name_Id
'Base,
224 Table_Low_Bound
=> First_Name_Id
,
226 Table_Increment
=> 200,
227 Table_Name
=> "Elim_Entries");
229 ----------------------
230 -- Check_Eliminated --
231 ----------------------
233 procedure Check_Eliminated
(E
: Entity_Id
) is
234 Elmt
: Access_Elim_Data
;
239 if No_Elimination
then
242 -- Elimination of objects and types is not implemented yet
244 elsif Ekind
(E
) not in Subprogram_Kind
then
248 -- Loop through homonyms for this key
250 Elmt
:= Elim_Hash_Table
.Get
(Chars
(E
));
251 while Elmt
/= null loop
252 Check_Homonyms
: declare
253 procedure Set_Eliminated
;
254 -- Set current subprogram entity as eliminated
260 procedure Set_Eliminated
is
262 if Is_Dispatching_Operation
(E
) then
264 -- If an overriding dispatching primitive is eliminated then
265 -- its parent must have been eliminated.
267 if Is_Overriding_Operation
(E
)
268 and then not Is_Eliminated
(Overridden_Operation
(E
))
270 Error_Msg_Name_1
:= Chars
(E
);
271 Error_Msg_N
("cannot eliminate subprogram %", E
);
276 Set_Is_Eliminated
(E
);
277 Elim_Entities
.Append
((Prag
=> Elmt
.Prag
, Subp
=> E
));
280 -- Start of processing for Check_Homonyms
283 -- First we check that the name of the entity matches
285 if Elmt
.Entity_Name
/= Chars
(E
) then
289 -- Find enclosing unit
291 Scop
:= Cunit_Entity
(Current_Sem_Unit
);
293 -- Now see if compilation unit matches
295 for J
in reverse Elmt
.Unit_Name
'Range loop
296 if Elmt
.Unit_Name
(J
) /= Chars
(Scop
) then
300 Scop
:= Scope
(Scop
);
301 while Ekind
(Scop
) = E_Block
loop
302 Scop
:= Scope
(Scop
);
305 if Scop
/= Standard_Standard
and then J
= 1 then
310 if Scop
/= Standard_Standard
then
314 -- Check for case of given entity is a library level subprogram
315 -- and we have the single parameter Eliminate case, a match!
317 if Is_Compilation_Unit
(E
)
318 and then Is_Subprogram
(E
)
319 and then No
(Elmt
.Entity_Node
)
324 -- Check for case of type or object with two parameter case
326 elsif (Is_Type
(E
) or else Is_Object
(E
))
327 and then Elmt
.Result_Type
= No_Name
328 and then Elmt
.Parameter_Types
= null
333 -- Check for case of subprogram
335 elsif Ekind
(E
) = E_Function
336 or else Ekind
(E
) = E_Procedure
338 -- If Source_Location present, then see if it matches
340 if Elmt
.Source_Location
/= No_Name
then
341 Get_Name_String
(Elmt
.Source_Location
);
344 Sloc_Trace
: constant String :=
345 Name_Buffer
(1 .. Name_Len
);
347 Idx
: Natural := Sloc_Trace
'First;
348 -- Index in Sloc_Trace, if equals to 0, then we have
349 -- completely traversed Sloc_Trace
351 Last
: constant Natural := Sloc_Trace
'Last;
354 Sindex
: Source_File_Index
;
356 function File_Name_Match
return Boolean;
357 -- This function is supposed to be called when Idx points
358 -- to the beginning of the new file name, and Name_Buffer
359 -- is set to contain the name of the proper source file
360 -- from the chain corresponding to the Sloc of E. First
361 -- it checks that these two files have the same name. If
362 -- this check is successful, moves Idx to point to the
363 -- beginning of the column number.
365 function Line_Num_Match
return Boolean;
366 -- This function is supposed to be called when Idx points
367 -- to the beginning of the column number, and P is
368 -- set to point to the proper Sloc the chain
369 -- corresponding to the Sloc of E. First it checks that
370 -- the line number Idx points on and the line number
371 -- corresponding to P are the same. If this check is
372 -- successful, moves Idx to point to the beginning of
373 -- the next file name in Sloc_Trace. If there is no file
374 -- name any more, Idx is set to 0.
376 function Different_Trace_Lengths
return Boolean;
377 -- From Idx and P, defines if there are in both traces
378 -- more element(s) in the instantiation chains. Returns
379 -- False if one trace contains more element(s), but
380 -- another does not. If both traces contains more
381 -- elements (that is, the function returns False), moves
382 -- P ahead in the chain corresponding to E, recomputes
383 -- Sindex and sets the name of the corresponding file in
386 function Skip_Spaces
return Natural;
387 -- If Sloc_Trace (Idx) is not space character, returns
388 -- Idx. Otherwise returns the index of the nearest
389 -- non-space character in Sloc_Trace to the right of Idx.
390 -- Returns 0 if there is no such character.
392 -----------------------------
393 -- Different_Trace_Lengths --
394 -----------------------------
396 function Different_Trace_Lengths
return Boolean is
398 P
:= Instantiation
(Sindex
);
400 if (P
= No_Location
and then Idx
/= 0)
402 (P
/= No_Location
and then Idx
= 0)
407 if P
/= No_Location
then
408 Sindex
:= Get_Source_File_Index
(P
);
409 Get_Name_String
(File_Name
(Sindex
));
414 end Different_Trace_Lengths
;
416 ---------------------
417 -- File_Name_Match --
418 ---------------------
420 function File_Name_Match
return Boolean is
429 -- Find first colon. If no colon, then return False.
430 -- If there is a colon, Tmp_Idx is set to point just
435 if Tmp_Idx
>= Last
then
437 elsif Sloc_Trace
(Tmp_Idx
+ 1) = ':' then
440 Tmp_Idx
:= Tmp_Idx
+ 1;
444 -- Find last non-space before this colon. If there is
445 -- no space character before this colon, then return
446 -- False. Otherwise, End_Idx is set to point to this
447 -- non-space character.
451 if End_Idx
< Idx
then
454 elsif Sloc_Trace
(End_Idx
) /= ' ' then
458 End_Idx
:= End_Idx
- 1;
462 -- Now see if file name matches what is in Name_Buffer
463 -- and if so, step Idx past it and return True. If the
464 -- name does not match, return False.
466 if Sloc_Trace
(Idx
.. End_Idx
) =
467 Name_Buffer
(1 .. Name_Len
)
481 function Line_Num_Match
return Boolean is
490 and then Sloc_Trace
(Idx
) in '0' .. '9'
493 (Character'Pos (Sloc_Trace
(Idx
)) -
494 Character'Pos ('0'));
498 if Get_Physical_Line_Number
(P
) =
499 Physical_Line_Number
(N
)
501 while Idx
<= Last
and then
502 Sloc_Trace
(Idx
) /= '['
507 if Idx
<= Last
and then
508 Sloc_Trace
(Idx
) = '['
527 function Skip_Spaces
return Natural is
532 while Sloc_Trace
(Res
) = ' ' loop
546 Sindex
:= Get_Source_File_Index
(P
);
547 Get_Name_String
(File_Name
(Sindex
));
551 if not File_Name_Match
then
553 elsif not Line_Num_Match
then
557 if Different_Trace_Lengths
then
564 -- If we have a Result_Type, then we must have a function with
565 -- the proper result type.
567 if Elmt
.Result_Type
/= No_Name
then
568 if Ekind
(E
) /= E_Function
569 or else Chars
(Etype
(E
)) /= Elmt
.Result_Type
575 -- If we have Parameter_Types, they must match
577 if Elmt
.Parameter_Types
/= null then
578 Form
:= First_Formal
(E
);
581 and then Elmt
.Parameter_Types
'Length = 1
582 and then Elmt
.Parameter_Types
(1) = No_Name
584 -- Parameterless procedure matches
588 elsif Elmt
.Parameter_Types
= null then
592 for J
in Elmt
.Parameter_Types
'Range loop
595 Chars
(Etype
(Form
)) /= Elmt
.Parameter_Types
(J
)
603 if Present
(Form
) then
609 -- If we fall through, this is match
617 Elmt
:= Elmt
.Homonym
;
621 end Check_Eliminated
;
623 -------------------------------------
624 -- Check_For_Eliminated_Subprogram --
625 -------------------------------------
627 procedure Check_For_Eliminated_Subprogram
(N
: Node_Id
; S
: Entity_Id
) is
628 Ultimate_Subp
: constant Entity_Id
:= Ultimate_Alias
(S
);
629 Enclosing_Subp
: Entity_Id
;
632 if Is_Eliminated
(Ultimate_Subp
)
633 and then not Inside_A_Generic
634 and then not Is_Generic_Unit
(Cunit_Entity
(Current_Sem_Unit
))
636 Enclosing_Subp
:= Current_Subprogram
;
637 while Present
(Enclosing_Subp
) loop
638 if Is_Eliminated
(Enclosing_Subp
) then
642 Enclosing_Subp
:= Enclosing_Subprogram
(Enclosing_Subp
);
645 Eliminate_Error_Msg
(N
, Ultimate_Subp
);
647 end Check_For_Eliminated_Subprogram
;
649 -------------------------
650 -- Eliminate_Error_Msg --
651 -------------------------
653 procedure Eliminate_Error_Msg
(N
: Node_Id
; E
: Entity_Id
) is
655 for J
in Elim_Entities
.First
.. Elim_Entities
.Last
loop
656 if E
= Elim_Entities
.Table
(J
).Subp
then
657 Error_Msg_Sloc
:= Sloc
(Elim_Entities
.Table
(J
).Prag
);
658 Error_Msg_NE
("cannot reference subprogram & eliminated #", N
, E
);
663 -- If this is an internal operation generated for a protected operation,
664 -- its name does not match the source name, so just report the error.
666 if not Comes_From_Source
(E
)
667 and then Present
(First_Entity
(E
))
668 and then Is_Concurrent_Record_Type
(Etype
(First_Entity
(E
)))
671 ("cannot reference eliminated protected subprogram", N
, E
);
673 -- Otherwise should not fall through, entry should be in table
678 end Eliminate_Error_Msg
;
684 procedure Initialize
is
686 Elim_Hash_Table
.Reset
;
688 No_Elimination
:= True;
691 ------------------------------
692 -- Process_Eliminate_Pragma --
693 ------------------------------
695 procedure Process_Eliminate_Pragma
696 (Pragma_Node
: Node_Id
;
697 Arg_Unit_Name
: Node_Id
;
698 Arg_Entity
: Node_Id
;
699 Arg_Parameter_Types
: Node_Id
;
700 Arg_Result_Type
: Node_Id
;
701 Arg_Source_Location
: Node_Id
)
703 Data
: constant Access_Elim_Data
:= new Elim_Data
;
704 -- Build result data here
706 Elmt
: Access_Elim_Data
;
708 Num_Names
: Nat
:= 0;
709 -- Number of names in unit name
715 function OK_Selected_Component
(N
: Node_Id
) return Boolean;
716 -- Test if N is a selected component with all identifiers, or a
717 -- selected component whose selector is an operator symbol. As a
718 -- side effect if result is True, sets Num_Names to the number
719 -- of names present (identifiers and operator if any).
721 ---------------------------
722 -- OK_Selected_Component --
723 ---------------------------
725 function OK_Selected_Component
(N
: Node_Id
) return Boolean is
727 if Nkind
(N
) = N_Identifier
728 or else Nkind
(N
) = N_Operator_Symbol
730 Num_Names
:= Num_Names
+ 1;
733 elsif Nkind
(N
) = N_Selected_Component
then
734 return OK_Selected_Component
(Prefix
(N
))
735 and then OK_Selected_Component
(Selector_Name
(N
));
740 end OK_Selected_Component
;
742 -- Start of processing for Process_Eliminate_Pragma
745 Data
.Prag
:= Pragma_Node
;
746 Error_Msg_Name_1
:= Name_Eliminate
;
748 -- Process Unit_Name argument
750 if Nkind
(Arg_Unit_Name
) = N_Identifier
then
751 Data
.Unit_Name
:= new Names
'(1 => Chars (Arg_Unit_Name));
754 elsif OK_Selected_Component (Arg_Unit_Name) then
755 Data.Unit_Name := new Names (1 .. Num_Names);
757 Arg_Uname := Arg_Unit_Name;
758 for J in reverse 2 .. Num_Names loop
759 Data.Unit_Name (J) := Chars (Selector_Name (Arg_Uname));
760 Arg_Uname := Prefix (Arg_Uname);
763 Data.Unit_Name (1) := Chars (Arg_Uname);
767 ("wrong form for Unit_Name parameter of pragma%", Arg_Unit_Name);
771 -- Process Entity argument
773 if Present (Arg_Entity) then
776 if Nkind (Arg_Entity) = N_Identifier
777 or else Nkind (Arg_Entity) = N_Operator_Symbol
779 Data.Entity_Name := Chars (Arg_Entity);
780 Data.Entity_Node := Arg_Entity;
781 Data.Entity_Scope := null;
783 elsif OK_Selected_Component (Arg_Entity) then
784 Data.Entity_Scope := new Names (1 .. Num_Names - 1);
785 Data.Entity_Name := Chars (Selector_Name (Arg_Entity));
786 Data.Entity_Node := Arg_Entity;
788 Arg_Ent := Prefix (Arg_Entity);
789 for J in reverse 2 .. Num_Names - 1 loop
790 Data.Entity_Scope (J) := Chars (Selector_Name (Arg_Ent));
791 Arg_Ent := Prefix (Arg_Ent);
794 Data.Entity_Scope (1) := Chars (Arg_Ent);
796 elsif Is_Config_Static_String (Arg_Entity) then
797 Data.Entity_Name := Name_Find;
798 Data.Entity_Node := Arg_Entity;
804 Data.Entity_Node := Empty;
805 Data.Entity_Name := Data.Unit_Name (Num_Names);
808 -- Process Parameter_Types argument
810 if Present (Arg_Parameter_Types) then
812 -- Here for aggregate case
814 if Nkind (Arg_Parameter_Types) = N_Aggregate then
815 Data.Parameter_Types :=
817 (1 .. List_Length (Expressions (Arg_Parameter_Types)));
819 Lit := First (Expressions (Arg_Parameter_Types));
820 for J in Data.Parameter_Types'Range loop
821 if Is_Config_Static_String (Lit) then
822 Data.Parameter_Types (J) := Name_Find;
829 -- Otherwise we must have case of one name, which looks like a
830 -- parenthesized literal rather than an aggregate.
832 elsif Paren_Count (Arg_Parameter_Types) /= 1 then
834 ("wrong form for argument of pragma Eliminate",
835 Arg_Parameter_Types);
838 elsif Is_Config_Static_String (Arg_Parameter_Types) then
839 String_To_Name_Buffer (Strval (Arg_Parameter_Types));
843 -- Parameterless procedure
845 Data.Parameter_Types := new Names'(1 => No_Name
);
848 Data
.Parameter_Types
:= new Names
'(1 => Name_Find);
856 -- Process Result_Types argument
858 if Present (Arg_Result_Type) then
859 if Is_Config_Static_String (Arg_Result_Type) then
860 Data.Result_Type := Name_Find;
865 -- Here if no Result_Types argument
868 Data.Result_Type := No_Name;
871 -- Process Source_Location argument
873 if Present (Arg_Source_Location) then
874 if Is_Config_Static_String (Arg_Source_Location) then
875 Data.Source_Location := Name_Find;
880 Data.Source_Location := No_Name;
883 Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data));
885 -- If we already have an entry with this same key, then link
886 -- it into the chain of entries for this key.
889 Data.Homonym := Elmt.Homonym;
890 Elmt.Homonym := Data;
892 -- Otherwise create a new entry
895 Elim_Hash_Table.Set (Data);
898 No_Elimination := False;
899 end Process_Eliminate_Pragma;