------------------------------------------------------------------------------ -- -- -- Libadalang Tools -- -- -- -- Copyright (C) 2021, AdaCore -- -- -- -- Libadalang Tools is free software; you can redistribute it and/or modi- -- -- fy it under terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 3, or (at your option) any -- -- later version. This software is distributed in the hope that it will be -- -- useful but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are -- -- granted additional permissions described in the GCC Runtime Library -- -- Exception, version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and a -- -- copy of the GCC Runtime Library Exception along with this program; see -- -- the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- ------------------------------------------------------------------------------ -- -- This package contains LAL_Tools common utilities to be used by other -- packages with Ada.Containers.Doubly_Linked_Lists; with Ada.Containers.Indefinite_Ordered_Maps; with Ada.Containers.Hashed_Sets; with Ada.Containers.Ordered_Maps; with Ada.Containers.Ordered_Sets; with Ada.Containers.Vectors; with Ada.Containers.Indefinite_Vectors; with GNATCOLL.Traces; with Libadalang.Analysis; use Libadalang.Analysis; with Libadalang.Common; use Libadalang.Common; with Langkit_Support.Slocs; use Langkit_Support.Slocs; with Langkit_Support.Text; use Langkit_Support.Text; package Laltools.Common is function "<" (Left, Right : Defining_Name) return Boolean is (Left.Text < Right.Text or else (Left.Text = Right.Text and then Left.Full_Sloc_Image < Right.Full_Sloc_Image)); -- The Ordered_Maps is using the "<" in its Equivalent_Keys function: -- this is too basic and it will assume that Left.Text = Right.Text implies -- Left = Right which is wrong. -- If Left.Text = Right.Text then Full_Sloc_Image will sort first by -- file and then by Sloc (first by line and then by column). function "<" (Left, Right : Source_Location_Range) return Boolean; -- Checks if L is < than R, first based on the line number and then on -- the column number function "<" (Left, Right : Base_Id) return Boolean is (Left.Text < Right.Text or else Left.Sloc_Range < Right.Sloc_Range); -- Use the Sloc to compare two Base_Id nodes when their text is equal. function Node_Equal (Left, Right : Libadalang.Analysis.Ada_Node) return Boolean is (Libadalang.Analysis.Full_Sloc_Image (Left) = Libadalang.Analysis.Full_Sloc_Image (Right)); -- Libadalang.Analysis."=" is not enough to fully detect duplicates type Analysis_Unit_Array_Access is access Analysis_Unit_Array; package Ada_List_Vectors is new Ada.Containers.Indefinite_Vectors (Index_Type => Natural, Element_Type => Ada_List'Class, "=" => "="); subtype Ada_List_Vector is Ada_List_Vectors.Vector; procedure Append_If_Not_Null (Vector : in out Ada_List_Vector; List : Ada_List'Class); -- Checks if Ada_List.Is_Null and if not, appends it to Vector package Base_Id_Vectors is new Ada.Containers.Vectors (Index_Type => Natural, Element_Type => Base_Id, "=" => "="); package Basic_Decl_Vectors is new Ada.Containers.Vectors (Index_Type => Natural, Element_Type => Basic_Decl, "=" => "="); subtype Basic_Decl_Vector is Basic_Decl_Vectors.Vector; package Bodies_List is new Ada.Containers.Doubly_Linked_Lists (Element_Type => Defining_Name, "=" => "="); package Declarative_Part_Vectors is new Ada.Containers.Indefinite_Vectors (Index_Type => Natural, Element_Type => Declarative_Part'Class, "=" => "="); subtype Declarative_Part_Vector is Declarative_Part_Vectors.Vector; package Node_Vectors is new Ada.Containers.Vectors (Index_Type => Natural, Element_Type => Ada_Node, "=" => "="); package Node_Sets is new Ada.Containers.Hashed_Sets (Element_Type => Ada_Node, Hash => Hash, Equivalent_Elements => Node_Equal, "=" => Node_Equal); package References_Sets is new Ada.Containers.Ordered_Sets (Element_Type => Base_Id, "<" => "<", "=" => "="); package References_By_Subprogram is new Ada.Containers.Ordered_Maps (Key_Type => Defining_Name, Element_Type => References_Sets.Set, "<" => "<", "=" => References_Sets."="); package Source_Location_Range_Sets is new Ada.Containers.Ordered_Sets (Element_Type => Source_Location_Range, "<" => "<", "=" => "="); subtype Source_Location_Range_Set is Source_Location_Range_Sets.Set; package Source_Location_Range_Maps is new Ada.Containers.Indefinite_Ordered_Maps (Key_Type => String, Element_Type => Source_Location_Range_Sets.Set, "<" => "<", "=" => Source_Location_Range_Sets."="); subtype Source_Location_Range_Map is Source_Location_Range_Maps.Map; function Compilation_Unit_Hash (Comp_Unit : Compilation_Unit) return Ada.Containers.Hash_Type; -- Casts Comp_Unit as Ada_Node and uses Hash from Libadalang.Analysis. -- This is convenient for containers with Compilation_Unit elements. function Contains (Token : Token_Reference; Pattern : Wide_Wide_String; As_Word : Boolean; Span : out Source_Location_Range) return Boolean; -- Return True if the Token text contains Pattern and set position in Span. -- Checks whether the Token's Pattern is delimited by word delimiters -- if As_Word is True. function Count_Subp_Parameters (Subp_Params : Params) return Natural with Pre => not Subp_Params.Is_Null; -- Returns the amount of parameters 'Subp_Params' has. procedure Find_All_References (Node : Defining_Name'Class; Units : Analysis_Unit_Array; Callback : not null access procedure (Reference : Ref_Result; Stop : in out Boolean)); -- TODO: Imprecise fallback makes sense here? -- Wrapper around Libadalang.Analysis.P_Find_All_References. -- Calls Callback for each reference found or until Stop is True. -- Callback is responsible for defining the stop criteria. -- Does nothing if Node is a No_Defining_Name. function Find_All_References_For_Renaming (Definition : Defining_Name; Units : Analysis_Unit_Array) return Base_Id_Vectors.Vector with Pre => not Definition.Is_Null; -- Returns a vector with all references of Definition. -- Depending if Definition is associated to a parameter spec or to a -- subprogram, the return vector will include returns of -- Find_All_Param_References_In_Subp_Hierarchy and -- Find_All_Subp_References_In_Subp_Hierarchy. function Find_All_Param_References_In_Subp_Hierarchy (Param_Definition : Defining_Name; Units : Analysis_Unit_Array) return Base_Id_Vectors.Vector with Pre => not Param_Definition.Is_Null and then Param_Definition.Parent.Parent.Kind in Ada_Param_Spec_Range; -- Retruns a vector with all references of Param_Definition. -- If Param_Definition is associated to a Param_Spec in a subprogram -- 'Foo' that is a primitive of a type, then the vector includes refereces -- to the associated parameter spec of supbprograms that 'Foo' is -- overriding or that is being overridden by. function Find_All_Subp_References_In_Subp_Hierarchy (Subp : Basic_Decl; Units : Analysis_Unit_Array) return Base_Id_Vectors.Vector with Pre => Is_Subprogram (Subp); -- Retruns a vector with all references of Subp, and if Subp is -- a primitive subrogram of a type, then the vector includes references of -- supbprograms that Definition is overriding or that is being overridden -- by. function Find_Canonical_Part (Definition : Defining_Name; Trace : GNATCOLL.Traces.Trace_Handle; Imprecise_Fallback : Boolean := False) return Defining_Name; -- Wrapper around P_Canonical_Part that returns null if canonical part -- is name itself. It also catches Property_Error and reports it in traces. procedure Find_Matching_Parents (Node : Ada_Node'Class; Match : not null access function (Node : Ada_Node'Class) return Boolean; Callback : not null access procedure (Parent : Ada_Node; Stop : in out Boolean)); -- Iterates through the parents of Node and calls Callback on the parents -- where Match returns True. This iterative process stops if Callback sets -- Stop to True. function Find_Local_Scopes (Node : Ada_Node'Class) return Ada_List_Vector with Post => (for all Scope of Find_Local_Scopes'Result => Scope.Kind in Ada_Ada_Node_List_Range | Ada_Basic_Decl_List_Range); -- Find all scopes in Node's Compilation_Unit visible by Node. It will not -- contain Node if Node is itself a scope. -- In this context, scope is the Ada_Node_List of a Declarative_Part, or a -- Basic_Decl_List of a Decl_Expr (in Ada 2022, Expr_Function can have a -- Decl_Expr node). -- Returns an empty vector if Node.Is_Null. function Find_Nested_Scopes (Node : Ada_Node'Class) return Declarative_Part_Vectors.Vector; -- Finds all scopes that have visibility if Node and that are nested -- in Node's own scope. function Find_Next_Part (Definition : Defining_Name; Trace : GNATCOLL.Traces.Trace_Handle; Imprecise_Fallback : Boolean := False) return Defining_Name; -- Wrapper around P_Next_Part that returns No_Defining_Name if next part -- is name itself. It also catches Property_Error and reports it in traces. function Find_Previous_Part (Definition : Defining_Name; Trace : GNATCOLL.Traces.Trace_Handle; Imprecise_Fallback : Boolean := False) return Defining_Name; -- Wrapper around P_Previous_Part that returns No_Defining_Name if previous -- part is name itself. It also catches Property_Error and reports it -- in traces. function Find_Other_Part_Fallback (Definition : Defining_Name; Trace : GNATCOLL.Traces.Trace_Handle) return Defining_Name; -- Attempt to find the other part of a definition manually, with -- simple heuristics that look at the available entities with matching --- names and profiles. -- This should be called only if straightforward Libadalang calls -- have failed. function Find_Subp_Body (Subp : Basic_Decl'Class) return Base_Subp_Body with Pre => Is_Subprogram (Subp); -- If Subp is of kind Ada_Subp_Decl or Ada_Generic_Subp_Decl then -- returns its body part, if is exists. Otherwise return No_Base_Subp_Body. function Get_Compilation_Unit (Node : Ada_Node'Class) return Compilation_Unit; -- Returns the Compilation_Unit associated to Node function Get_Insert_With_Location (Node : Compilation_Unit'Class; Pack_Name : Text_Type; Last : out Boolean) return Source_Location; -- Returns the Source_Location where to insert a with clause for Pack_Name -- or No_Source_Location if Pack_Name is already withed. -- Last indicates if the location is after the last with/use clause. function Get_CU_Visible_Declarative_Parts (Node : Ada_Node'Class; Skip_First : Boolean := False) return Declarative_Part_Vectors.Vector; -- Returns a vector with all Declarative_Parts in Node's compilation unit -- visible by Node. If Skip_First is True, then Node's first -- Declarative_Part parent is skipped. function Get_Decl_Block_Declarative_Part (Decl_B : Decl_Block) return Declarative_Part; -- Gets the Declarative_Part of a Decl_Block. function Get_Decl_Block_Decls (Decl_B : Decl_Block) return Ada_Node_List; -- Gets the Ada_Node_List of a Declarative_Part associated to a Decl_Block. function Get_Declarative_Part (Stmts : Handled_Stmts) return Declarative_Part; -- Finds the Handled_Stmts's respective Declarative_Part, if it exists. -- ??? Possibly move this function to Libadalang. function Is_Declarative_Part_Owner (Node : Ada_Node'Class) return Boolean; -- Checks if Node can have a Declarative_Part child function Is_Decl_Expr_Owner (Node : Ada_Node'Class) return Boolean with Post => (if Is_Decl_Expr_Owner'Result then Node.Kind in Ada_Expr_Function_Range); -- Checks if Node is an Expr_Function with a Decl_Expr child function Get_Declarative_Parts (Node : Ada_Node'Class) return Declarative_Part_Vector with Pre => not Node.Is_Null and then Is_Declarative_Part_Owner (Node), Post => not Declarative_Part_Vectors.Is_Empty (Get_Declarative_Parts'Result) and then (for all Decl_Part of Get_Declarative_Parts'Result => not Decl_Part.Is_Null); -- Returns a vector with the Declarative_Part, Public_Part and Private_Part -- of Owner, if they exist. function Get_Defining_Name_Id (Definition : Defining_Name) return Identifier; -- Gets the Identifier of Definition. If Definition is associated to a -- Dotted_Name them return the suffix. function Get_First_Identifier_From_Declaration (Decl : Basic_Decl'Class) return Identifier; -- Return the first identifier found in a basic declaration. function Get_Last_Name (Name_Node : Name) return Unbounded_Text_Type; -- Return the last name, for example if name is A.B.C then return C. function Get_Name_As_Defining (Name_Node : Name) return Defining_Name; -- Wrapper around P_Enclosing_Defining_Name that returns No_Defining_Name -- if Name_Node is No_Name or not a Defining_Name. function Get_Node_As_Name (Node : Ada_Node) return Name; -- Wrapper around As_Name that returns No_Name if Node is not a Name. function Get_Package_Body_Declative_Part (Pkg_Body : Package_Body) return Declarative_Part; -- Gets the Declarative_Part associated to a Package_Body. function Get_Package_Body_Decls (Pkg_Body : Package_Body) return Ada_Node_List; -- Gets the Ada_Node_List of a Declarative_Part associated to a -- Package_Body. function Get_Package_Declarative_Parts (Pkg_Decl : Base_Package_Decl'Class) return Declarative_Part_Vectors.Vector; -- Gets all the Declarative_Parts associated to a Base_Package_Decl -- (public, private and body declarative parts). function Get_Package_Declarative_Parts (Pkg_Body : Package_Body) return Declarative_Part_Vectors.Vector is (Get_Package_Declarative_Parts (Pkg_Body.P_Canonical_Part.As_Base_Package_Decl)); -- Gets all the Declarative_Parts associated to a Package_Body -- (public, private and body declarative parts). function Get_Package_Decls (Pkg_Decl : Base_Package_Decl'Class) return Ada_List_Vector; -- Gets all the Ada_Node_Lists of the Declarative_Parts associated to a -- Base_Package_Decl (public, private and body declarative parts). function Get_Package_Decls (Pkg_Body : Package_Body) return Ada_List_Vector is (Get_Package_Decls (Pkg_Body.P_Canonical_Part.As_Base_Package_Decl)); -- Gets all the Ada_Node_Lists of the Declarative_Parts associated to a --- Package_Body (public, private and body declarative parts). function Get_Package_Decl_Private_Declarative_Part (Pkg_Decl : Base_Package_Decl'Class) return Declarative_Part; -- Gets the private Declarative_Part associated to a Package_Body function Get_Package_Decl_Private_Decls (Pkg_Decl : Base_Package_Decl'Class) return Ada_Node_List; -- Gets the Ada_Node_List of the private Declarative_Part associated to a -- Package_Body, if it exists. function Get_Package_Decl_Public_Declarative_Part (Pkg_Decl : Base_Package_Decl'Class) return Declarative_Part; -- Gets the public Declarative_Part associated to a Base_Package_Decl function Get_Package_Decl_Public_Decls (Pkg_Decl : Base_Package_Decl'Class) return Ada_Node_List; -- Gets the Ada_Node_List of the the public Declarative_Part associated to -- a Package_Decl. function Get_Param_Spec_Index (Target : Param_Spec) return Positive with Pre => not Target.Is_Null; -- Returns the index of 'Target' regardind its parent Param_Spec_List function Get_Parameter_Absolute_Index (Target : Defining_Name) return Natural with Pre => Target.Parent.Parent.Kind = Ada_Param_Spec; -- Returns the index of 'Target' regarding all parameters os its parent -- subprogram. function Get_Parameter_Name (Parameters : Params'Class; Parameter_Index : Positive) return Text_Type; -- TODO function Get_Parameter_Name (Subp : Basic_Decl'Class; Parameter_Index : Positive) return Text_Type with Pre => Is_Subprogram (Subp); -- Returns the name of the parameters associated to 'Parameter_Index'. -- Is 'Parameter_Index' is > than the amount of parameters 'Subp' has, then -- return an empty Text_Type. function Get_Subp_Body_Declarative_Part (Subp_B : Subp_Body) return Declarative_Part; -- Gets the Declarative_Part associated to a Subp_Body. function Get_Subp_Body_Decls (Subp_B : Subp_Body) return Ada_Node_List; -- Gets the Ada_Node_List of a Declarative_Part associated to a Subp_Body function Get_Subp_Params (Subp : Basic_Decl'Class) return Params with Inline, Pre => Is_Subprogram (Subp) or else (not Subp.Is_Null and then Subp.Kind in Ada_Generic_Subp_Instantiation); -- Gets the Params node associated to Subp, if it exists. -- If it doesn't exist returns No_Params. function Get_Subp_Spec (Subp : Basic_Decl'Class) return Base_Subp_Spec with Inline, Pre => Is_Subprogram (Subp) or else (not Subp.Is_Null and then Subp.Kind in Ada_Generic_Subp_Instantiation); -- Gets the Subp_Spec node associated to Subp function Get_Subp_Spec_Params (Subp_Spec : Base_Subp_Spec'Class) return Params; -- Gets the Params node associated to Subp_Spec, if it exists. -- If it doesn't exist returns No_Params. function Get_Task_Body_Declarative_Part (Task_B : Task_Body) return Declarative_Part; -- Gets the Declarative_Part associated to a Task_Body. function Get_Task_Body_Decls (Task_B : Task_Body) return Ada_Node_List; -- Gets the Ada_Node_List of a Declarative_Part associated to a Task_Body. function Get_Use_Units_Public_Parts (Node : Ada_Node'Class) return Declarative_Part_Vectors.Vector; -- Gets all public Declarative_Parts of the units used by Node's unit function Get_Used_Units (Node : Compilation_Unit'Class) return Compilation_Unit_Array; -- Returns a Compilation_Unit_Array with all the Compilation_Unit -- whose Node has a use clause for. If Node is null, then returns an empty -- Compilation_Unit_Array. The return array does not contain null -- Compilation_Units. procedure Insert (Map : in out Source_Location_Range_Map; Key : String; Element : Source_Location_Range); -- Safely inserts a new 'Key : Element' in 'Map'. If Element = -- No_Source_Location_Range then it is NOT inserted. function Is_Access_Ref (Node : Ada_Node) return Boolean; -- Return True if the node or the dotted name is an access reference. function Is_Call (Node : Ada_Node'Class; Trace : GNATCOLL.Traces.Trace_Handle; Imprecise : in out Boolean) return Boolean; -- Check if a node is a call and an identifier. Enum literals -- in DottedName are excluded. function Is_Constant (Node : Basic_Decl) return Boolean; -- Return True if the decl contains the constant keyword. function Is_Definition_Without_Separate_Implementation (Definition : Defining_Name) return Boolean; -- Return True if the definition given is a subprogram that does not call -- for a body, ie a "is null" procedure, an expression function, or an -- abstract subprogram. function Is_End_Label (Node : Ada_Node) return Boolean is (not Node.Parent.Is_Null and then (Node.Parent.Kind in Ada_End_Name or else (Node.Parent.Kind in Ada_Dotted_Name and then not Node.Parent.Parent.Is_Null and then Node.Parent.Parent.Kind in Ada_End_Name))); -- Return True if the node belongs to an end label node. -- Used to filter out end label references. function Is_Enum_Literal (Node : Ada_Node'Class; Trace : GNATCOLL.Traces.Trace_Handle; Imprecise : in out Boolean) return Boolean; -- Check if a node is an enum literal. function Is_Renamable (Node : Ada_Node'Class) return Boolean; -- A node is renamable only if a precise definition is found. function Is_Structure (Node : Basic_Decl) return Boolean; -- Return True if the type contains a record part. function Is_Subprogram (Decl : Basic_Decl'Class) return Boolean is (not Decl.Is_Null and then (Decl.P_Is_Subprogram or else Decl.Kind in Ada_Generic_Subp_Decl_Range) and then not (Decl.Kind in Ada_Enum_Literal_Decl_Range)); -- Checks if Decl is a subprogram excluding enum literals function Is_Type_Derivation (Node : Ada_Node) return Boolean is (not Node.Parent.Is_Null and then (Node.Parent.Kind in Ada_Subtype_Indication_Range and then not Node.Parent.Parent.Is_Null and then Node.Parent.Parent.Kind in Ada_Derived_Type_Def_Range)); -- Return True if the node belongs to derived type declaration. function Length (List : Assoc_List) return Natural; -- Returns how many Basic_Assoc nodes L has. function Length (List : Compilation_Unit_List) return Natural; -- Returns how many Compilation_Unit nodes List has. function Length (List : Defining_Name_List) return Natural; -- Returns how many Defining_Name nodes L has. function Length (List : Param_Spec_List) return Natural; -- Returns how many Param_Spec nodes L has. function List_Bodies_Of (Definition : Defining_Name; Trace : GNATCOLL.Traces.Trace_Handle; Imprecise : in out Boolean) return Bodies_List.List; -- List all the bodies of Definition. This does not list the bodies of the -- parent. It sets Imprecise to True if any request returns -- imprecise results. procedure Merge (Left : in out Source_Location_Range_Map; Right : Source_Location_Range_Map); -- Safely merges 'Right' into 'Left'. function Resolve_Name (Name_Node : Name; Trace : GNATCOLL.Traces.Trace_Handle; Imprecise : out Boolean) return Defining_Name; -- Return the definition node (canonical part) of the given name. -- Imprecise is set to True if LAL has marked the result as imprecise or -- if an error happened. function Resolve_Name_Precisely (Name_Node : Name) return Defining_Name; -- Return the definition node (canonical part) of the given name. end Laltools.Common;