diff options
Diffstat (limited to 'gcc-4.9/gcc/ada/sem_elim.adb')
| -rw-r--r-- | gcc-4.9/gcc/ada/sem_elim.adb | 1019 |
1 files changed, 1019 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/sem_elim.adb b/gcc-4.9/gcc/ada/sem_elim.adb new file mode 100644 index 000000000..c8a07a97f --- /dev/null +++ b/gcc-4.9/gcc/ada/sem_elim.adb @@ -0,0 +1,1019 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ E L I M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2013, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Errout; use Errout; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Opt; use Opt; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Prag; use Sem_Prag; +with Sem_Util; use Sem_Util; +with Sinput; use Sinput; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Table; + +with GNAT.HTable; use GNAT.HTable; + +package body Sem_Elim is + + No_Elimination : Boolean; + -- Set True if no Eliminate pragmas active + + --------------------- + -- Data Structures -- + --------------------- + + -- A single pragma Eliminate is represented by the following record + + type Elim_Data; + type Access_Elim_Data is access Elim_Data; + + type Names is array (Nat range <>) of Name_Id; + -- Type used to represent set of names. Used for names in Unit_Name + -- and also the set of names in Argument_Types. + + type Access_Names is access Names; + + type Elim_Data is record + + Unit_Name : Access_Names; + -- Unit name, broken down into a set of names (e.g. A.B.C is + -- represented as Name_Id values for A, B, C in sequence). + + Entity_Name : Name_Id; + -- Entity name if Entity parameter if present. If no Entity parameter + -- was supplied, then Entity_Node is set to Empty, and the Entity_Name + -- field contains the last identifier name in the Unit_Name. + + Entity_Scope : Access_Names; + -- Static scope of the entity within the compilation unit represented by + -- Unit_Name. + + Entity_Node : Node_Id; + -- Save node of entity argument, for posting error messages. Set + -- to Empty if there is no entity argument. + + Parameter_Types : Access_Names; + -- Set to set of names given for parameter types. If no parameter + -- types argument is present, this argument is set to null. + + Result_Type : Name_Id; + -- Result type name if Result_Types parameter present, No_Name if not + + Source_Location : Name_Id; + -- String describing the source location of subprogram defining name if + -- Source_Location parameter present, No_Name if not + + Hash_Link : Access_Elim_Data; + -- Link for hash table use + + Homonym : Access_Elim_Data; + -- Pointer to next entry with same key + + Prag : Node_Id; + -- Node_Id for Eliminate pragma + + end record; + + ---------------- + -- Hash_Table -- + ---------------- + + -- Setup hash table using the Entity_Name field as the hash key + + subtype Element is Elim_Data; + subtype Elmt_Ptr is Access_Elim_Data; + + subtype Key is Name_Id; + + type Header_Num is range 0 .. 1023; + + Null_Ptr : constant Elmt_Ptr := null; + + ---------------------- + -- Hash_Subprograms -- + ---------------------- + + package Hash_Subprograms is + + function Equal (F1, F2 : Key) return Boolean; + pragma Inline (Equal); + + function Get_Key (E : Elmt_Ptr) return Key; + pragma Inline (Get_Key); + + function Hash (F : Key) return Header_Num; + pragma Inline (Hash); + + function Next (E : Elmt_Ptr) return Elmt_Ptr; + pragma Inline (Next); + + procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); + pragma Inline (Set_Next); + + end Hash_Subprograms; + + package body Hash_Subprograms is + + ----------- + -- Equal -- + ----------- + + function Equal (F1, F2 : Key) return Boolean is + begin + return F1 = F2; + end Equal; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key (E : Elmt_Ptr) return Key is + begin + return E.Entity_Name; + end Get_Key; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Key) return Header_Num is + begin + return Header_Num (Int (F) mod 1024); + end Hash; + + ---------- + -- Next -- + ---------- + + function Next (E : Elmt_Ptr) return Elmt_Ptr is + begin + return E.Hash_Link; + end Next; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is + begin + E.Hash_Link := Next; + end Set_Next; + end Hash_Subprograms; + + ------------ + -- Tables -- + ------------ + + -- The following table records the data for each pragmas, using the + -- entity name as the hash key for retrieval. Entries in this table + -- are set by Process_Eliminate_Pragma and read by Check_Eliminated. + + package Elim_Hash_Table is new Static_HTable ( + Header_Num => Header_Num, + Element => Element, + Elmt_Ptr => Elmt_Ptr, + Null_Ptr => Null_Ptr, + Set_Next => Hash_Subprograms.Set_Next, + Next => Hash_Subprograms.Next, + Key => Key, + Get_Key => Hash_Subprograms.Get_Key, + Hash => Hash_Subprograms.Hash, + Equal => Hash_Subprograms.Equal); + + -- The following table records entities for subprograms that are + -- eliminated, and corresponding eliminate pragmas that caused the + -- elimination. Entries in this table are set by Check_Eliminated + -- and read by Eliminate_Error_Msg. + + type Elim_Entity_Entry is record + Prag : Node_Id; + Subp : Entity_Id; + end record; + + package Elim_Entities is new Table.Table ( + Table_Component_Type => Elim_Entity_Entry, + Table_Index_Type => Name_Id'Base, + Table_Low_Bound => First_Name_Id, + Table_Initial => 50, + Table_Increment => 200, + Table_Name => "Elim_Entries"); + + ---------------------- + -- Check_Eliminated -- + ---------------------- + + procedure Check_Eliminated (E : Entity_Id) is + Elmt : Access_Elim_Data; + Scop : Entity_Id; + Form : Entity_Id; + Up : Nat; + + begin + if No_Elimination then + return; + + -- Elimination of objects and types is not implemented yet + + elsif Ekind (E) not in Subprogram_Kind then + return; + end if; + + -- Loop through homonyms for this key + + Elmt := Elim_Hash_Table.Get (Chars (E)); + while Elmt /= null loop + Check_Homonyms : declare + procedure Set_Eliminated; + -- Set current subprogram entity as eliminated + + -------------------- + -- Set_Eliminated -- + -------------------- + + procedure Set_Eliminated is + Overridden : Entity_Id; + + begin + if Is_Dispatching_Operation (E) then + + -- If an overriding dispatching primitive is eliminated then + -- its parent must have been eliminated. If the parent is an + -- inherited operation, check the operation that it renames, + -- because flag Eliminated is only set on source operations. + + Overridden := Overridden_Operation (E); + + if Present (Overridden) + and then not Comes_From_Source (Overridden) + and then Present (Alias (Overridden)) + then + Overridden := Alias (Overridden); + end if; + + if Present (Overridden) + and then not Is_Eliminated (Overridden) + and then not Is_Abstract_Subprogram (Overridden) + then + Error_Msg_Name_1 := Chars (E); + Error_Msg_N ("cannot eliminate subprogram %", E); + return; + end if; + end if; + + Set_Is_Eliminated (E); + Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E)); + end Set_Eliminated; + + -- Start of processing for Check_Homonyms + + begin + -- First we check that the name of the entity matches + + if Elmt.Entity_Name /= Chars (E) then + goto Continue; + end if; + + -- Find enclosing unit, and verify that its name and those of its + -- parents match. + + Scop := Cunit_Entity (Current_Sem_Unit); + + -- Now see if compilation unit matches + + Up := Elmt.Unit_Name'Last; + + -- If we are within a subunit, the name in the pragma has been + -- parsed as a child unit, but the current compilation unit is in + -- fact the parent in which the subunit is embedded. We must skip + -- the first name which is that of the subunit to match the pragma + -- specification. Body may be that of a package or subprogram. + + declare + Par : Node_Id; + + begin + Par := Parent (E); + while Present (Par) loop + if Nkind (Par) = N_Subunit then + if Chars (Defining_Entity (Proper_Body (Par))) = + Elmt.Unit_Name (Up) + then + Up := Up - 1; + exit; + + else + goto Continue; + end if; + end if; + + Par := Parent (Par); + end loop; + end; + + for J in reverse Elmt.Unit_Name'First .. Up loop + if Elmt.Unit_Name (J) /= Chars (Scop) then + goto Continue; + end if; + + Scop := Scope (Scop); + + if Scop /= Standard_Standard and then J = 1 then + goto Continue; + end if; + end loop; + + if Scop /= Standard_Standard then + goto Continue; + end if; + + if Present (Elmt.Entity_Node) + and then Elmt.Entity_Scope /= null + then + -- Check that names of enclosing scopes match. Skip blocks and + -- wrapper package of subprogram instances, which do not appear + -- in the pragma. + + Scop := Scope (E); + + for J in reverse Elmt.Entity_Scope'Range loop + while Ekind (Scop) = E_Block + or else + (Ekind (Scop) = E_Package + and then Is_Wrapper_Package (Scop)) + loop + Scop := Scope (Scop); + end loop; + + if Elmt.Entity_Scope (J) /= Chars (Scop) then + if Ekind (Scop) /= E_Protected_Type + or else Comes_From_Source (Scop) + then + goto Continue; + + -- For simple protected declarations, retrieve the source + -- name of the object, which appeared in the Eliminate + -- pragma. + + else + declare + Decl : constant Node_Id := + Original_Node (Parent (Scop)); + + begin + if Elmt.Entity_Scope (J) /= + Chars (Defining_Identifier (Decl)) + then + if J > 0 then + null; + end if; + goto Continue; + end if; + end; + end if; + + end if; + + Scop := Scope (Scop); + end loop; + end if; + + -- If given entity is a library level subprogram and pragma had a + -- single parameter, a match. + + if Is_Compilation_Unit (E) + and then Is_Subprogram (E) + and then No (Elmt.Entity_Node) + then + Set_Eliminated; + return; + + -- Check for case of type or object with two parameter case + + elsif (Is_Type (E) or else Is_Object (E)) + and then Elmt.Result_Type = No_Name + and then Elmt.Parameter_Types = null + then + Set_Eliminated; + return; + + -- Check for case of subprogram + + elsif Ekind_In (E, E_Function, E_Procedure) then + + -- If Source_Location present, then see if it matches + + if Elmt.Source_Location /= No_Name then + Get_Name_String (Elmt.Source_Location); + + declare + Sloc_Trace : constant String := + Name_Buffer (1 .. Name_Len); + + Idx : Natural := Sloc_Trace'First; + -- Index in Sloc_Trace, if equals to 0, then we have + -- completely traversed Sloc_Trace + + Last : constant Natural := Sloc_Trace'Last; + + P : Source_Ptr; + Sindex : Source_File_Index; + + function File_Name_Match return Boolean; + -- This function is supposed to be called when Idx points + -- to the beginning of the new file name, and Name_Buffer + -- is set to contain the name of the proper source file + -- from the chain corresponding to the Sloc of E. First + -- it checks that these two files have the same name. If + -- this check is successful, moves Idx to point to the + -- beginning of the column number. + + function Line_Num_Match return Boolean; + -- This function is supposed to be called when Idx points + -- to the beginning of the column number, and P is + -- set to point to the proper Sloc the chain + -- corresponding to the Sloc of E. First it checks that + -- the line number Idx points on and the line number + -- corresponding to P are the same. If this check is + -- successful, moves Idx to point to the beginning of + -- the next file name in Sloc_Trace. If there is no file + -- name any more, Idx is set to 0. + + function Different_Trace_Lengths return Boolean; + -- From Idx and P, defines if there are in both traces + -- more element(s) in the instantiation chains. Returns + -- False if one trace contains more element(s), but + -- another does not. If both traces contains more + -- elements (that is, the function returns False), moves + -- P ahead in the chain corresponding to E, recomputes + -- Sindex and sets the name of the corresponding file in + -- Name_Buffer + + function Skip_Spaces return Natural; + -- If Sloc_Trace (Idx) is not space character, returns + -- Idx. Otherwise returns the index of the nearest + -- non-space character in Sloc_Trace to the right of Idx. + -- Returns 0 if there is no such character. + + ----------------------------- + -- Different_Trace_Lengths -- + ----------------------------- + + function Different_Trace_Lengths return Boolean is + begin + P := Instantiation (Sindex); + + if (P = No_Location and then Idx /= 0) + or else + (P /= No_Location and then Idx = 0) + then + return True; + + else + if P /= No_Location then + Sindex := Get_Source_File_Index (P); + Get_Name_String (File_Name (Sindex)); + end if; + + return False; + end if; + end Different_Trace_Lengths; + + --------------------- + -- File_Name_Match -- + --------------------- + + function File_Name_Match return Boolean is + Tmp_Idx : Natural; + End_Idx : Natural; + + begin + if Idx = 0 then + return False; + end if; + + -- Find first colon. If no colon, then return False. + -- If there is a colon, Tmp_Idx is set to point just + -- before the colon. + + Tmp_Idx := Idx - 1; + loop + if Tmp_Idx >= Last then + return False; + elsif Sloc_Trace (Tmp_Idx + 1) = ':' then + exit; + else + Tmp_Idx := Tmp_Idx + 1; + end if; + end loop; + + -- Find last non-space before this colon. If there is + -- no space character before this colon, then return + -- False. Otherwise, End_Idx is set to point to this + -- non-space character. + + End_Idx := Tmp_Idx; + loop + if End_Idx < Idx then + return False; + + elsif Sloc_Trace (End_Idx) /= ' ' then + exit; + + else + End_Idx := End_Idx - 1; + end if; + end loop; + + -- Now see if file name matches what is in Name_Buffer + -- and if so, step Idx past it and return True. If the + -- name does not match, return False. + + if Sloc_Trace (Idx .. End_Idx) = + Name_Buffer (1 .. Name_Len) + then + Idx := Tmp_Idx + 2; + Idx := Skip_Spaces; + return True; + else + return False; + end if; + end File_Name_Match; + + -------------------- + -- Line_Num_Match -- + -------------------- + + function Line_Num_Match return Boolean is + N : Int := 0; + + begin + if Idx = 0 then + return False; + end if; + + while Idx <= Last + and then Sloc_Trace (Idx) in '0' .. '9' + loop + N := N * 10 + + (Character'Pos (Sloc_Trace (Idx)) - + Character'Pos ('0')); + Idx := Idx + 1; + end loop; + + if Get_Physical_Line_Number (P) = + Physical_Line_Number (N) + then + while Idx <= Last and then + Sloc_Trace (Idx) /= '[' + loop + Idx := Idx + 1; + end loop; + + if Idx <= Last and then + Sloc_Trace (Idx) = '[' + then + Idx := Idx + 1; + Idx := Skip_Spaces; + else + Idx := 0; + end if; + + return True; + + else + return False; + end if; + end Line_Num_Match; + + ----------------- + -- Skip_Spaces -- + ----------------- + + function Skip_Spaces return Natural is + Res : Natural; + + begin + Res := Idx; + while Sloc_Trace (Res) = ' ' loop + Res := Res + 1; + + if Res > Last then + Res := 0; + exit; + end if; + end loop; + + return Res; + end Skip_Spaces; + + begin + P := Sloc (E); + Sindex := Get_Source_File_Index (P); + Get_Name_String (File_Name (Sindex)); + + Idx := Skip_Spaces; + while Idx > 0 loop + if not File_Name_Match then + goto Continue; + elsif not Line_Num_Match then + goto Continue; + end if; + + if Different_Trace_Lengths then + goto Continue; + end if; + end loop; + end; + end if; + + -- If we have a Result_Type, then we must have a function with + -- the proper result type. + + if Elmt.Result_Type /= No_Name then + if Ekind (E) /= E_Function + or else Chars (Etype (E)) /= Elmt.Result_Type + then + goto Continue; + end if; + end if; + + -- If we have Parameter_Types, they must match + + if Elmt.Parameter_Types /= null then + Form := First_Formal (E); + + if No (Form) + and then Elmt.Parameter_Types'Length = 1 + and then Elmt.Parameter_Types (1) = No_Name + then + -- Parameterless procedure matches + + null; + + elsif Elmt.Parameter_Types = null then + goto Continue; + + else + for J in Elmt.Parameter_Types'Range loop + if No (Form) + or else + Chars (Etype (Form)) /= Elmt.Parameter_Types (J) + then + goto Continue; + else + Next_Formal (Form); + end if; + end loop; + + if Present (Form) then + goto Continue; + end if; + end if; + end if; + + -- If we fall through, this is match + + Set_Eliminated; + return; + end if; + end Check_Homonyms; + + <<Continue>> + Elmt := Elmt.Homonym; + end loop; + + return; + end Check_Eliminated; + + ------------------------------------- + -- Check_For_Eliminated_Subprogram -- + ------------------------------------- + + procedure Check_For_Eliminated_Subprogram (N : Node_Id; S : Entity_Id) is + Ultimate_Subp : constant Entity_Id := Ultimate_Alias (S); + Enclosing_Subp : Entity_Id; + + begin + -- No check needed within a default expression for a formal, since this + -- is not really a use, and the expression (a call or attribute) may + -- never be used if the enclosing subprogram is itself eliminated. + + if In_Spec_Expression then + return; + end if; + + if Is_Eliminated (Ultimate_Subp) + and then not Inside_A_Generic + and then not Is_Generic_Unit (Cunit_Entity (Current_Sem_Unit)) + then + Enclosing_Subp := Current_Subprogram; + while Present (Enclosing_Subp) loop + if Is_Eliminated (Enclosing_Subp) then + return; + end if; + + Enclosing_Subp := Enclosing_Subprogram (Enclosing_Subp); + end loop; + + -- Emit error, unless we are within an instance body and the expander + -- is disabled, indicating an instance within an enclosing generic. + -- In an instance, the ultimate alias is an internal entity, so place + -- the message on the original subprogram. + + if In_Instance_Body and then not Expander_Active then + null; + + elsif Comes_From_Source (Ultimate_Subp) then + Eliminate_Error_Msg (N, Ultimate_Subp); + + else + Eliminate_Error_Msg (N, S); + end if; + end if; + end Check_For_Eliminated_Subprogram; + + ------------------------- + -- Eliminate_Error_Msg -- + ------------------------- + + procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id) is + begin + for J in Elim_Entities.First .. Elim_Entities.Last loop + if E = Elim_Entities.Table (J).Subp then + Error_Msg_Sloc := Sloc (Elim_Entities.Table (J).Prag); + Error_Msg_NE ("cannot reference subprogram & eliminated #", N, E); + return; + end if; + end loop; + + -- If this is an internal operation generated for a protected operation, + -- its name does not match the source name, so just report the error. + + if not Comes_From_Source (E) + and then Present (First_Entity (E)) + and then Is_Concurrent_Record_Type (Etype (First_Entity (E))) + then + Error_Msg_NE + ("cannot reference eliminated protected subprogram", N, E); + + -- Otherwise should not fall through, entry should be in table + + else + Error_Msg_NE + ("subprogram& is called but its alias is eliminated", N, E); + -- raise Program_Error; + end if; + end Eliminate_Error_Msg; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Elim_Hash_Table.Reset; + Elim_Entities.Init; + No_Elimination := True; + end Initialize; + + ------------------------------ + -- Process_Eliminate_Pragma -- + ------------------------------ + + procedure Process_Eliminate_Pragma + (Pragma_Node : Node_Id; + Arg_Unit_Name : Node_Id; + Arg_Entity : Node_Id; + Arg_Parameter_Types : Node_Id; + Arg_Result_Type : Node_Id; + Arg_Source_Location : Node_Id) + is + Data : constant Access_Elim_Data := new Elim_Data; + -- Build result data here + + Elmt : Access_Elim_Data; + + Num_Names : Nat := 0; + -- Number of names in unit name + + Lit : Node_Id; + Arg_Ent : Entity_Id; + Arg_Uname : Node_Id; + + function OK_Selected_Component (N : Node_Id) return Boolean; + -- Test if N is a selected component with all identifiers, or a selected + -- component whose selector is an operator symbol. As a side effect + -- if result is True, sets Num_Names to the number of names present + -- (identifiers, and operator if any). + + --------------------------- + -- OK_Selected_Component -- + --------------------------- + + function OK_Selected_Component (N : Node_Id) return Boolean is + begin + if Nkind (N) = N_Identifier + or else Nkind (N) = N_Operator_Symbol + then + Num_Names := Num_Names + 1; + return True; + + elsif Nkind (N) = N_Selected_Component then + return OK_Selected_Component (Prefix (N)) + and then OK_Selected_Component (Selector_Name (N)); + + else + return False; + end if; + end OK_Selected_Component; + + -- Start of processing for Process_Eliminate_Pragma + + begin + Data.Prag := Pragma_Node; + Error_Msg_Name_1 := Name_Eliminate; + + -- Process Unit_Name argument + + if Nkind (Arg_Unit_Name) = N_Identifier then + Data.Unit_Name := new Names'(1 => Chars (Arg_Unit_Name)); + Num_Names := 1; + + elsif OK_Selected_Component (Arg_Unit_Name) then + Data.Unit_Name := new Names (1 .. Num_Names); + + Arg_Uname := Arg_Unit_Name; + for J in reverse 2 .. Num_Names loop + Data.Unit_Name (J) := Chars (Selector_Name (Arg_Uname)); + Arg_Uname := Prefix (Arg_Uname); + end loop; + + Data.Unit_Name (1) := Chars (Arg_Uname); + + else + Error_Msg_N + ("wrong form for Unit_Name parameter of pragma%", Arg_Unit_Name); + return; + end if; + + -- Process Entity argument + + if Present (Arg_Entity) then + Num_Names := 0; + + if Nkind (Arg_Entity) = N_Identifier + or else Nkind (Arg_Entity) = N_Operator_Symbol + then + Data.Entity_Name := Chars (Arg_Entity); + Data.Entity_Node := Arg_Entity; + Data.Entity_Scope := null; + + elsif OK_Selected_Component (Arg_Entity) then + Data.Entity_Scope := new Names (1 .. Num_Names - 1); + Data.Entity_Name := Chars (Selector_Name (Arg_Entity)); + Data.Entity_Node := Arg_Entity; + + Arg_Ent := Prefix (Arg_Entity); + for J in reverse 2 .. Num_Names - 1 loop + Data.Entity_Scope (J) := Chars (Selector_Name (Arg_Ent)); + Arg_Ent := Prefix (Arg_Ent); + end loop; + + Data.Entity_Scope (1) := Chars (Arg_Ent); + + elsif Is_Config_Static_String (Arg_Entity) then + Data.Entity_Name := Name_Find; + Data.Entity_Node := Arg_Entity; + + else + return; + end if; + else + Data.Entity_Node := Empty; + Data.Entity_Name := Data.Unit_Name (Num_Names); + end if; + + -- Process Parameter_Types argument + + if Present (Arg_Parameter_Types) then + + -- Here for aggregate case + + if Nkind (Arg_Parameter_Types) = N_Aggregate then + Data.Parameter_Types := + new Names + (1 .. List_Length (Expressions (Arg_Parameter_Types))); + + Lit := First (Expressions (Arg_Parameter_Types)); + for J in Data.Parameter_Types'Range loop + if Is_Config_Static_String (Lit) then + Data.Parameter_Types (J) := Name_Find; + Next (Lit); + else + return; + end if; + end loop; + + -- Otherwise we must have case of one name, which looks like a + -- parenthesized literal rather than an aggregate. + + elsif Paren_Count (Arg_Parameter_Types) /= 1 then + Error_Msg_N + ("wrong form for argument of pragma Eliminate", + Arg_Parameter_Types); + return; + + elsif Is_Config_Static_String (Arg_Parameter_Types) then + String_To_Name_Buffer (Strval (Arg_Parameter_Types)); + + if Name_Len = 0 then + + -- Parameterless procedure + + Data.Parameter_Types := new Names'(1 => No_Name); + + else + Data.Parameter_Types := new Names'(1 => Name_Find); + end if; + + else + return; + end if; + end if; + + -- Process Result_Types argument + + if Present (Arg_Result_Type) then + if Is_Config_Static_String (Arg_Result_Type) then + Data.Result_Type := Name_Find; + else + return; + end if; + + -- Here if no Result_Types argument + + else + Data.Result_Type := No_Name; + end if; + + -- Process Source_Location argument + + if Present (Arg_Source_Location) then + if Is_Config_Static_String (Arg_Source_Location) then + Data.Source_Location := Name_Find; + else + return; + end if; + else + Data.Source_Location := No_Name; + end if; + + Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data)); + + -- If we already have an entry with this same key, then link + -- it into the chain of entries for this key. + + if Elmt /= null then + Data.Homonym := Elmt.Homonym; + Elmt.Homonym := Data; + + -- Otherwise create a new entry + + else + Elim_Hash_Table.Set (Data); + end if; + + No_Elimination := False; + end Process_Eliminate_Pragma; + +end Sem_Elim; |