| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S E M _ E L I M -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1997-2022, 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 Einfo.Entities; use Einfo.Entities; |
| with Einfo.Utils; use Einfo.Utils; |
| 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 Sinfo.Nodes; use Sinfo.Nodes; |
| 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 pragma, 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 not Is_Subprogram (E) 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 (E) in 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 : Nat := 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 then |
| pragma Assert (Sloc_Trace (Idx) = '['); |
| 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; |
