1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2021, 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;
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;
44 with GNAT.HTable; use GNAT.HTable;
46 package body Sem_Elim is
48 No_Elimination : Boolean;
49 -- Set True if no Eliminate pragmas active
55 -- A single pragma Eliminate is represented by the following record
58 type Access_Elim_Data is access Elim_Data;
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.
64 type Access_Names is access Names;
66 type Elim_Data is record
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).
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.
77 Entity_Scope : Access_Names;
78 -- Static scope of the entity within the compilation unit represented by
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.
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.
89 Result_Type : Name_Id;
90 -- Result type name if Result_Types parameter present, No_Name if not
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
96 Hash_Link : Access_Elim_Data;
97 -- Link for hash table use
99 Homonym : Access_Elim_Data;
100 -- Pointer to next entry with same key
103 -- Node_Id for Eliminate pragma
111 -- Setup hash table using the Entity_Name field as the hash key
113 subtype Element is Elim_Data;
114 subtype Elmt_Ptr is Access_Elim_Data;
116 subtype Key is Name_Id;
118 type Header_Num is range 0 .. 1023;
120 Null_Ptr : constant Elmt_Ptr := null;
122 ----------------------
123 -- Hash_Subprograms --
124 ----------------------
126 package Hash_Subprograms is
128 function Equal (F1, F2 : Key) return Boolean;
129 pragma Inline (Equal);
131 function Get_Key (E : Elmt_Ptr) return Key;
132 pragma Inline (Get_Key);
134 function Hash (F : Key) return Header_Num;
135 pragma Inline (Hash);
137 function Next (E : Elmt_Ptr) return Elmt_Ptr;
138 pragma Inline (Next);
140 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
141 pragma Inline (Set_Next);
143 end Hash_Subprograms;
145 package body Hash_Subprograms is
151 function Equal (F1, F2 : Key) return Boolean is
160 function Get_Key (E : Elmt_Ptr) return Key is
162 return E.Entity_Name;
169 function Hash (F : Key) return Header_Num is
171 return Header_Num (Int (F) mod 1024);
178 function Next (E : Elmt_Ptr) return Elmt_Ptr is
187 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
191 end Hash_Subprograms;
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.
201 package Elim_Hash_Table is new Static_HTable (
202 Header_Num => Header_Num,
204 Elmt_Ptr => Elmt_Ptr,
205 Null_Ptr => Null_Ptr,
206 Set_Next => Hash_Subprograms.Set_Next,
207 Next => Hash_Subprograms.Next,
209 Get_Key => Hash_Subprograms.Get_Key,
210 Hash => Hash_Subprograms.Hash,
211 Equal => Hash_Subprograms.Equal);
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.
218 type Elim_Entity_Entry is record
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,
228 Table_Increment => 200,
229 Table_Name => "Elim_Entries");
231 ----------------------
232 -- Check_Eliminated --
233 ----------------------
235 procedure Check_Eliminated (E : Entity_Id) is
236 Elmt : Access_Elim_Data;
242 if No_Elimination then
245 -- Elimination of objects and types is not implemented yet
247 elsif Ekind (E) not in Subprogram_Kind then
251 -- Loop through homonyms for this key
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
263 procedure Set_Eliminated is
264 Overridden : Entity_Id;
267 if Is_Dispatching_Operation (E) then
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.
274 Overridden := Overridden_Operation (E);
276 if Present (Overridden)
277 and then not Comes_From_Source (Overridden)
278 and then Present (Alias (Overridden))
280 Overridden := Alias (Overridden);
283 if Present (Overridden)
284 and then not Is_Eliminated (Overridden)
285 and then not Is_Abstract_Subprogram (Overridden)
287 Error_Msg_Name_1 := Chars (E);
288 Error_Msg_N ("cannot eliminate subprogram %", E);
293 Set_Is_Eliminated (E);
294 Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E));
297 -- Start of processing for Check_Homonyms
300 -- First we check that the name of the entity matches
302 if Elmt.Entity_Name /= Chars (E) then
306 -- Find enclosing unit, and verify that its name and those of its
309 Scop := Cunit_Entity (Current_Sem_Unit);
311 -- Now see if compilation unit matches
313 Up := Elmt.Unit_Name'Last;
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.
326 while Present (Par) loop
327 if Nkind (Par) = N_Subunit then
328 if Chars (Defining_Entity (Proper_Body (Par))) =
343 for J in reverse Elmt.Unit_Name'First .. Up loop
344 if Elmt.Unit_Name (J) /= Chars (Scop) then
348 Scop := Scope (Scop);
350 if Scop /= Standard_Standard and then J = 1 then
355 if Scop /= Standard_Standard then
359 if Present (Elmt.Entity_Node)
360 and then Elmt.Entity_Scope /= null
362 -- Check that names of enclosing scopes match. Skip blocks and
363 -- wrapper package of subprogram instances, which do not appear
368 for J in reverse Elmt.Entity_Scope'Range loop
369 while Ekind (Scop) = E_Block
371 (Ekind (Scop) = E_Package
372 and then Is_Wrapper_Package (Scop))
374 Scop := Scope (Scop);
377 if Elmt.Entity_Scope (J) /= Chars (Scop) then
378 if Ekind (Scop) /= E_Protected_Type
379 or else Comes_From_Source (Scop)
383 -- For simple protected declarations, retrieve the source
384 -- name of the object, which appeared in the Eliminate
389 Decl : constant Node_Id :=
390 Original_Node (Parent (Scop));
393 if Elmt.Entity_Scope (J) /=
394 Chars (Defining_Identifier (Decl))
406 Scop := Scope (Scop);
410 -- If given entity is a library level subprogram and pragma had a
411 -- single parameter, a match.
413 if Is_Compilation_Unit (E)
414 and then Is_Subprogram (E)
415 and then No (Elmt.Entity_Node)
420 -- Check for case of type or object with two parameter case
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
429 -- Check for case of subprogram
431 elsif Ekind (E) in E_Function | E_Procedure then
433 -- If Source_Location present, then see if it matches
435 if Elmt.Source_Location /= No_Name then
436 Get_Name_String (Elmt.Source_Location);
439 Sloc_Trace : constant String :=
440 Name_Buffer (1 .. Name_Len);
442 Idx : Natural := Sloc_Trace'First;
443 -- Index in Sloc_Trace, if equals to 0, then we have
444 -- completely traversed Sloc_Trace
446 Last : constant Natural := Sloc_Trace'Last;
449 Sindex : Source_File_Index;
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.
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.
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
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.
487 -----------------------------
488 -- Different_Trace_Lengths --
489 -----------------------------
491 function Different_Trace_Lengths return Boolean is
493 P := Instantiation (Sindex);
495 if (P = No_Location and then Idx /= 0)
497 (P /= No_Location and then Idx = 0)
502 if P /= No_Location then
503 Sindex := Get_Source_File_Index (P);
504 Get_Name_String (File_Name (Sindex));
509 end Different_Trace_Lengths;
511 ---------------------
512 -- File_Name_Match --
513 ---------------------
515 function File_Name_Match return Boolean is
524 -- Find first colon. If no colon, then return False.
525 -- If there is a colon, Tmp_Idx is set to point just
530 if Tmp_Idx >= Last then
532 elsif Sloc_Trace (Tmp_Idx + 1) = ':' then
535 Tmp_Idx := Tmp_Idx + 1;
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.
546 if End_Idx < Idx then
549 elsif Sloc_Trace (End_Idx) /= ' ' then
553 End_Idx := End_Idx - 1;
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.
561 if Sloc_Trace (Idx .. End_Idx) =
562 Name_Buffer (1 .. Name_Len)
576 function Line_Num_Match return Boolean is
585 and then Sloc_Trace (Idx) in '0' .. '9'
588 (Character'Pos (Sloc_Trace (Idx)) -
589 Character'Pos ('0'));
593 if Get_Physical_Line_Number (P) =
594 Physical_Line_Number (N)
596 while Idx <= Last and then
597 Sloc_Trace (Idx) /= '['
603 pragma Assert (Sloc_Trace (Idx) = '[');
621 function Skip_Spaces return Natural is
626 while Sloc_Trace (Res) = ' ' loop
640 Sindex := Get_Source_File_Index (P);
641 Get_Name_String (File_Name (Sindex));
645 if not File_Name_Match then
647 elsif not Line_Num_Match then
651 if Different_Trace_Lengths then
658 -- If we have a Result_Type, then we must have a function with
659 -- the proper result type.
661 if Elmt.Result_Type /= No_Name then
662 if Ekind (E) /= E_Function
663 or else Chars (Etype (E)) /= Elmt.Result_Type
669 -- If we have Parameter_Types, they must match
671 if Elmt.Parameter_Types /= null then
672 Form := First_Formal (E);
675 and then Elmt.Parameter_Types'Length = 1
676 and then Elmt.Parameter_Types (1) = No_Name
678 -- Parameterless procedure matches
682 elsif Elmt.Parameter_Types = null then
686 for J in Elmt.Parameter_Types'Range loop
689 Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
697 if Present (Form) then
703 -- If we fall through, this is match
711 Elmt := Elmt.Homonym;
715 end Check_Eliminated;
717 -------------------------------------
718 -- Check_For_Eliminated_Subprogram --
719 -------------------------------------
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;
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.
730 if In_Spec_Expression then
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))
738 Enclosing_Subp := Current_Subprogram;
739 while Present (Enclosing_Subp) loop
740 if Is_Eliminated (Enclosing_Subp) then
744 Enclosing_Subp := Enclosing_Subprogram (Enclosing_Subp);
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.
752 if In_Instance_Body and then not Expander_Active then
755 elsif Comes_From_Source (Ultimate_Subp) then
756 Eliminate_Error_Msg (N, Ultimate_Subp);
759 Eliminate_Error_Msg (N, S);
762 end Check_For_Eliminated_Subprogram;
764 -------------------------
765 -- Eliminate_Error_Msg --
766 -------------------------
768 procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id) is
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);
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.
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)))
786 ("cannot reference eliminated protected subprogram&", N, E);
788 -- Otherwise should not fall through, entry should be in table
792 ("subprogram& is called but its alias is eliminated", N, E);
793 -- raise Program_Error;
795 end Eliminate_Error_Msg;
801 procedure Initialize is
803 Elim_Hash_Table.Reset;
805 No_Elimination := True;
808 ------------------------------
809 -- Process_Eliminate_Pragma --
810 ------------------------------
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)
820 Data : constant Access_Elim_Data := new Elim_Data;
821 -- Build result data here
823 Elmt : Access_Elim_Data;
825 Num_Names : Nat := 0;
826 -- Number of names in unit name
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).
838 ---------------------------
839 -- OK_Selected_Component --
840 ---------------------------
842 function OK_Selected_Component (N : Node_Id) return Boolean is
844 if Nkind (N) = N_Identifier
845 or else Nkind (N) = N_Operator_Symbol
847 Num_Names := Num_Names + 1;
850 elsif Nkind (N) = N_Selected_Component then
851 return OK_Selected_Component (Prefix (N))
852 and then OK_Selected_Component (Selector_Name (N));
857 end OK_Selected_Component;
859 -- Start of processing for Process_Eliminate_Pragma
862 Data.Prag := Pragma_Node;
863 Error_Msg_Name_1 := Name_Eliminate;
865 -- Process Unit_Name argument
867 if Nkind (Arg_Unit_Name) = N_Identifier then
868 Data.Unit_Name := new Names'(1 => Chars (Arg_Unit_Name));
871 elsif OK_Selected_Component (Arg_Unit_Name) then
872 Data.Unit_Name := new Names (1 .. Num_Names);
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);
880 Data.Unit_Name (1) := Chars (Arg_Uname);
884 ("wrong form for Unit_Name parameter of pragma%", Arg_Unit_Name);
888 -- Process Entity argument
890 if Present (Arg_Entity) then
893 if Nkind (Arg_Entity) = N_Identifier
894 or else Nkind (Arg_Entity) = N_Operator_Symbol
896 Data.Entity_Name := Chars (Arg_Entity);
897 Data.Entity_Node := Arg_Entity;
898 Data.Entity_Scope := null;
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;
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);
911 Data.Entity_Scope (1) := Chars (Arg_Ent);
913 elsif Is_Config_Static_String (Arg_Entity) then
914 Data.Entity_Name := Name_Find;
915 Data.Entity_Node := Arg_Entity;
921 Data.Entity_Node := Empty;
922 Data.Entity_Name := Data.Unit_Name (Num_Names);
925 -- Process Parameter_Types argument
927 if Present (Arg_Parameter_Types) then
929 -- Here for aggregate case
931 if Nkind (Arg_Parameter_Types) = N_Aggregate then
932 Data.Parameter_Types :=
934 (1 .. List_Length (Expressions (Arg_Parameter_Types)));
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;
946 -- Otherwise we must have case of one name, which looks like a
947 -- parenthesized literal rather than an aggregate.
949 elsif Paren_Count (Arg_Parameter_Types) /= 1 then
951 ("wrong form for argument of pragma Eliminate",
952 Arg_Parameter_Types);
955 elsif Is_Config_Static_String (Arg_Parameter_Types) then
956 String_To_Name_Buffer (Strval (Arg_Parameter_Types));
960 -- Parameterless procedure
962 Data.Parameter_Types := new Names'(1 => No_Name);
965 Data.Parameter_Types := new Names'(1 => Name_Find);
973 -- Process Result_Types argument
975 if Present (Arg_Result_Type) then
976 if Is_Config_Static_String (Arg_Result_Type) then
977 Data.Result_Type := Name_Find;
982 -- Here if no Result_Types argument
985 Data.Result_Type := No_Name;
988 -- Process Source_Location argument
990 if Present (Arg_Source_Location) then
991 if Is_Config_Static_String (Arg_Source_Location) then
992 Data.Source_Location := Name_Find;
997 Data.Source_Location := No_Name;
1000 Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data));
1002 -- If we already have an entry with this same key, then link
1003 -- it into the chain of entries for this key.
1005 if Elmt /= null then
1006 Data.Homonym := Elmt.Homonym;
1007 Elmt.Homonym := Data;
1009 -- Otherwise create a new entry
1012 Elim_Hash_Table.Set (Data);
1015 No_Elimination := False;
1016 end Process_Eliminate_Pragma;