-- -- Copyright (C) 2022-2023, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -- with Ada.Assertions; use Ada.Assertions; with Ada.Characters.Latin_1; with Ada.Containers.Hashed_Sets; with Ada.Containers.Indefinite_Hashed_Sets; with Ada.Strings; with Ada.Strings.Fixed; with Ada.Strings.Hash_Case_Insensitive; with Ada.Strings.Wide_Wide_Fixed; with Langkit_Support.Text; package body LAL_Refactor.Extract_Subprogram is Tool_Name : constant String := "Extract Subprogram"; function Get_Parameter_Mode_From_Reference (Reference : Base_Id'Class) return Ada_Mode; -- Assuming that Reference will be passed as a subprogram argument, -- computes its mode by checking if Reference is being read or written. function Get_Statements_To_Extract (Start_Stmt : Stmt; End_Stmt : Stmt) return Stmt_Vector; -- Returns a vector with all Stmt nodes between Start_Stmt and End_Stmt, -- inclusive. The vector is ordered from Start_Stmt to End_Stmt. If -- Start_Stmt = End_Stmt, then the returned vector only contains -- Start_Stmt. function Is_Declaration_Owner (Node : Ada_Node'Class) return Boolean is (Is_Declarative_Part_Owner (Node) or else Node.Kind in Ada_Accept_Stmt_With_Stmts_Range | Ada_For_Loop_Stmt_Range | Ada_Exception_Handler_Range | Ada_Extended_Return_Stmt_Range) with Pre => not Node.Is_Null; type Direction is (Forward, Backward); function Lookup (Unit : Analysis_Unit; Token : Token_Reference; Going : Direction) return Ada_Node; -- Finds the next Ada_Node relative to Token. Going controls the lookup -- direction. If Token already belongs to an Ada_Node, that node is -- returned. Returns No_Ada_Node if no node is found or if -- Token = No_Token. function Next_Non_Whitespace (Token : Token_Reference; Going : Direction) return Token_Reference; -- Finds the next non white Token_Reference relative to Token. Going -- controls the lookup direction. Returns No_Token if no whitespace -- if found or if Token = No_Token. function To_String (Mode : Ada_Mode; Default_As_In : Boolean := False) return String; function To_String_Vector (Set : Defining_Name_Ordered_Set) return String_Vector; -- Converts a Defining_Name_Ordered_Set into a String_Vector procedure Update_Parameter_Mode (Parameter_Mode : in out Ada_Mode; New_Mode : Ada_Mode); -- This is a specific OR operation between modes. -- If New_Mode has an In component, then it is added to Old_Mode. -- Same for the Out component. procedure Update_Parameter_Mode (Parameters_Mode : in out Parameters_Mode_Map; Parameter : Defining_Name'Class; Mode : Ada_Mode); -- Updates Parameter key in Parameters_Mode with Mode. If Parameter is not -- in Parameters_Mode, it is added with value Mode. ------------------------------- -- Get_Statements_To_Extract -- ------------------------------- function Get_Statements_To_Extract (Start_Stmt : Stmt; End_Stmt : Stmt) return Stmt_Vector is Stmts : Stmt_Vector; Aux_Node : Ada_Node; begin Stmts.Append (Start_Stmt); Aux_Node := Start_Stmt.As_Ada_Node; loop exit when Aux_Node.As_Stmt = End_Stmt; Aux_Node := Aux_Node.Next_Sibling; exit when Aux_Node.Is_Null; Stmts.Append (Aux_Node.As_Stmt); end loop; return Stmts; end Get_Statements_To_Extract; --------------------------------------- -- Get_Parameter_Mode_From_Reference -- --------------------------------------- function Get_Parameter_Mode_From_Reference (Reference : Base_Id'Class) return Ada_Mode is Mode : Ada_Mode := Ada_Mode_Default; begin if Reference.Parent.Kind in Ada_Assign_Stmt_Range then if Reference = Reference.Parent.As_Assign_Stmt.F_Expr then Mode := Ada_Mode_Default; else Assert (Reference = Reference.Parent.As_Assign_Stmt.F_Dest); Mode := Ada_Mode_Out; end if; elsif Reference.Parent.Parent.Kind in Ada_Assign_Stmt_Range then if Reference.Parent = Reference.Parent.Parent.As_Assign_Stmt.F_Dest and then Reference.Parent = Reference.Parent.Parent.As_Assign_Stmt.F_Expr then Mode := Ada_Mode_In_Out; elsif Reference.Parent = Reference.Parent.Parent.As_Assign_Stmt.F_Dest then Mode := Ada_Mode_Out; else Assert (Reference.Parent = Reference.Parent.Parent.As_Assign_Stmt.F_Expr); Mode := Ada_Mode_Default; end if; elsif Reference.Parent.Kind in Ada_Param_Assoc then for Parameter of Reference.Parent.As_Param_Assoc.P_Get_Params loop Mode := Ada_Mode (Parameter.P_Basic_Decl.As_Param_Spec.F_Mode.Kind); -- This is a list of parameters in a Param_Spec. They all have the -- same mode, so only one needs to be checked. exit; end loop; elsif Reference.Parent.Parent.Kind in Ada_Param_Assoc then for Parameter of Reference.Parent.Parent.As_Param_Assoc.P_Get_Params loop Mode := Ada_Mode (Parameter.P_Basic_Decl.As_Param_Spec.F_Mode.Kind); -- This is a list of parameters in a Param_Spec. They all have the -- same mode, so only one needs to be checked. exit; end loop; end if; if Mode = Ada_Mode_In then Mode := Ada_Mode_Default; end if; return Mode; end Get_Parameter_Mode_From_Reference; ------------ -- Lookup -- ------------ function Lookup (Unit : Analysis_Unit; Token : Token_Reference; Going : Direction) return Ada_Node is Aux_Token : Token_Reference := Token; Aux_Token_Kind : Libadalang.Common.Token_Kind := Kind (Data (Aux_Token)); begin -- Do nothing if Aux_Token <=> Token is a No_Token or already belongs to -- an Ada_Node. while not (Aux_Token = No_Token) and then Aux_Token_Kind in Ada_Comment | Ada_Whitespace loop case Going is when Forward => Aux_Token := Next (Aux_Token); when Backward => Aux_Token := Previous (Aux_Token); end case; Aux_Token_Kind := Kind (Data (Aux_Token)); end loop; -- No Ada_Node was found relative to Token if Aux_Token = No_Token then return No_Ada_Node; end if; return Unit.Root.Lookup (Start_Sloc (Sloc_Range (Data (Aux_Token)))); end Lookup; ------------------------- -- Next_Non_Whitespace -- ------------------------- function Next_Non_Whitespace (Token : Token_Reference; Going : Direction) return Token_Reference is Result : Token_Reference := Token; begin -- Do nothing if Result <=> Token is a No_Token while Result /= No_Token loop case Going is when Forward => Result := Next (Result); when Backward => Result := Previous (Result); end case; exit when Kind (Data (Result)) /= Ada_Whitespace; end loop; if Result /= No_Token and then Kind (Data (Result)) /= Ada_Whitespace then -- No whitespace relative to Token return Result; else return No_Token; end if; end Next_Non_Whitespace; ---------------------- -- To_String_Vector -- ---------------------- function To_String_Vector (Set : Defining_Name_Ordered_Set) return String_Vector is Vector : String_Vector; use Langkit_Support.Text; begin for Element of Set loop Vector.Append (To_UTF8 (Element.Text)); end loop; return Vector; end To_String_Vector; --------------------------- -- Update_Parameter_Mode -- --------------------------- procedure Update_Parameter_Mode (Parameters_Mode : in out Parameters_Mode_Map; Parameter : Defining_Name'Class; Mode : Ada_Mode) is begin if Parameters_Mode.Contains (Parameter) then Parameters_Mode.Replace (Parameter, Mode); else Parameters_Mode.Insert (Parameter, Mode); end if; end Update_Parameter_Mode; --------------------------- -- Update_Parameter_Mode -- --------------------------- procedure Update_Parameter_Mode (Parameter_Mode : in out Ada_Mode; New_Mode : Ada_Mode) is begin if New_Mode = Ada_Mode_In_Out then Parameter_Mode := New_Mode; elsif Parameter_Mode in Ada_Mode_Default | Ada_Mode_In and then New_Mode = Ada_Mode_Out then Parameter_Mode := Ada_Mode_In_Out; elsif Parameter_Mode = Ada_Mode_Out and then New_Mode in Ada_Mode_Default | Ada_Mode_In then Parameter_Mode := Ada_Mode_In_Out; end if; end Update_Parameter_Mode; --------------- -- To_String -- --------------- function To_String (Mode : Ada_Mode; Default_As_In : Boolean := False) return String is (case Mode is when Ada_Mode_Default_Range => (if Default_As_In then "in " else ""), when Ada_Mode_In_Range => "in ", when Ada_Mode_Out_Range => "out ", when Ada_Mode_In_Out_Range => "in out "); ------------- -- Extract -- ------------- function Extract (Self : Extract_Subprogram_Strategy'Class) return Refactoring_Edits is Target_Statements : constant Stmt_Vector := Get_Statements_To_Extract (Self.Start_Stmt, Self.End_Stmt); Parameter_Candidates : constant Defining_Name_Ordered_Set := Self.Get_Local_Declarations; Parameters_To_Extract : constant Defining_Name_Ordered_Set := Self.Get_Parameters_To_Extract (Parameter_Candidates, Target_Statements); Parameters_Mode : constant Parameters_Mode_Map := Self.Get_Parameters_Mode (Parameters_To_Extract, Target_Statements); Parameters_Type : constant Parameters_Type_Map := Self.Get_Parameters_Type (Parameters_To_Extract); Extracted_Subprogram_Name : constant String := To_String (Self.Name); Extracted_Subprogram_Parameters : constant String_Vector := Self.Build_Extracted_Subprogram_Parameters (Parameters_To_Extract, Parameters_Mode, Parameters_Type); Extracted_Subprogram_Statements : constant String_Vector := Self.Build_Extracted_Subprogram_Statements; Enclosing_Declarative_Part : constant Declarative_Part := Get_Enclosing_Declarative_Part (Self.Start_Stmt); Extracted_Subprogram : constant String := Self.Build_Extracted_Subprogram (Extracted_Subprogram_Parameters, Extracted_Subprogram_Statements, Natural (Enclosing_Declarative_Part.Sloc_Range.End_Column) - 1); Extracted_Subprogram_Arguments : constant String_Vector := To_String_Vector (Parameters_To_Extract); Extracted_Subprogram_Call : constant String := Self.Build_Extracted_Subprogram_Call (Extracted_Subprogram_Name, Extracted_Subprogram_Arguments); Insertion_Point : constant Source_Location_Range := (Enclosing_Declarative_Part.Sloc_Range.End_Line, Enclosing_Declarative_Part.Sloc_Range.End_Line, 1, 1); Start_Line : constant Line_Number := Line_Number'Min (Sloc_Range (Data (Self.Start_Token)).Start_Line, Self.Start_Stmt.Sloc_Range.Start_Line); End_Line : constant Line_Number := Line_Number'Max (Sloc_Range (Data (Self.End_Token)).End_Line, Self.End_Stmt.Sloc_Range.End_Line); Start_Column : constant Column_Number := Column_Number'Min (Sloc_Range (Data (Self.Start_Token)).Start_Column, Self.Start_Stmt.Sloc_Range.Start_Column); End_Column : constant Column_Number := Column_Number'Max (Sloc_Range (Data (Self.End_Token)).End_Column, Self.End_Stmt.Sloc_Range.End_Column); Text_Edits : Text_Edit_Ordered_Set; Edits : Refactoring_Edits; begin Text_Edits.Insert ((Insertion_Point, To_Unbounded_String (Extracted_Subprogram))); Text_Edits.Insert (((Start_Line, End_Line, Start_Column, End_Column), To_Unbounded_String (Extracted_Subprogram_Call))); Edits.Text_Edits.Insert (Self.Unit.Get_Filename, Text_Edits); return Edits; end Extract; ---------------------------- -- Get_Local_Declarations -- ---------------------------- function Get_Local_Declarations (Self : Extract_Subprogram_Strategy) return Defining_Name_Ordered_Set is Candidates : Defining_Name_Ordered_Set; procedure Declaration_Owner_Callback (Parent : Ada_Node; Stop : in out Boolean); -- If Parent.Kind is in: -- Ada_Accept_Stmt_With_Stmts_Range -- Ada_For_Loop_Stmt_Range -- Ada_Exception_Handler_Range -- Ada_Extended_Return_Stmt_Range -- Then checks if there's a local object declaration. If so, adds it to -- candidates. -- Iteration stops when Is_Declarative_Part_Owner (Parent). -------------------------------- -- Declaration_Owner_Callback -- -------------------------------- procedure Declaration_Owner_Callback (Parent : Ada_Node; Stop : in out Boolean) is begin if Is_Declarative_Part_Owner (Parent) then Stop := True; else case Parent.Kind is when Ada_Accept_Stmt_With_Stmts_Range => for Param_Spec of Parent.As_Accept_Stmt_With_Stmts.F_Params. F_Params.F_Params loop for Parameter_Defining_Name of Param_Spec.F_Ids loop Candidates.Insert (Parameter_Defining_Name.As_Defining_Name); end loop; end loop; when Ada_For_Loop_Stmt_Range => Candidates.Insert (Parent.As_For_Loop_Stmt.F_Spec.As_For_Loop_Spec. F_Var_Decl.F_Id); when Ada_Exception_Handler_Range => Candidates.Insert (Parent.As_Exception_Handler.F_Exception_Name); when Ada_Extended_Return_Stmt_Range => Candidates.Insert (Defining_Name_List_Element (Parent.As_Extended_Return_Stmt.F_Decl.F_Ids, Defining_Name_List_First (Parent.As_Extended_Return_Stmt.F_Decl.F_Ids)). As_Defining_Name); when others => raise Assertion_Error; end case; end if; end Declaration_Owner_Callback; begin -- Find all objects declarated in: -- Ada_Accept_Stmt_With_Stmts_Range -- Ada_For_Loop_Stmt_Range -- Ada_Exception_Handler_Range -- Ada_Extended_Return_Stmt_Range Find_Matching_Parents (Self.Start_Stmt, Is_Declaration_Owner'Access, Declaration_Owner_Callback'Access); return Candidates; end Get_Local_Declarations; ------------------------- -- Get_Parameters_Type -- ------------------------- function Get_Parameters_Type (Self : Extract_Subprogram_Strategy; Parameters : Defining_Name_Ordered_Set) return Parameters_Type_Map is pragma Unreferenced (Self); Parameters_Base_Type_Decl : Parameters_Type_Map; Parameter_Base_Type_Decl : Basic_Decl; begin for Parameter of Parameters loop case Parameter.P_Basic_Decl.Kind is when Ada_For_Loop_Var_Decl_Range => Parameter_Base_Type_Decl := Parameter.P_Basic_Decl.As_For_Loop_Var_Decl.P_Defining_Name. P_Expression_Type.As_Basic_Decl; when Ada_Exception_Handler => Parameter_Base_Type_Decl := No_Exception_Handler.As_Basic_Decl; when Ada_Param_Spec => Parameter_Base_Type_Decl := Parameter.P_Basic_Decl.Parent.As_Param_Spec. F_Type_Expr.P_Designated_Type_Decl.As_Basic_Decl; when Ada_Extended_Return_Stmt_Object_Decl => Parameter_Base_Type_Decl := Parameter.P_Basic_Decl. As_Extended_Return_Stmt_Object_Decl. P_Type_Expression.P_Designated_Type_Decl.As_Basic_Decl; when others => raise Assertion_Error with "Unexpected parameter type"; end case; if not Parameter_Base_Type_Decl.Is_Null and then Parameter_Base_Type_Decl = Parameter_Base_Type_Decl.P_Universal_Int_Type then Parameters_Base_Type_Decl.Insert (Parameter, Parameter_Base_Type_Decl.P_Int_Type.As_Basic_Decl); else Parameters_Base_Type_Decl.Insert (Parameter, Parameter_Base_Type_Decl); end if; end loop; return Parameters_Base_Type_Decl; end Get_Parameters_Type; ------------------------------------------- -- Build_Extracted_Subprogram_Parameters -- ------------------------------------------- function Build_Extracted_Subprogram_Parameters (Self : Extract_Subprogram_Strategy; Parameters : Defining_Name_Ordered_Set; Parameters_Mode : Parameters_Mode_Map; Parameters_Type : Parameters_Type_Map) return String_Vector is pragma Unreferenced (Self); use Langkit_Support.Text; function Build_Param_Spec (Name : String; Mode : Ada_Node_Kind_Type; Subtype_Indication : Basic_Decl'Class) return String; -- Build the Ada code of a Param_Spec: -- "Name : Mode Subtype_Indication" ---------------------- -- Build_Param_Spec -- ---------------------- function Build_Param_Spec (Name : String; Mode : Ada_Node_Kind_Type; Subtype_Indication : Basic_Decl'Class) return String is Parameter_Mode : constant String := To_String (Mode); Parameter_Type : constant String := (if Subtype_Indication.Is_Null then "Ada.Exceptions.Exception_Occurrence" else To_UTF8 (Subtype_Indication.P_Defining_Name.Text)); begin return Name & " : " & Parameter_Mode & Parameter_Type; end Build_Param_Spec; begin return Extracted_Subprogram_Parameters : String_Vector do for Parameter of Parameters loop Extracted_Subprogram_Parameters.Append (Build_Param_Spec (To_UTF8 (Parameter.Text), Parameters_Mode.Element (Parameter), Parameters_Type.Element (Parameter))); end loop; end return; end Build_Extracted_Subprogram_Parameters; ------------------------------- -- Get_Parameters_To_Extract -- ------------------------------- function Get_Parameters_To_Extract (Self : Procedure_Extractor; Candidates : Defining_Name_Ordered_Set; Statements : Stmt_Vector) return Defining_Name_Ordered_Set is begin return Parameters : Defining_Name_Ordered_Set do -- Check if they have references in Statemets. If they do, then it -- is needed as a parameter for Candidate of Candidates loop Find_Candidate_In_Statements : for Stmt of Statements loop if Candidate.P_Find_Refs (Stmt)'Length > 0 then Parameters.Insert (Candidate); exit Find_Candidate_In_Statements; end if; end loop Find_Candidate_In_Statements; end loop; end return; end Get_Parameters_To_Extract; ------------------------- -- Get_Parameters_Mode -- ------------------------- overriding function Get_Parameters_Mode (Self : Procedure_Extractor; Parameters : Defining_Name_Ordered_Set; Statements : Stmt_Vector) return Parameters_Mode_Map is Parameters_Mode : Parameters_Mode_Map; begin for Parameter of Parameters loop declare Mode : Ada_Mode; First_Reference : Boolean := True; begin Compute_Mode : for Stmt of Statements loop for Reference of Parameter.P_Find_Refs (Root => Stmt) loop if First_Reference then Mode := Get_Parameter_Mode_From_Reference (Ref (Reference)); First_Reference := False; else Update_Parameter_Mode (Mode, Get_Parameter_Mode_From_Reference (Ref (Reference))); end if; end loop; -- Early exit when we the parameter mode must include out exit Compute_Mode when not First_Reference and then Mode in Ada_Mode_Out | Ada_Mode_In_Out; end loop Compute_Mode; Assert (not First_Reference); Update_Parameter_Mode (Parameters_Mode, Parameter, Mode); end; end loop; return Parameters_Mode; end Get_Parameters_Mode; ------------------------------------------- -- Build_Extracted_Subprogram_Statements -- ------------------------------------------- function Build_Extracted_Subprogram_Statements (Self : Procedure_Extractor) return String_Vector is Start_Line : constant Line_Number := Line_Number'Min (Sloc_Range (Data (Self.Start_Token)).Start_Line, Self.Start_Stmt.Sloc_Range.Start_Line); End_Line : constant Line_Number := Line_Number'Max (Sloc_Range (Data (Self.End_Token)).End_Line, Self.End_Stmt.Sloc_Range.End_Line); Start_Column : constant Column_Number := Column_Number'Min (Sloc_Range (Data (Self.Start_Token)).Start_Column, Self.Start_Stmt.Sloc_Range.Start_Column); End_Column : constant Column_Number := Column_Number'Max (Sloc_Range (Data (Self.End_Token)).End_Column, Self.End_Stmt.Sloc_Range.End_Column) - 1; Real_Start_Token : constant Token_Reference := Self.Unit.Lookup_Token ((Start_Line, Start_Column)); Real_End_Token : constant Token_Reference := Self.Unit.Lookup_Token ((End_Line, End_Column)); Lines_Number : constant Positive := 1 + Positive (End_Line) - Positive (Start_Line); Start_Index_To_Extract : array (Start_Line .. End_Line) of Natural := [others => 0]; End_Index_To_Extract : array (Start_Line .. End_Line) of Natural := [others => 0]; Minimum_Indentation : Natural := Natural'Last; Extracted_Subprogram_Statements : String_Vector; use Langkit_Support.Text; begin if Lines_Number = 1 then Minimum_Indentation := 0; Start_Index_To_Extract (Start_Line) := Text (Real_Start_Token)'First; End_Index_To_Extract (Start_Line) := Text (Real_End_Token)'Last; else -- Find the Minimum_Indentation, i.e., the indentation -- of the least indented statement or comment. declare use Ada.Strings.Wide_Wide_Fixed; Start_Line_First_Non_Blank : constant Positive := Index_Non_Blank (Self.Unit.Get_Line (Positive (Start_Line))); Include_Start_Line : constant Boolean := Start_Line_First_Non_Blank = Text (Real_Start_Token)'First; Indentation : Natural; begin for Line_Number in (if Include_Start_Line then Start_Line else Start_Line + 1) .. Self.End_Stmt.Sloc_Range.Start_Line loop declare Line : constant Text_Type := Self.Unit.Get_Line (Positive (Line_Number)); begin if Line /= "" then Indentation := Index_Non_Blank (Line) - Line'First; if Indentation < Minimum_Indentation then Minimum_Indentation := Indentation; end if; end if; end; end loop; if Include_Start_Line then Start_Index_To_Extract (Start_Line) := Self.Unit.Get_Line (Integer (Start_Line))'First + Minimum_Indentation; End_Index_To_Extract (Start_Line) := Self.Unit.Get_Line (Integer (Start_Line))'Last; else Start_Index_To_Extract (Start_Line) := Text (Real_Start_Token)'First; End_Index_To_Extract (Start_Line) := Self.Unit.Get_Line (Integer (Start_Line))'Last; end if; end; for Line_Number in Start_Line + 1 .. End_Line - 1 loop Start_Index_To_Extract (Line_Number) := Self.Unit.Get_Line (Integer (Line_Number))'First + Minimum_Indentation; End_Index_To_Extract (Line_Number) := Self.Unit.Get_Line (Integer (Line_Number))'Last; end loop; Start_Index_To_Extract (End_Line) := Self.Unit.Get_Line (Integer (End_Line))'First + Minimum_Indentation; End_Index_To_Extract (End_Line) := Text (Real_End_Token)'Last; end if; for Line_Number in Start_Line .. End_Line loop Extracted_Subprogram_Statements.Append (To_UTF8 (Self.Unit.Get_Line (Integer (Line_Number)) (Start_Index_To_Extract (Line_Number) .. End_Index_To_Extract (Line_Number)))); end loop; return Extracted_Subprogram_Statements; end Build_Extracted_Subprogram_Statements; -------------------------------- -- Build_Extracted_Subprogram -- -------------------------------- overriding function Build_Extracted_Subprogram (Self : Procedure_Extractor; Params : String_Vector; Statements : String_Vector; Offset : Natural; Indentation : Natural := 3) return String is use Ada.Characters.Latin_1; use Ada.Containers; function Padding (N : Integer) return Unbounded_String is ((Offset + N * Indentation) * " "); function Build_Procedure_Spec return String; -- Builds the ada code of the extracted procedure spec function Build_Procedure_Body return String; -- Builds the ada code of the extracted procedure spec -------------------------- -- Build_Procedure_Spec -- -------------------------- function Build_Procedure_Spec return String is Subp_Spec : Unbounded_String; begin if Params.Is_Empty then Append (Subp_Spec, Padding (1) & "procedure " & Self.Name & ";" & LF); else if Params.Length = 1 then Append (Subp_Spec, Padding (1) & "procedure " & Self.Name & LF & Padding (1) & " (" & Params.First_Element & ");" & LF); else Append (Subp_Spec, Padding (1) & "procedure " & Self.Name & LF & Padding (1) & " (" & Params.First_Element & ";" & LF); for J in Params.First_Index + 1 .. Params.Last_Index - 1 loop Append (Subp_Spec, Padding (2) & Params.Element (J) & ";" & LF); end loop; Append (Subp_Spec, Padding (2) & Params.Last_Element & ");" & LF); end if; end if; return To_String (Subp_Spec); end Build_Procedure_Spec; -------------------------- -- Build_Procedure_Body -- -------------------------- function Build_Procedure_Body return String is use Ada.Strings; use Ada.Strings.Fixed; Subp_Body : Unbounded_String; begin if Params.Is_Empty then Append (Subp_Body, Padding (1) & "procedure " & Self.Name & " is" & LF & Padding (1) & "begin" & LF); for Stmt of Statements loop if Stmt /= "" then Append (Subp_Body, Padding (2) & Trim (Stmt, Right) & LF); else Append (Subp_Body, Stmt & LF); end if; end loop; Append (Subp_Body, Padding (1) & "end " & Self.Name & ";" & LF); else if Params.Length = 1 then Append (Subp_Body, Padding (1) & "procedure " & Self.Name & LF & Padding (1) & " (" & Params.First_Element & ")" & " is" & LF); else Append (Subp_Body, Padding (1) & "procedure " & Self.Name & LF & Padding (1) & " (" & Params.First_Element & ";" & LF); for J in Params.First_Index + 1 .. Params.Last_Index - 1 loop Append (Subp_Body, Padding (2) & Params.Element (J) & ";" & LF); end loop; Append (Subp_Body, Padding (2) & Params.Last_Element & ")" & " is" & LF); end if; Append (Subp_Body, Padding (1) & "begin" & LF); for Stmt of Statements loop if Stmt /= "" then Append (Subp_Body, Padding (2) & Trim (Stmt, Right) & LF); else Append (Subp_Body, Stmt & LF); end if; end loop; Append (Subp_Body, Padding (1) & "end " & Self.Name & ";" & LF); end if; return To_String (Subp_Body); end Build_Procedure_Body; begin return LF & Build_Procedure_Spec & LF & Build_Procedure_Body & LF; end Build_Extracted_Subprogram; ------------------------------------- -- Build_Extracted_Subprogram_Call -- ------------------------------------- overriding function Build_Extracted_Subprogram_Call (Self : Procedure_Extractor; Name : String; Parameters : String_Vector) return String is use Ada.Containers; use String_Vectors; begin if Parameters.Is_Empty then return Name & ";"; else declare Call_Parameters : Unbounded_String; C : Cursor := Parameters.First; L : constant Cursor := Parameters.Last; begin String_Vectors.Next (C); if Parameters.Length = 1 then Append (Call_Parameters, "(" & Parameters.First_Element & ");"); return Name & " " & To_String (Call_Parameters); else Append (Call_Parameters, "(" & Parameters.First_Element & ", "); while C /= L loop Append (Call_Parameters, Element (C) & ", "); String_Vectors.Next (C); end loop; Append (Call_Parameters, Parameters.Last_Element & ")"); return Name & " " & To_String (Call_Parameters) & ";"; end if; end; end if; end Build_Extracted_Subprogram_Call; ------------------------------- -- Get_Parameters_To_Extract -- ------------------------------- function Get_Parameters_To_Extract (Self : Function_Extractor; Candidates : Defining_Name_Ordered_Set; Statements : Stmt_Vector) return Defining_Name_Ordered_Set is function All_Parameters return Defining_Name_Ordered_Set; -- Returns the Defining_Names of Candidates that have references in -- Statements. -------------------- -- All_Parameters -- -------------------- function All_Parameters return Defining_Name_Ordered_Set is begin return Parameters : Defining_Name_Ordered_Set do -- Check if they have references in Statemets. If they do, then it -- is needed as a parameter for Candidate of Candidates loop Find_Candidate_In_Statements : for Stmt of Statements loop if Candidate.P_Find_Refs (Stmt)'Length > 0 then Parameters.Insert (Candidate); exit Find_Candidate_In_Statements; end if; end loop Find_Candidate_In_Statements; end loop; end return; end All_Parameters; Parameters_To_Extract : Defining_Name_Ordered_Set := All_Parameters; Assigned_Definition : constant Defining_Name := (if Statements.Last_Element.Kind in Ada_Assign_Stmt_Range then Statements.Last_Element.As_Assign_Stmt.F_Dest. P_Referenced_Decl.P_Defining_Name else No_Defining_Name); Assigned_Definition_Is_Needed : Boolean := False; begin if Assigned_Definition.Is_Null then return Parameters_To_Extract; end if; Find_Assigned_Definition_In_Statements : for Statement of Statements loop if Statement = Statements.Last_Element then if Assigned_Definition.P_Find_Refs (Statement.As_Assign_Stmt.F_Expr)'Length > 0 then Assigned_Definition_Is_Needed := True; end if; else if Assigned_Definition.P_Find_Refs (Statement)'Length > 0 then Assigned_Definition_Is_Needed := True; end if; end if; exit Find_Assigned_Definition_In_Statements when Assigned_Definition_Is_Needed; end loop Find_Assigned_Definition_In_Statements; if not Assigned_Definition_Is_Needed then Parameters_To_Extract.Exclude (Assigned_Definition); end if; return Parameters_To_Extract; end Get_Parameters_To_Extract; ------------------------- -- Get_Parameters_Mode -- ------------------------- overriding function Get_Parameters_Mode (Self : Function_Extractor; Parameters : Defining_Name_Ordered_Set; Statements : Stmt_Vector) return Parameters_Mode_Map is Parameters_Mode : Parameters_Mode_Map; begin for Parameter of Parameters loop declare Mode : Ada_Mode; First_Reference : Boolean := True; Subtree : Ada_Node; begin Compute_Mode : for Stmt of Statements loop Subtree := (if Stmt = Statements.Last_Element and then Stmt.Kind in Ada_Assign_Stmt_Range then Stmt.As_Assign_Stmt.F_Expr.As_Ada_Node else Stmt.As_Ada_Node); for Reference of Parameter.P_Find_Refs (Root => Subtree) loop if First_Reference then Mode := Get_Parameter_Mode_From_Reference (Ref (Reference)); First_Reference := False; else Update_Parameter_Mode (Mode, Get_Parameter_Mode_From_Reference (Ref (Reference))); end if; end loop; -- Early exit when we the parameter mode must include out exit Compute_Mode when not First_Reference and then Mode in Ada_Mode_Out | Ada_Mode_In_Out; end loop Compute_Mode; Assert (not First_Reference); Update_Parameter_Mode (Parameters_Mode, Parameter, Mode); end; end loop; return Parameters_Mode; end Get_Parameters_Mode; ------------------------------------------- -- Build_Extracted_Subprogram_Statements -- ------------------------------------------- overriding function Build_Extracted_Subprogram_Statements (Self : Function_Extractor) return String_Vector is use Langkit_Support.Text; -- Section To Extract SLOC. -- _Token can be in the middle of a statement. Therefore, -- find the _ by comparing the _Token -- and _Stmt SLOC. Start_Line : constant Line_Number := Line_Number'Min (Sloc_Range (Data (Self.Start_Token)).Start_Line, Self.Start_Stmt.Sloc_Range.Start_Line); End_Line : constant Line_Number := Line_Number'Max (Sloc_Range (Data (Self.End_Token)).End_Line, Self.End_Stmt.Sloc_Range.End_Line); Start_Column : constant Column_Number := Column_Number'Min (Sloc_Range (Data (Self.Start_Token)).Start_Column, Self.Start_Stmt.Sloc_Range.Start_Column); End_Column : constant Column_Number := Column_Number'Max (Sloc_Range (Data (Self.End_Token)).End_Column, Self.End_Stmt.Sloc_Range.End_Column); -- Find the True__Token given the _ -- computed above. True_Start_Token : constant Token_Reference := Self.Unit.Lookup_Token ((Start_Line, Start_Column)); True_End_Token : constant Token_Reference := Self.Unit.Lookup_Token ((End_Line, End_Column - 1)); -- The section to extract can be a single line or multiple lines. -- If it's a single line, it can be the fully or partially extracted. -- If it's multiple lines, the same is applicable for the start and -- end line. -- Total_Lines is how many lines we'll extract. Total_Lines : constant Positive := Natural (End_Line) - Natural (Start_Line) + 1; -- Also, the lines can have a wrong indentation, so the best -- we can do is find the minimum indentation and remove the leading -- whitespaces relative to it. Minimum_Indentation : Natural := Natural'Last; -- Exception messages Unexpected_End_Stmt_Kind_Exception_Message : constant String := "Trying to extract a function, however, the last statement is neither " & "an Ada_Return_Stmt_Range nor an Ada_Assign_Stmt_Range"; -- Result of this function, with all the extracted statements, without -- padding. Extracted_Stmts : String_Vector; begin if Total_Lines = 1 then -- Only one line to extract. -- The following algorithm assumes that there can't be any comments -- before Start_Stmt on this line, since comments can only appear in -- the end of the line, or in the whole line. Assert (Start_Line = End_Line, "Only one line to extract, however, Start_Line and End_Line are " & "different"); Assert (Start_Sloc (Self.Start_Stmt.Sloc_Range) = (Start_Line, Start_Column), "Only one line to extract, but the start Source_Location of " & "Start_Stmt is /= than (Start_Line, Start_Column)"); if Self.Start_Stmt = Self.End_Stmt then -- Only one line and one statement to extract case Self.Start_Stmt.Kind is when Ada_Return_Stmt_Range => declare Target_Line : constant Text_Type := Self.Unit.Get_Line (Positive (Start_Line)); Return_Stmt : constant Text_Type := Target_Line (Text (True_Start_Token)'First .. Text (True_End_Token)'Last); begin Extracted_Stmts.Append (To_UTF8 (Return_Stmt)); end; when Ada_Assign_Stmt_Range => -- There might be comments after the Assign_Stmt node. -- Transform the Assign_Stmt into a Return_Stmt, and append -- these comments. declare Target_Line : constant Text_Type := Self.Unit.Get_Line (Positive (Start_Line)); -- Might be empty Comments : constant Text_Type := Target_Line (Target_Line'First + Positive (Self.Start_Stmt.Sloc_Range.End_Column) - 1 .. Target_Line'Last); Return_Stmt : constant Text_Type := "return " & Self.Start_Stmt.As_Assign_Stmt.F_Expr.Text & ";"; begin Extracted_Stmts.Append (To_UTF8 (Return_Stmt & Comments)); end; when others => raise Assertion_Error with Unexpected_End_Stmt_Kind_Exception_Message; end case; else -- Only one line with multiple statements to extract case Self.End_Stmt.Kind is when Ada_Return_Stmt_Range => declare Target_Line : constant Text_Type := Self.Unit.Get_Line (Positive (Start_Line)); Return_Stmt : constant Text_Type := Target_Line (Text (True_Start_Token)'First .. Text (True_End_Token)'Last); begin Extracted_Stmts.Append (To_UTF8 (Return_Stmt)); end; when Ada_Assign_Stmt_Range => -- There might be comments after the Assign_Stmt node. -- Transform End_Stmt into a Return_Stmt, prepend the -- previous statments and lastly, append any comments. declare Target_Line : constant Text_Type := Self.Unit.Get_Line (Positive (Start_Line)); Initial_Stmts : constant Text_Type := Target_Line (Target_Line'First + Positive (Self.Start_Stmt.Sloc_Range.Start_Column) - 1 .. Target_Line'First + Positive (Self.End_Stmt.Sloc_Range.Start_Column) - 1 - 1); -- Might be empty Comments : constant Text_Type := Target_Line (Target_Line'First + Positive (Self.End_Stmt.Sloc_Range.End_Column) - 1 .. Target_Line'Last); Return_Stmt : constant Text_Type := "return " & Self.End_Stmt.As_Assign_Stmt.F_Expr.Text & ";"; begin Extracted_Stmts.Append (To_UTF8 (Initial_Stmts & Return_Stmt & Comments)); end; when others => raise Assertion_Error with Unexpected_End_Stmt_Kind_Exception_Message; end case; end if; else if Self.Start_Stmt = Self.End_Stmt then -- Single Stmt across multiple lines. There might be some comments -- before, in the middle, or after it. Impossible predict where -- the comments are and to know how the user wants the code to be -- formated, so just gather all the comments and add them before -- the return statements. -- -- Example: -- -- A := -- Foo -- Some comment about Foo -- (B, -- Some comment about B -- C, -- Some comment about C -- D); -- Some comment about D -- -- Will result in -- -- -- Some comment about Foo -- -- Some comment about B -- -- Some comment about C -- -- Some comment about D -- return Foo (B, C, D); case Self.End_Stmt.Kind is when Ada_Return_Stmt_Range => declare Return_Stmt : constant Text_Type := Self.End_Stmt.As_Return_Stmt.Text; Aux_Token : Token_Reference := Self.Start_Token; begin loop if Kind (Data (Aux_Token)) in Ada_Comment then Extracted_Stmts.Append (To_UTF8 (Text (Aux_Token))); end if; exit when Aux_Token = Self.End_Token; Aux_Token := Next (Aux_Token); end loop; Extracted_Stmts.Append (To_UTF8 (Return_Stmt)); end; when Ada_Assign_Stmt_Range => declare Return_Stmt : constant Text_Type := "return " & Self.End_Stmt.As_Assign_Stmt.F_Expr.Text & ";"; Aux_Token : Token_Reference := Self.Start_Token; begin loop if Kind (Data (Aux_Token)) in Ada_Comment then Extracted_Stmts.Append (To_UTF8 (Text (Aux_Token))); end if; exit when Aux_Token = Self.End_Token; Aux_Token := Next (Aux_Token); end loop; Extracted_Stmts.Append (To_UTF8 (Return_Stmt)); end; when others => raise Assertion_Error with Unexpected_End_Stmt_Kind_Exception_Message; end case; else -- Multiple statements accross multiple lines. There might be some -- comments before, in the middle, or after it. -- Find the Minimum_Indentation, i.e., the indentation -- of the least indented statement or comment. declare use Ada.Strings.Wide_Wide_Fixed; Start_Line_First_Non_Blank : constant Positive := Index_Non_Blank (Self.Unit.Get_Line (Positive (Start_Line))); Include_Start_Line : constant Boolean := Start_Line_First_Non_Blank = Text (True_Start_Token)'First; Indentation : Natural; begin for Line_Number in (if Include_Start_Line then Start_Line else Start_Line + 1) .. Self.End_Stmt.Sloc_Range.Start_Line loop declare Line : constant Text_Type := Self.Unit.Get_Line (Positive (Line_Number)); begin if Line /= "" then Indentation := Index_Non_Blank (Line) - Line'First; if Indentation < Minimum_Indentation then Minimum_Indentation := Indentation; end if; end if; end; end loop; end; -- Add all statements from the first line up to the line with -- the last statement Extracted_Stmts.Append (To_UTF8 (Self.Unit.Get_Line (Positive (Start_Line)) (Text (True_Start_Token)'First .. Self.Unit.Get_Line (Positive (Start_Line))'Last))); for Line_Number in Start_Line + 1 .. Self.End_Stmt.Sloc_Range.Start_Line - 1 loop -- Note that if this is an empty line, -- Start_Index_To_Extract (Line_Number) > -- End_Index_To_Extract (Line_Number). -- Since Start_Index_To_Extract and End_Index_To_Extract -- are use to create a string slice, this is not a problem. -- It will result in an empty string, which is the same as -- an empty line. Extracted_Stmts.Append (To_UTF8 (Self.Unit.Get_Line (Positive (Line_Number)) (Self.Unit.Get_Line (Positive (Line_Number))'First + Minimum_Indentation .. Self.Unit.Get_Line (Positive (Line_Number))'Last))); end loop; -- Add the lines with the last statement case Self.End_Stmt.Kind is when Ada_Return_Stmt_Range => for Line_Number in Self.End_Stmt.Sloc_Range.Start_Line .. Self.End_Stmt.Sloc_Range.End_Line loop if Line_Number = Self.End_Stmt.Sloc_Range.End_Line and then Line_Number = End_Line then Extracted_Stmts.Append (To_UTF8 (Self.Unit.Get_Line (Positive (Line_Number)) (Self.Unit.Get_Line (Positive (Line_Number))'First + Minimum_Indentation .. Text (Self.End_Token)'Last))); else Extracted_Stmts.Append (To_UTF8 (Self.Unit.Get_Line (Positive (Line_Number)) (Self.Unit.Get_Line (Positive (Line_Number))'First + Minimum_Indentation .. Self.Unit.Get_Line (Positive (Start_Line))'Last))); end if; end loop; when Ada_Assign_Stmt_Range => declare Dest : constant Ada_Node'Class := Self.End_Stmt.As_Assign_Stmt.F_Dest; Dest_Line : constant Text_Type := Self.Unit.Get_Line (Positive (Dest.Sloc_Range.Start_Line)); Dest_Start_Index : constant Positive := Dest.Text'First; New_Dest_Text : constant String := To_UTF8 (Dest_Line (Dest_Line'First + Minimum_Indentation .. Dest_Start_Index - 1) & "return "); Expr : constant Ada_Node'Class := Self.End_Stmt.As_Assign_Stmt.F_Expr; Expr_Line : constant Text_Type := Self.Unit.Get_Line (Positive (Expr.Sloc_Range.Start_Line)); Expr_Line_Start_Index : constant Positive := Expr.Text'First; Expr_Line_End_Index : constant Positive := (if Expr.Sloc_Range.Start_Line = End_Line then Text (Self.End_Token)'Last else Expr_Line'Last); New_Expr_Text : constant String := To_UTF8 (Expr_Line (Expr_Line_Start_Index .. Expr_Line_End_Index)); begin -- Add any comments found between Dest and Expr declare Aux_Token : Token_Reference := Dest.Token_Start; begin loop if Kind (Data (Aux_Token)) in Ada_Comment then Extracted_Stmts.Append (To_UTF8 (Text (Aux_Token))); end if; exit when Aux_Token = Expr.Token_Start; Aux_Token := Next (Aux_Token); end loop; end; Extracted_Stmts.Append (New_Dest_Text & New_Expr_Text); for Line_Number in Expr.Sloc_Range.Start_Line + 1 .. Expr.Sloc_Range.End_Line loop Extracted_Stmts.Append (To_UTF8 (Self.Unit.Get_Line (Positive (Line_Number)) (Self.Unit.Get_Line (Positive (Line_Number))'First + Minimum_Indentation .. Self.Unit.Get_Line (Positive (Line_Number))'Last))); end loop; end; when others => raise Assertion_Error with Unexpected_End_Stmt_Kind_Exception_Message; end case; -- Add any lines after the last statement line. -- Consider these as whole line comments. for Line_Number in Self.End_Stmt.Sloc_Range.End_Line + 1 .. End_Line loop Extracted_Stmts.Append (To_UTF8 (Self.Unit.Get_Line (Positive (Line_Number)) (Self.Unit.Get_Line (Positive (Line_Number))'First + Minimum_Indentation .. Self.Unit.Get_Line (Positive (Line_Number))'Last))); end loop; end if; end if; return Extracted_Stmts; end Build_Extracted_Subprogram_Statements; -------------------------------- -- Build_Extracted_Subprogram -- -------------------------------- overriding function Build_Extracted_Subprogram (Self : Function_Extractor; Params : String_Vector; Statements : String_Vector; Offset : Natural; Indentation : Natural := 3) return String is use Ada.Characters.Latin_1; use String_Vectors; use Ada.Containers; function Get_Return_Type return String with Pre => not Self.End_Stmt.Is_Null and then Self.End_Stmt.Kind in Ada_Assign_Stmt_Range | Ada_Return_Stmt_Range; --------------------- -- Get_Return_Type -- --------------------- function Get_Return_Type return String is subtype Stmt_Kind_Type is Ada_Node_Kind_Type with Static_Predicate => Stmt_Kind_Type in Ada_Assign_Stmt_Range | Ada_Return_Stmt_Range; Stmt_Kind : constant Stmt_Kind_Type := Self.End_Stmt.Kind; use Langkit_Support.Text; begin case Stmt_Kind is when Ada_Assign_Stmt_Range => return To_UTF8 (Self.End_Stmt.As_Assign_Stmt.F_Dest. P_Referenced_Defining_Name. P_Basic_Decl.P_Type_Expression.Text); when Ada_Return_Stmt_Range => return To_UTF8 (Self.End_Stmt.P_Parent_Basic_Decl. As_Base_Subp_Body.F_Subp_Spec.F_Subp_Returns. Text); end case; end Get_Return_Type; Return_Type : constant String := Get_Return_Type; function Padding (N : Integer) return Unbounded_String is ((Offset + N * Indentation) * " "); -- Analyse the function Build_Function_Spec return String; -- Builds the ada code of the extracted function spec function Build_Function_Body return String; -- Builds the ada code of the extracted function body ------------------------- -- Build_Function_Spec -- ------------------------- function Build_Function_Spec return String is Subp_Spec : Unbounded_String; begin if Params.Is_Empty then Append (Subp_Spec, Padding (1) & "function " & Self.Name & " return " & Return_Type & ";" & LF); else if Params.Length = 1 then Append (Subp_Spec, Padding (1) & "function " & Self.Name & LF & Padding (1) & " (" & Params.First_Element & ")" & LF & Padding (2) & "return " & Return_Type & ";" & LF); else Append (Subp_Spec, Padding (1) & "function " & Self.Name & LF & Padding (1) & " (" & Params.First_Element & ";" & LF); for J in Params.First_Index + 1 .. Params.Last_Index - 1 loop Append (Subp_Spec, Padding (2) & Params.Element (J) & ";" & LF); end loop; Append (Subp_Spec, Padding (2) & Params.Last_Element & ")" & LF & Padding (2) & "return " & Return_Type & ";" & LF); end if; end if; return To_String (Subp_Spec); end Build_Function_Spec; ------------------------- -- Build_Function_Body -- ------------------------- function Build_Function_Body return String is use Ada.Strings; use Ada.Strings.Fixed; Function_Body : Unbounded_String; begin if Params.Is_Empty then Append (Function_Body, Padding (1) & "function " & Self.Name & " return " & Return_Type & " is" & LF); Append (Function_Body, Padding (1) & "begin" & LF); for Statement of Statements loop if Statement /= "" then Append (Function_Body, Padding (2) & Trim (Statement, Right) & LF); else Append (Function_Body, Statement & LF); end if; end loop; Append (Function_Body, Padding (1) & "end " & Self.Name & ";" & LF); else if Params.Length = 1 then Append (Function_Body, Padding (1) & "function " & Self.Name & LF & Padding (1) & " (" & Params.First_Element & ")" & LF & Padding (2) & "return " & Return_Type & " is" & LF); else Append (Function_Body, Padding (1) & "function " & Self.Name & LF & Padding (1) & " (" & Params.First_Element & ";" & LF); for J in Params.First_Index + 1 .. Params.Last_Index - 1 loop Append (Function_Body, Padding (2) & Params.Element (J) & ";" & LF); end loop; Append (Function_Body, Padding (2) & Params.Last_Element & ")" & LF & Padding (2) & "return " & Return_Type & " is" & LF); end if; Append (Function_Body, Padding (1) & "begin" & LF); for Statement of Statements loop if Statement /= "" then Append (Function_Body, Padding (2) & Trim (Statement, Right) & LF); else Append (Function_Body, Statement & LF); end if; end loop; Append (Function_Body, Padding (1) & "end " & Self.Name & ";" & LF); end if; return To_String (Function_Body); end Build_Function_Body; begin return LF & Build_Function_Spec & LF & Build_Function_Body & LF; end Build_Extracted_Subprogram; ------------------------------------- -- Build_Extracted_Subprogram_Call -- ------------------------------------- overriding function Build_Extracted_Subprogram_Call (Self : Function_Extractor; Name : String; Parameters : String_Vector) return String is use Langkit_Support.Text; Reduced_Function_Arguments : Unbounded_String; Destination : constant String := (if Get_Statements_To_Extract (Self.Start_Stmt, Self.End_Stmt).Last_Element.Kind in Ada_Return_Stmt_Range then "" else To_UTF8 (Get_Statements_To_Extract (Self.Start_Stmt, Self.End_Stmt). Last_Element.As_Assign_Stmt.F_Dest.Text)); begin if Destination /= "" then if Parameters.Is_Empty then return Destination & " := " & Name & ";"; else Append (Reduced_Function_Arguments, "(" & Parameters.First_Element); for J in Parameters.First_Index + 1 .. Parameters.Last_Index loop Append (Reduced_Function_Arguments, ", " & Parameters.Element (J)); end loop; Append (Reduced_Function_Arguments, ")"); return Destination & " := " & Name & " " & To_String (Reduced_Function_Arguments) & ";"; end if; else if Parameters.Is_Empty then return "return " & Name & ";"; else Append (Reduced_Function_Arguments, "(" & Parameters.First_Element); for J in Parameters.First_Index + 1 .. Parameters.Last_Index loop Append (Reduced_Function_Arguments, ", " & Parameters.Element (J)); end loop; Append (Reduced_Function_Arguments, ")"); return "return " & Name & " " & To_String (Reduced_Function_Arguments) & ";"; end if; end if; end Build_Extracted_Subprogram_Call; ------------------------------------- -- Is_Extract_Subprogram_Available -- ------------------------------------- function Is_Extract_Subprogram_Available (Unit : Analysis_Unit; Section_To_Extract : Source_Location_Range; Available_Subprogram_Kinds : out Available_Subprogram_Kinds_Type) return Boolean is Start_Token : constant Token_Reference := Unit.Lookup_Token (Source_Location' (Line => Section_To_Extract.Start_Line, Column => Section_To_Extract.Start_Column)); End_Token : constant Token_Reference := Unit.Lookup_Token (Source_Location' (Line => Section_To_Extract.End_Line, Column => Section_To_Extract.End_Column)); Start_Node : constant Ada_Node := Lookup (Unit, Start_Token, Forward); End_Node : constant Ada_Node := Lookup (Unit, End_Token, Backward); Start_Stmt : Stmt := No_Stmt; End_Stmt : Stmt := No_Stmt; It_Stmt : Stmt := No_Stmt; -- Used to iterate from Start_Stmt to End_Stmt Aux : Ada_Node := No_Ada_Node; function Is_Stmt (Node : Ada_Node'Class) return Boolean is (not Node.Is_Null and then Node.Kind in Ada_Stmt); procedure Is_Stmt_Callback (Parent : Ada_Node; Stop : in out Boolean); -- When Parent is a Stmt, stops the search and sets Aux to Parent ---------------------- -- Is_Stmt_Callback -- ---------------------- procedure Is_Stmt_Callback (Parent : Ada_Node; Stop : in out Boolean) is begin Stop := True; Aux := Parent; end Is_Stmt_Callback; begin if Start_Node.Is_Null or else End_Node.Is_Null then Available_Subprogram_Kinds := [others => False]; return False; end if; if Start_Node.Kind not in Ada_Stmt then Find_Matching_Parents (Start_Node, Is_Stmt'Access, Is_Stmt_Callback'Access); if Aux.Is_Null then Available_Subprogram_Kinds := [others => False]; return False; end if; Start_Stmt := Aux.As_Stmt; else Start_Stmt := Start_Node.As_Stmt; end if; if Start_Stmt.Kind in Ada_Base_Loop_Stmt and then Start_Stmt.Parent.Kind in Ada_Named_Stmt_Range then Start_Stmt := Start_Stmt.Parent.As_Stmt; end if; Aux := No_Ada_Node; if End_Node.Kind not in Ada_Stmt then Find_Matching_Parents (End_Node, Is_Stmt'Access, Is_Stmt_Callback'Access); if Aux.Is_Null then Available_Subprogram_Kinds := [others => False]; return False; end if; End_Stmt := Aux.As_Stmt; else End_Stmt := End_Node.As_Stmt; end if; if End_Stmt.Kind in Ada_Base_Loop_Stmt and then End_Stmt.Parent.Kind in Ada_Named_Stmt_Range then End_Stmt := End_Stmt.Parent.As_Stmt; end if; if Start_Stmt.Parent /= End_Stmt.Parent then Available_Subprogram_Kinds := [others => False]; return False; end if; -- Check for return statements that cannot be extracted. -- A return statement can only be extracted iff it is in a nested -- function body. -- End_Stmt is allowed to be a return statement since we can extract -- a function. if End_Stmt.Kind not in Ada_Return_Stmt_Range then It_Stmt := Start_Stmt; loop if It_Stmt.Kind in Ada_Return_Stmt_Range then -- From the if statement before this one, we know that if -- It_Stmt = End_Stmt => It_Stmt.Kind not in -- Ada_Return_Stmt_Range. -- -- If any sibling node in [Start_Stmt, End_Stmt[ is a return -- statement node, we can immediately conclude that we cannot -- extract. Available_Subprogram_Kinds := [others => False]; return False; else declare Found_Forbidden_Return_Stmt : Boolean := False; -- Flag to be filled by the Look_Up_Forbidden_Return_Stmts -- traverse function. function Look_Up_Forbidden_Return_Stmts (Node : Ada_Node'Class) return Visit_Status; -- Traverse function that looks for return statements that -- cannot be extracted. A return statement can only be -- extracted iff it is in a nested function body. ------------------------------------ -- Look_Up_Forbidden_Return_Stmts -- ------------------------------------ function Look_Up_Forbidden_Return_Stmts (Node : Ada_Node'Class) return Visit_Status is begin if Node.Is_Null then return Over; elsif Node.Kind in Ada_Return_Stmt_Range then Found_Forbidden_Return_Stmt := True; return Stop; elsif Node.Kind in Ada_Subp_Body_Range and then Node.As_Subp_Body.F_Subp_Spec.F_Subp_Kind in Ada_Subp_Kind_Function_Range then -- Ignore any child return statements of this -- function body since they are safe to be -- extracted. return Over; else return Into; end if; end Look_Up_Forbidden_Return_Stmts; begin It_Stmt.Traverse (Look_Up_Forbidden_Return_Stmts'Access); if Found_Forbidden_Return_Stmt then Available_Subprogram_Kinds := [others => False]; return False; end if; end; end if; exit when It_Stmt = End_Stmt; -- It_Stmt.Next_Sibling should never be null, because it should be -- End_Stmt before going beyond the last statement. However, with -- invalid code, it might be null. In that case, the refactoring -- is not available. if It_Stmt.Next_Sibling.Is_Null then return False; else It_Stmt := It_Stmt.Next_Sibling.As_Stmt; end if; end loop; end if; -- Check for exit statements that cannot be extracted It_Stmt := Start_Stmt; loop if It_Stmt.Kind in Ada_Exit_Stmt then -- If any sibling node from Start_Stmt to End_Stmt is an Exit_Stmt -- node we can immediately conclude that its correspondent -- loop statement will not be extracted, therefore, neither does -- this exit statement. Available_Subprogram_Kinds := [others => False]; return False; else declare Found_Forbidden_Exit_Stmt : Boolean := False; -- Flag to be filled by the Look_Up_Forbidden_Exit_Stmts -- traverse function. package Defining_Name_Indefinite_Hashed_Sets is new Ada.Containers.Indefinite_Hashed_Sets (Element_Type => Defining_Name'Class, Hash => Defining_Name_Hash, Equivalent_Elements => "=", "=" => "="); subtype Named_Loop_Indefinite_Hashed_Set is Defining_Name_Indefinite_Hashed_Sets.Set; Found_Loop : Boolean := It_Stmt.Kind in Ada_Base_Loop_Stmt; -- This variable will state if a loop node was found. If True -- before finding an unnamed exit statement, then the exit -- statement is allowed to be removed. -- This is not applicable for named exit statements since -- the correspondent named loop needs to be analysed. Named_Loop_Stmts : Named_Loop_Indefinite_Hashed_Set; -- A named exit statement can only be extracted iff its -- corresponding named loop statement was found first. This set -- will hold all the named loop statement that are to be -- extracted. function Look_Up_Forbidden_Exit_Stmts (Node : Ada_Node'Class) return Visit_Status; -- Traverse function that looks for exit statments that -- cannot be extracted. -- An exit statement can only be extract iff it's correspondent -- loop statement is also extracted. ---------------------------------- -- Look_Up_Forbidden_Exit_Stmts -- ---------------------------------- function Look_Up_Forbidden_Exit_Stmts (Node : Ada_Node'Class) return Visit_Status is Loop_Name : Name := No_Name; Loop_Referenced_Defining_Name : Defining_Name := No_Defining_Name; begin if Node.Is_Null then return Over; elsif Node.Kind in Ada_Base_Loop_Stmt then Found_Loop := True; if Node.Parent.Kind in Ada_Named_Stmt_Range then Named_Loop_Stmts.Include (Node.Parent.As_Named_Stmt.F_Decl.F_Name); end if; elsif Node.Kind in Ada_Exit_Stmt then -- Determine if it's a named exit statement or not Loop_Name := Node.As_Exit_Stmt.F_Loop_Name; Loop_Referenced_Defining_Name := (if not Loop_Name.Is_Null then Loop_Name.P_Referenced_Defining_Name else No_Defining_Name); -- If no loop was found yet, then it does not matter -- if it's a named exit statement or not - it cannot -- be extracted. -- Othewise, check if it's named and if its -- corresponding named loop is going to be extracted too. if not Found_Loop or else (not Loop_Referenced_Defining_Name.Is_Null and then not Named_Loop_Stmts.Contains (Loop_Referenced_Defining_Name)) then Found_Forbidden_Exit_Stmt := True; return Stop; end if; end if; return Into; end Look_Up_Forbidden_Exit_Stmts; begin if It_Stmt.Kind in Ada_Base_Loop_Stmt and then It_Stmt.Parent.Kind in Ada_Named_Stmt_Range then Named_Loop_Stmts.Include (It_Stmt.Parent.As_Named_Stmt.F_Decl.F_Name); end if; It_Stmt.Traverse (Look_Up_Forbidden_Exit_Stmts'Access); if Found_Forbidden_Exit_Stmt then Available_Subprogram_Kinds := [others => False]; return False; end if; end; end if; exit when It_Stmt = End_Stmt; -- It_Stmt.Next_Sibling should never be null, because it should be -- End_Stmt before going beyond the last statement. However, with -- invalid code, it might be null. In that case, the refactoring is -- not available. if It_Stmt.Next_Sibling.Is_Null then return False; else It_Stmt := It_Stmt.Next_Sibling.As_Stmt; end if; end loop; -- Check what kind of subprograms can be extracted if End_Stmt.Kind in Ada_Return_Stmt_Range then Available_Subprogram_Kinds := [Ada_Subp_Kind_Function => True, Ada_Subp_Kind_Procedure => False]; elsif End_Stmt.Kind in Ada_Assign_Stmt_Range then Available_Subprogram_Kinds := [Ada_Subp_Kind_Function => True, Ada_Subp_Kind_Procedure => True]; else Available_Subprogram_Kinds := [Ada_Subp_Kind_Function => False, Ada_Subp_Kind_Procedure => True]; end if; return True; exception when E : others => Refactor_Trace.Trace (E, Is_Refactoring_Tool_Available_Default_Error_Message (Tool_Name)); return False; end Is_Extract_Subprogram_Available; --------------------------------------- -- Default_Extracted_Subprogram_Name -- --------------------------------------- function Default_Extracted_Subprogram_Name (Unit : Analysis_Unit; Location : Source_Location) return Unbounded_String is use Ada.Containers; use Ada.Strings; use Langkit_Support.Text; Node : constant Ada_Node := Unit.Root.Lookup (Location); Nearest_Declarative_Part : constant Declarative_Part := Get_Enclosing_Declarative_Part (Node); function Hash (US : Unbounded_String) return Hash_Type is (Ada.Strings.Hash_Case_Insensitive (To_String (US))); package Unbounded_String_Hash_Sets is new Ada.Containers.Hashed_Sets (Element_Type => Unbounded_String, Hash => Hash, Equivalent_Elements => "=", "=" => "="); subtype Unbounded_String_Ordered_Set is Unbounded_String_Hash_Sets.Set; -- Subprogram names in Nearest_Declarative_Part Subprogram_Names : Unbounded_String_Ordered_Set; -- Default name when there are no collisions Target_Name : constant Unbounded_String := To_Unbounded_String ("Extracted"); Aux_Target_Name : Unbounded_String := Target_Name; Counter : Positive := 1; begin -- Find all subprogram names in Nearest_Declarative_Part for Decl of Nearest_Declarative_Part.F_Decls loop if Decl.Kind in Ada_Basic_Decl and then Is_Subprogram (Decl.As_Basic_Decl) then Subprogram_Names.Include (To_Unbounded_String (To_UTF8 (Decl.As_Basic_Decl.P_Defining_Name.Text))); end if; end loop; -- The extracted subprogram name will have an index if the default -- name (Target_Name) already exists. The full signature is not -- compared, only the name. while Subprogram_Names.Contains (Aux_Target_Name) loop Aux_Target_Name := Target_Name & ("_" & Trim (To_Unbounded_String (Counter'Image), Both)); Counter := Counter + 1; end loop; return Aux_Target_Name; end Default_Extracted_Subprogram_Name; --------------------------------- -- Create_Subprogram_Extractor -- --------------------------------- function Create_Subprogram_Extractor (Unit : Analysis_Unit; Section_To_Extract : Source_Location_Range; Subprogram_Kind : Ada_Subp_Kind; Subprogram_Name : Unbounded_String) return Subprogram_Extractor is Start_Token : constant Token_Reference := Unit.Lookup_Token (Source_Location' (Section_To_Extract.Start_Line, Section_To_Extract.Start_Column)); End_Token : constant Token_Reference := Unit.Lookup_Token (Source_Location' (Section_To_Extract.End_Line, Section_To_Extract.End_Column)); Start_Node : constant Ada_Node := Lookup (Unit, Start_Token, Forward); End_Node : constant Ada_Node := Lookup (Unit, End_Token, Backward); -- Section_To_Extract might no be complete, for instance, the -- Start_Line/Column might be in a whitespace. -- Therefore True_Start_Token and True_End_Token must be computed using -- Start_Token and End_Token. True_Start_Token : Token_Reference; True_End_Token : Token_Reference; -- Statements to be extracted Start_Stmt : Stmt := No_Stmt; End_Stmt : Stmt := No_Stmt; -- Used to find the first parent Stmt node of Start_Node and End_Node Aux : Ada_Node := No_Ada_Node; function Is_Stmt (Node : Ada_Node'Class) return Boolean is (not Node.Is_Null and then Node.Kind in Ada_Stmt); procedure Is_Stmt_Callback (Parent : Ada_Node; Stop : in out Boolean); -- When Parent is a Stmt, stops the search and sets Aux to Parent ---------------------- -- Is_Stmt_Callback -- ---------------------- procedure Is_Stmt_Callback (Parent : Ada_Node; Stop : in out Boolean) is begin Stop := True; Aux := Parent; end Is_Stmt_Callback; begin -- Find the first Stmt node that is a parent of Start_Node Aux := Start_Node; if Start_Node.Kind not in Ada_Stmt then Find_Matching_Parents (Start_Node, Is_Stmt'Access, Is_Stmt_Callback'Access); end if; Start_Stmt := Aux.As_Stmt; if Start_Stmt.Kind in Ada_Base_Loop_Stmt and then Start_Stmt.Parent.Kind in Ada_Named_Stmt_Range then Start_Stmt := Start_Stmt.Parent.As_Stmt; end if; -- Find the first Stmt node that is a parent of End_Node Aux := End_Node; if End_Node.Kind not in Ada_Stmt then Find_Matching_Parents (End_Node, Is_Stmt'Access, Is_Stmt_Callback'Access); end if; End_Stmt := Aux.As_Stmt; if End_Stmt.Kind in Ada_Base_Loop_Stmt and then End_Stmt.Parent.Kind in Ada_Named_Stmt_Range then End_Stmt := End_Stmt.Parent.As_Stmt; end if; -- If Start_Token is an Ada_Whitespace, then find the next token that is -- not an Ada_Whitespace. That will be the first guess for the -- True_Start_Token. True_Start_Token := (if Kind (Data (Start_Token)) = Ada_Whitespace then Next_Non_Whitespace (Start_Token, Forward) else Start_Token); -- If True_Start_Token comes after the first token of Start_Stmt -- then update it. True_Start_Token := (if Start_Stmt.Compare (Start_Sloc (Sloc_Range (Data (True_Start_Token)))) = Before then True_Start_Token else Unit.Lookup_Token (Source_Location' (Start_Stmt.Sloc_Range.Start_Line, Start_Stmt.Sloc_Range.Start_Column))); -- Do the exact same algorithm to find the True_End_Token, but in the -- opposite search direction. True_End_Token := (if Kind (Data (End_Token)) = Ada_Whitespace then Next_Non_Whitespace (End_Token, Backward) else End_Token); True_End_Token := (if End_Stmt.Compare (End_Sloc (Sloc_Range (Data (True_End_Token)))) = After then True_End_Token else Unit.Lookup_Token (Source_Location' (End_Stmt.Sloc_Range.End_Line, End_Stmt.Sloc_Range.End_Column - 1))); return Subprogram_Extractor' (Unit, True_Start_Token, True_End_Token, Start_Stmt, End_Stmt, Subprogram_Name, Subprogram_Kind); end Create_Subprogram_Extractor; -------------- -- Refactor -- -------------- overriding function Refactor (Self : Subprogram_Extractor; Analysis_Units : access function return Analysis_Unit_Array) return Refactoring_Edits is begin case Self.Kind is when Ada_Subp_Kind_Function_Range => return Function_Extractor' (Self.Unit, Self.Start_Token, Self.End_Token, Self.Start_Stmt, Self.End_Stmt, Self.Name).Extract; when Ada_Subp_Kind_Procedure_Range => return Procedure_Extractor' (Self.Unit, Self.Start_Token, Self.End_Token, Self.Start_Stmt, Self.End_Stmt, Self.Name).Extract; end case; exception when E : others => Refactor_Trace.Trace (E, Refactoring_Tool_Refactor_Default_Error_Message (Tool_Name)); return No_Refactoring_Edits; end Refactor; end LAL_Refactor.Extract_Subprogram;