------------------------------------------------------------------------------ -- -- -- GNATTEST COMPONENTS -- -- -- -- G N A T T E S T . S T U B . G E N E R A T O R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2014-2018, AdaCore -- -- -- -- GNATTEST is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNATTEST 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. 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 COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02110-1301, USA., -- -- -- -- GNATTEST is maintained by AdaCore (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ pragma Ada_2012; with Ada.Containers.Multiway_Trees; with Ada.Containers.Doubly_Linked_Lists; with Ada.Containers.Indefinite_Ordered_Maps; with Ada.Containers.Indefinite_Vectors; with Ada.Containers.Indefinite_Ordered_Sets; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.SHA1; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with Asis; use Asis; with Asis.Compilation_Units; use Asis.Compilation_Units; with Asis.Declarations; use Asis.Declarations; with Asis.Definitions; use Asis.Definitions; with Asis.Elements; use Asis.Elements; with Asis.Expressions; use Asis.Expressions; with Asis.Extensions; use Asis.Extensions; with Asis.Iterator; use Asis.Iterator; with Asis.Limited_Views; use Asis.Limited_Views; with Asis.Text; use Asis.Text; with Asis.Extensions.Flat_Kinds; use Asis.Extensions.Flat_Kinds; with ASIS_UL.Misc; use ASIS_UL.Misc; with GNATCOLL.Traces; use GNATCOLL.Traces; with GNATCOLL.VFS; use GNATCOLL.VFS; with GNATtest.Common; use GNATtest.Common; with GNATtest.Options; use GNATtest.Options; with GNATtest.Mapping; use GNATtest.Mapping; with GNATtest.Skeleton.Source_Table; with Ada.Text_IO; use Ada.Text_IO; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Strings; use Ada.Strings; with Ada.Strings.Fixed; use Ada.Strings.Fixed; package body GNATtest.Stub.Generator is Me : constant Trace_Handle := Create ("Stubs", Default => Off); Me_Mapping : constant Trace_Handle := Create ("Stubs.Mapping", Default => Off); ------------------ -- ASIS parsing -- ------------------ type Element_Node is record Spec : Asis.Element; Spec_Name : String_Access; -- Not used for incomplete type declarations. Inside_Generic : Boolean; Private_Part : Boolean; end record; Tasks_Present : Boolean; package Element_Node_Trees is new Ada.Containers.Multiway_Trees (Element_Node); use Element_Node_Trees; package Element_Node_Lists is new Ada.Containers.Doubly_Linked_Lists (Element_Node); use Element_Node_Lists; Nil_Element_Node : constant Element_Node := (Spec => Nil_Element, Spec_Name => null, Inside_Generic => False, Private_Part => False); type Data_Holder is record Elem_Tree : Element_Node_Trees.Tree; Flat_List : Element_Node_Lists.List; Limited_Withed_Units : String_Set.Set; -- All limited withed units from the spec should have a cooresponding -- regular with clause in the body. end record; function Requires_Body (El : Asis.Element) return Boolean; -- checks if a body sample should be created for an element procedure Gather_Data (The_Unit : Asis.Compilation_Unit; Data : out Data_Holder); -- Gathers all ASIS info for stub generation. -- arguments & result profile analysis type Stubbed_Parameter_Kinds is (Access_Kind, Constrained, Not_Constrained); type Stubbed_Parameter is record Name : String_Access; Type_Image : String_Access; Type_Full_Name_Image : String_Access; -- for nested types Kind : Stubbed_Parameter_Kinds; Type_Elem : Asis.Element; end record; package Stubbed_Parameter_Lists is new Ada.Containers.Doubly_Linked_Lists (Stubbed_Parameter); use Stubbed_Parameter_Lists; function Get_Args_List (Node : Element_Node) return Stubbed_Parameter_Lists.List; -- Returns info on access, out and in out parameters of the subprogram and -- on result profile in case of functions. function Get_Type_Image (Param_Type : Asis.Element) return String; -- Returns exact image is the argument type is not declared in nested -- package. Otherwise replaces whatever name of the type is given with -- corresponding full ada name. function Is_Abstract (Param_Type : Asis.Element) return Boolean; -- Analyzes type definition and detects is it's private or public -- declaration is abstract. function Is_Limited (Param_Type : Asis.Element) return Boolean; -- Analyzes type definition and detects is it's private or public -- declaration is limited. function Is_Only_Limited_Withed (Param_Type : Asis.Element) return Boolean; -- Analyzes type definition and detects if only the limited view is -- available. If so, Is_Limited and Is_Abstract are not to be applied. function Is_Fully_Private (Param_Type : Asis.Element) return Boolean; -- Analyzes type definition and detects if corresponding type is declared -- only in the private declaration part. function Filter_Private_Parameters (Param_List : Stubbed_Parameter_Lists.List) return Stubbed_Parameter_Lists.List; -- Filer out parameters of private types. ------------------------------ -- Markered Mata processing -- ------------------------------ type Markered_Data_Kinds is ( -- with clauses, code 00 Import_MD, -- incomplete type, code 01 Type_MD, -- task type or single task, code 02 Task_MD, -- local declarations in packages, code 03 Package_MD, -- subprogram, code 04 Subprogram_MD, -- entry, code 05 Entry_MD, -- possible elaboration code, code 06 Elaboration_MD, -- used in attempts to partially recover corrupted packages. code 99. Unknown_MD); function MD_Kind_To_String (MD : Markered_Data_Kinds) return String; -- Returns string with corresponding code. function MD_Kind_From_String (Str : String) return Markered_Data_Kinds; -- And back (Unknown for "99" and any illegal argument). type Markered_Data_Id is record Kind : Markered_Data_Kinds; Self_Hash : String_Access; Nesting_Hash : String_Access; Hash_Version : String_Access; Name : String_Access; end record; function "<" (L, R : Markered_Data_Id) return Boolean; package String_Vectors is new Ada.Containers.Indefinite_Vectors (Natural, String); type Markered_Data_Type is record Commneted_Out : Boolean := False; Lines : String_Vectors.Vector := String_Vectors.Empty_Vector; end record; function Generate_MD_Id_String (Element : Asis.Element; Commented_Out : Boolean := False) return String; function Generate_MD_Id_String (Id : Markered_Data_Id; Commented_Out : Boolean := False) return String; function Generate_MD_Id (Element : Asis.Element) return Markered_Data_Id; package Markered_Data_Maps is new Ada.Containers.Indefinite_Ordered_Maps (Markered_Data_Id, Markered_Data_Type, "<"); use Markered_Data_Maps; Markered_Data : Markered_Data_Maps.Map; -- Main MD storage for stub body. Markered_Subp_Data : Markered_Data_Maps.Map; -- Used to keep MD for subprograms that are actually present in the spec -- so that unused setters could be reported. -- Setters_Data : Markered_Data_Maps.Map; -- Stub_Data body and spec. procedure Gather_Markered_Data (File : String; Map : in out Markered_Data_Maps.Map); ----------------------------- -- Stub package generation -- ----------------------------- Level : Integer := 0; -- nesting level of a spec being processed Indent_Level : constant Natural := 3; -- indentation level procedure Generate_Body_Stub (Body_File_Name : String; Data : Data_Holder); -- Generates stub body. procedure Generate_Stub_Data (Stub_Data_File_Spec : String; Stub_Data_File_Body : String; Data : Data_Holder); -- Generates Stub_Data package which contains setters procedure Put_Stub_Header (Unit_Name : String; Stub_Data : Boolean := True; Limited_Withed : String_Set.Set); -- Puts header of generated stub explaining where user code should be put. procedure Put_Import_Section (Markered_Data : in out Markered_Data_Maps.Map; Add_Import : Boolean := False); -- Puts or regenerates markered section for with clauses. procedure Process_Siblings (Cursor : Element_Node_Trees.Cursor); procedure Process_Node (Cursor : Element_Node_Trees.Cursor); procedure Put_Lines (MD : Markered_Data_Type; Comment_Out : Boolean); procedure Generate_Package_Body (Node : Element_Node; Cursor : Element_Node_Trees.Cursor); procedure Generate_Protected_Body (Node : Element_Node; Cursor : Element_Node_Trees.Cursor); procedure Generate_Full_Type_Declaration (Node : Element_Node); procedure Generate_Task_Body (Node : Element_Node); procedure Generate_Entry_Body (Node : Element_Node); procedure Generate_Procedure_Body (Node : Element_Node); procedure Generate_Function_Body (Node : Element_Node); procedure Put_Dangling_Elements; ------------------------------- -- Setter package generation -- ------------------------------- procedure Generate_Default_Setter_Spec (Node : Element_Node); -- Generate stub data type and object and a setter spec. procedure Generate_Default_Setter_Body (Node : Element_Node); -- Generate setter body. function Hash_Suffix (ID : Markered_Data_Id) return String; -- Returns hash suffix from gived ID. function Get_Access_Type_Name (Elem : Asis.Element) return String; -- Returns full ada name for given type definition with "." and "'" -- replaced with underscores and an "_Access" suffix. type Access_Dictionary_Entry is record Entry_Str : String_Access := null; Type_Decl : Asis.Declaration := Nil_Element; end record; function "<" (L, R : Access_Dictionary_Entry) return Boolean is (L.Entry_Str.all < R.Entry_Str.all); package Access_Dictionaries is new Ada.Containers.Indefinite_Ordered_Sets (Access_Dictionary_Entry); use Access_Dictionaries; Dictionary : Access_Dictionaries.Set; -- A set of all unrestricted types that we need to make access types for. procedure Add_Unconstrained_Type_To_Dictionary (Elem : Asis.Element); -- Updates the dictionary of unconstrained-to-access types if needed. function Get_Declaration (Elem : Asis.Element) return Asis.Declaration; -- Returns declaration of corresponding parameter type. ------------- -- Mapping -- ------------- use Entity_Stub_Mapping_List; Local_Stub_Unit_Mapping : Stub_Unit_Mapping; procedure Add_Entity_To_Local_List (Node : Element_Node; New_First_Line, New_First_Column : Natural); -- Adds mapping info to Local_Stub_Unit_Mapping. procedure Update_Local_Entity_With_Setter (Node : Element_Node; New_First_Line, New_First_Column : Natural); -- Adds mapping info on setter to corresponding item in the list. --------- -- "<" -- --------- function "<" (L, R : Markered_Data_Id) return Boolean is begin if L.Kind < R.Kind then return True; end if; if L.Kind = R.Kind then if L.Self_Hash.all < R.Self_Hash.all then return True; end if; if L.Self_Hash.all = R.Self_Hash.all then if L.Nesting_Hash.all < R.Nesting_Hash.all then return True; end if; if L.Nesting_Hash.all = R.Nesting_Hash.all then if L.Hash_Version.all < R.Hash_Version.all then return True; end if; end if; end if; end if; return False; end "<"; ------------------------------ -- Add_Entity_To_Local_List -- ------------------------------ procedure Add_Entity_To_Local_List (Node : Element_Node; New_First_Line, New_First_Column : Natural) is Local_Entity : Entity_Stub_Mapping; -- Local_Body : Asis.Element; begin Trace (Me_Mapping, "adding entry for " & Node.Spec_Name.all); Local_Entity.Name := new String'(Node.Spec_Name.all); Local_Entity.Line := First_Line_Number (Node.Spec); Local_Entity.Column := First_Column_Number (Node.Spec); -- Local_Body := Corresponding_Body (Node.Spec); -- Local_Entity.Original_Body.Line := First_Line_Number (Local_Body); -- Local_Entity.Original_Body.Column := -- First_Column_Number (Local_Body); Local_Entity.Stub_Body.Line := New_First_Line; Local_Entity.Stub_Body.Column := New_First_Column; Local_Entity.Setter := Nil_Entity_Sloc; Local_Stub_Unit_Mapping.Entities.Append (Local_Entity); end Add_Entity_To_Local_List; ------------------------------------------ -- Add_Unconstrained_Type_To_Dictionary -- ------------------------------------------ procedure Add_Unconstrained_Type_To_Dictionary (Elem : Asis.Element) is Encl : Asis.Element := Enclosing_Element (Get_Declaration (Elem)); Dict_Elem : Access_Dictionary_Entry; D_Cur : Access_Dictionaries.Cursor; begin -- Types foraml or not, declared in nested generic packages should not -- be added to the dictionary. while not Is_Nil (Encl) loop case Declaration_Kind (Encl) is when A_Generic_Package_Declaration | A_Generic_Procedure_Declaration | A_Generic_Function_Declaration => return; when others => null; end case; Encl := Enclosing_Element (Encl); end loop; Dict_Elem.Type_Decl := Get_Declaration (Elem); D_Cur := Dictionary.First; while D_Cur /= Access_Dictionaries.No_Element loop if Is_Equal (Access_Dictionaries.Element (D_Cur).Type_Decl, Dict_Elem.Type_Decl) then return; end if; Next (D_Cur); end loop; Dict_Elem.Entry_Str := new String' ("type " & Get_Access_Type_Name (Elem) & " is access all " & Get_Type_Image (Elem) & ";"); Dictionary.Include (Dict_Elem); end Add_Unconstrained_Type_To_Dictionary; ------------------ -- Process_Unit -- ------------------ procedure Process_Unit (CU : Asis.Compilation_Unit; Body_File_Name : String; Stub_Data_File_Spec : String; Stub_Data_File_Body : String) is Data : Data_Holder; begin Gather_Data (CU, Data); Gather_Markered_Data (Body_File_Name, Markered_Data); Local_Stub_Unit_Mapping.Stub_Data_File_Name := new String'(Stub_Data_File_Body); Local_Stub_Unit_Mapping.Orig_Body_File_Name := new String' (GNATtest.Skeleton.Source_Table.Get_Source_Body (To_String (Text_Name (CU)))); Local_Stub_Unit_Mapping.Stub_Body_File_Name := new String'(Body_File_Name); Generate_Body_Stub (Body_File_Name, Data); Generate_Stub_Data (Stub_Data_File_Spec, Stub_Data_File_Body, Data); Add_Stub_List (To_String (Text_Name (CU)), Local_Stub_Unit_Mapping); Dictionary.Clear; Free (Local_Stub_Unit_Mapping.Stub_Data_File_Name); Free (Local_Stub_Unit_Mapping.Orig_Body_File_Name); Free (Local_Stub_Unit_Mapping.Stub_Body_File_Name); Local_Stub_Unit_Mapping.Entities.Clear; Local_Stub_Unit_Mapping.D_Setters.Clear; Local_Stub_Unit_Mapping.D_Bodies.Clear; Data.Elem_Tree.Clear; Data.Flat_List.Clear; Data.Limited_Withed_Units.Clear; end Process_Unit; --------------------------- -- Put_Dangling_Elements -- --------------------------- procedure Put_Dangling_Elements is MD_Cur : Markered_Data_Maps.Cursor := Markered_Data.First; ID : Markered_Data_Id; MD : Markered_Data_Type; begin S_Put (3, "-------------------"); New_Line_Count; S_Put (3, "-- Unused Bodies --"); New_Line_Count; S_Put (3, "-------------------"); New_Line_Count; New_Line_Count; while MD_Cur /= Markered_Data_Maps.No_Element loop ID := Markered_Data_Maps.Key (MD_Cur); MD := Markered_Data_Maps.Element (MD_Cur); if not (ID.Kind in Subprogram_MD | Task_MD | Entry_MD) then goto END_DANGLING; end if; S_Put (0, GT_Marker_Begin); New_Line_Count; case ID.Kind is when Subprogram_MD => S_Put (Indent_Level, "-- procedure/function " & ID.Name.all & " is"); when Task_MD => S_Put (3, "-- task body " & ID.Name.all & " is"); when Entry_MD => S_Put (3, "-- entry " & ID.Name.all & " when"); when others => null; end case; New_Line_Count; Local_Stub_Unit_Mapping.D_Bodies.Append ((New_Line_Counter, 0)); S_Put (2 * Indent_Level, Generate_MD_Id_String (ID, Commented_Out => True)); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; Put_Lines (MD, Comment_Out => True); S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put (Indent_Level, "-- end " & ID.Name.all & ";"); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; <> Next (MD_Cur); end loop; end Put_Dangling_Elements; ------------------------ -- Put_Import_Section -- ------------------------ procedure Put_Import_Section (Markered_Data : in out Markered_Data_Maps.Map; Add_Import : Boolean := False) is ID : constant Markered_Data_Id := (Import_MD, new String'(""), new String'(""), new String'(Hash_Version), new String'("")); MD : Markered_Data_Type; begin S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put (0, "-- id:" & Hash_Version & "/" & MD_Kind_To_String (Import_MD) & "/"); -- No need for hashes here. New_Line_Count; S_Put (0, "--"); New_Line_Count; S_Put (0, "-- This section can be used to add with clauses if necessary."); New_Line_Count; S_Put (0, "--"); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; if Markered_Data.Contains (ID) then -- Extract importing MD MD := Markered_Data.Element (ID); Put_Lines (MD, Comment_Out => False); Markered_Data.Delete (ID); else New_Line_Count; if Add_Import and then Tasks_Present then S_Put (3, "with Ada.Real_Time;"); New_Line_Count; end if; end if; S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; end Put_Import_Section; --------------- -- Put_Lines -- --------------- procedure Put_Lines (MD : Markered_Data_Type; Comment_Out : Boolean) is function Comment_Line (S : String) return String is ("-- " & S); function Uncomment_Line (S : String) return String; -------------------- -- Uncomment_Line -- -------------------- function Uncomment_Line (S : String) return String is begin if S = "-- " then return ""; end if; if S'Length < 5 then return S; end if; if S (S'First .. S'First + 3) = "-- " then return S (S'First + 4 .. S'Last); end if; return S; end Uncomment_Line; begin if MD.Commneted_Out = Comment_Out then for I in MD.Lines.First_Index .. MD.Lines.Last_Index loop S_Put (0, MD.Lines.Element (I)); New_Line_Count; end loop; else if Comment_Out then for I in MD.Lines.First_Index .. MD.Lines.Last_Index loop S_Put (0, Comment_Line (MD.Lines.Element (I))); New_Line_Count; end loop; else for I in MD.Lines.First_Index .. MD.Lines.Last_Index loop S_Put (0, Uncomment_Line (MD.Lines.Element (I))); New_Line_Count; end loop; end if; end if; end Put_Lines; --------------------- -- Put_Stub_Header -- --------------------- procedure Put_Stub_Header (Unit_Name : String; Stub_Data : Boolean := True; Limited_Withed : String_Set.Set) is Cur : String_Set.Cursor := Limited_Withed.First; use String_Set; begin S_Put (0, "-- This package has been generated " & "automatically by GNATtest."); New_Line_Count; S_Put (0, "-- You are allowed to add your code to " & "designated areas between read-only"); New_Line_Count; S_Put (0, "-- sections. Such changes will be kept during " & "further regeneration of this"); New_Line_Count; S_Put (0, "-- file. All code placed outside of such " & "areas will be lost during"); New_Line_Count; S_Put (0, "-- regeneration of this package."); New_Line_Count; New_Line_Count; S_Put (0, GT_Marker_Begin); New_Line_Count; if Stub_Data then S_Put (0, "with " & Unit_Name & "." & Stub_Data_Unit_Name & "; use " & Unit_Name & "." & Stub_Data_Unit_Name & ";"); end if; New_Line_Count; -- We need to put a regular with into the body for every limited with -- from the spec. while Cur /= String_Set.No_Element loop S_Put (0, "with " & String_Set.Element (Cur) & ";"); New_Line_Count; Next (Cur); end loop; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; end Put_Stub_Header; procedure Process_Siblings (Cursor : Element_Node_Trees.Cursor) is Cur : Element_Node_Trees.Cursor := Cursor; begin while Cur /= Element_Node_Trees.No_Element loop Process_Node (Cur); Next_Sibling (Cur); end loop; end Process_Siblings; procedure Process_Node (Cursor : Element_Node_Trees.Cursor) is Node : constant Element_Node := Element_Node_Trees.Element (Cursor); Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Node.Spec); begin case Arg_Kind is when A_Package_Declaration | A_Generic_Package_Declaration => Generate_Package_Body (Node, Cursor); when A_Function_Declaration | A_Function_Body_Stub | A_Generic_Function_Declaration => Generate_Function_Body (Node); when A_Procedure_Declaration | A_Procedure_Body_Stub | A_Generic_Procedure_Declaration => Generate_Procedure_Body (Node); when An_Entry_Declaration => Generate_Entry_Body (Node); when A_Single_Protected_Declaration | A_Protected_Type_Declaration => Generate_Protected_Body (Node, Cursor); when A_Single_Task_Declaration | A_Task_Type_Declaration => Generate_Task_Body (Node); when An_Incomplete_Type_Declaration | A_Tagged_Incomplete_Type_Declaration => Generate_Full_Type_Declaration (Node); when others => Report_Err ("gnattest: unexpected element in the body structure"); raise Fatal_Error; end case; end Process_Node; ----------------- -- Gather_Data -- ----------------- procedure Gather_Data (The_Unit : Asis.Compilation_Unit; Data : out Data_Holder) is separate; -------------------------- -- Gather_Markered_Data -- -------------------------- procedure Gather_Markered_Data (File : String; Map : in out Markered_Data_Maps.Map) is Line : String_Access; Line_Counter : Natural := 0; ID_Found, Commented_Out : Boolean; MD : Markered_Data_Type; ID : Markered_Data_Id := (Unknown_MD, null, null, null, null); Input_File : Ada.Text_IO.File_Type; type Parsing_Modes is (Code, Marker, Other); Parsing_Mode : Parsing_Modes := Other; Prev_Parsing_Mode : Parsing_Modes := Other; function Is_Marker_Start (S : String) return Boolean is (Trim (S, Both) = GT_Marker_Begin); function Is_Marker_End (S : String) return Boolean is (Trim (S, Both) = GT_Marker_End); function Is_Id_String (S : String) return Boolean is (Head (Trim (S, Both), 7) = "-- id:"); procedure Parse_Id_String (S : String; MD : out Markered_Data_Id; Commented_Out : out Boolean); procedure Parse_Id_String (S : String; MD : out Markered_Data_Id; Commented_Out : out Boolean) is Str : constant String := Trim (S, Both); Idx1, Idx2 : Natural; begin Commented_Out := False; Idx1 := Str'First + 7; Idx2 := Index (Str, "/", Idx1 + 1); MD.Hash_Version := new String'(Str (Idx1 .. Idx2 - 1)); Idx1 := Idx2 + 1; Idx2 := Index (Str, "/", Idx1 + 1); MD.Kind := MD_Kind_From_String (Str (Idx1 .. Idx2 - 1)); if MD.Kind = Import_MD then -- Nothing else to parse for this type. MD.Self_Hash := new String'(""); MD.Nesting_Hash := new String'(""); return; end if; Idx1 := Idx2 + 1; Idx2 := Index (Str, "/", Idx1 + 1); MD.Self_Hash := new String'(Str (Idx1 .. Idx2 - 1)); Idx1 := Idx2 + 1; Idx2 := Index (Str, "/", Idx1 + 1); MD.Nesting_Hash := new String'(Str (Idx1 .. Idx2 - 1)); Idx1 := Idx2 + 1; Idx2 := Index (Str, "/", Idx1 + 1); if Str (Idx1 .. Idx2 - 1) = "1" then Commented_Out := True; end if; Idx1 := Idx2 + 1; Idx2 := Index (Str, "/", Idx1 + 1); MD.Name := new String'(Str (Idx1 .. Idx2 - 1)); end Parse_Id_String; begin if not Is_Regular_File (File) then return; end if; Open (Input_File, In_File, File); Trace (Me, "parsing " & File & " for markered blocks"); Increase_Indent (Me); while not End_Of_File (Input_File) loop Line := new String'(Get_Line (Input_File)); Line_Counter := Line_Counter + 1; case Parsing_Mode is when Code => if Is_Marker_Start (Line.all) then Map.Include (ID, MD); Prev_Parsing_Mode := Code; Parsing_Mode := Marker; MD.Lines := String_Vectors.Empty_Vector; Trace (Me, "closing marker found at line" & Natural'Image (Line_Counter)); else MD.Lines.Append (Line.all); end if; when Marker => case Prev_Parsing_Mode is when Other => if Is_Id_String (Line.all) then Parse_Id_String (Line.all, ID, Commented_Out); MD.Commneted_Out := Commented_Out; ID_Found := True; Trace (Me, "id string found at line" & Natural'Image (Line_Counter)); end if; if Is_Marker_End (Line.all) then if ID_Found then Prev_Parsing_Mode := Marker; Parsing_Mode := Code; Trace (Me, "switching to 'Code' at line" & Natural'Image (Line_Counter)); else Prev_Parsing_Mode := Marker; Parsing_Mode := Other; Trace (Me, "switching to 'Other' at line" & Natural'Image (Line_Counter)); end if; end if; when Code => if Is_Marker_End (Line.all) then Prev_Parsing_Mode := Marker; Parsing_Mode := Other; Trace (Me, "switching to 'Other' at line" & Natural'Image (Line_Counter)); end if; when Marker => -- Can't happen. null; end case; when Other => if Is_Marker_Start (Line.all) then Parsing_Mode := Marker; Prev_Parsing_Mode := Other; ID_Found := False; Trace (Me, "opening marker found at line" & Natural'Image (Line_Counter)); end if; end case; Free (Line); end loop; Decrease_Indent (Me); Close (Input_File); end Gather_Markered_Data; ------------------------ -- Generate_Body_Stub -- ------------------------ procedure Generate_Body_Stub (Body_File_Name : String; Data : Data_Holder) is Tmp_File_Name : constant String := "gnattest_tmp_stub_body"; Success : Boolean; begin Trace (Me, "generating body of " & Body_File_Name); Increase_Indent (Me); Create (Tmp_File_Name); Reset_Line_Counter; Put_Stub_Header (Element_Node_Trees.Element (First_Child (Data.Elem_Tree.Root)).Spec_Name.all, not Data.Flat_List.Is_Empty, Data.Limited_Withed_Units); Put_Import_Section (Markered_Data, Add_Import => True); Process_Siblings (First_Child (Data.Elem_Tree.Root)); Close_File; declare F : File_Array_Access; begin Append (F, Dir (GNATCOLL.VFS.Create (+(Body_File_Name)))); Create_Dirs (F); end; -- At this point temp package is coplete and it is safe -- to replace the old one with it. if Is_Regular_File (Body_File_Name) then Delete_File (Body_File_Name, Success); if not Success then Report_Err ("cannot delete " & Body_File_Name); raise Fatal_Error; end if; end if; Copy_File (Tmp_File_Name, Body_File_Name, Success); if not Success then Report_Err ("cannot copy tmp test package to " & Body_File_Name); raise Fatal_Error; end if; Delete_File (Tmp_File_Name, Success); if not Success then Report_Err ("cannot delete tmp test package"); raise Fatal_Error; end if; Decrease_Indent (Me); end Generate_Body_Stub; ---------------------------------- -- Generate_Default_Setter_Spec -- ---------------------------------- procedure Generate_Default_Setter_Spec (Node : Element_Node) is ID : constant Markered_Data_Id := Generate_MD_Id (Node.Spec); Suffix : constant String := Hash_Suffix (ID); Param_List : Stubbed_Parameter_Lists.List := Filter_Private_Parameters (Get_Args_List (Node)); Cur : Stubbed_Parameter_Lists.Cursor; Empty_Case : Boolean := Param_List.Is_Empty; Abstract_Res_Profile : constant Boolean := not Empty_Case and then not Is_Nil (Param_List.Last_Element.Type_Elem) and then not Is_Only_Limited_Withed (Param_List.Last_Element.Type_Elem) and then Is_Abstract (Param_List.Last_Element.Type_Elem); SP : Stubbed_Parameter; Count : Natural; begin Trace (Me, "Generating default setter spec for " & Node.Spec_Name.all); if Abstract_Res_Profile and then not Empty_Case then -- No need to keep it in the parameters list. Param_List.Delete_Last; end if; Empty_Case := Param_List.Is_Empty; -- stub type S_Put (3, "type " & Stub_Type_Prefix & Node.Spec_Name.all & Suffix & " is record"); New_Line_Count; Cur := Param_List.First; while Cur /= Stubbed_Parameter_Lists.No_Element loop SP := Stubbed_Parameter_Lists.Element (Cur); S_Put (6, SP.Name.all & " : " & SP.Type_Full_Name_Image.all & ";"); New_Line_Count; Next (Cur); end loop; New_Line_Count; S_Put (6, Stub_Counter_Var & " : Natural := 0;"); New_Line_Count; S_Put (3, "end record;"); New_Line_Count; -- stub object S_Put (3, Stub_Object_Prefix & Node.Spec_Name.all & Suffix & " : " & Stub_Type_Prefix & Node.Spec_Name.all & Suffix & ";"); New_Line_Count; -- setter S_Put (3, "procedure " & Setter_Prefix & Node.Spec_Name.all & Suffix); if not Empty_Case then New_Line_Count; S_Put (5, "("); Cur := Param_List.First; Count := 1; while Cur /= Stubbed_Parameter_Lists.No_Element loop SP := Stubbed_Parameter_Lists.Element (Cur); if Count = 1 then S_Put (0, SP.Name.all & " : " & SP.Type_Full_Name_Image.all & " := " & Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & SP.Name.all); else S_Put (6, SP.Name.all & " : " & SP.Type_Full_Name_Image.all & " := " & Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & SP.Name.all); end if; if Count = Natural (Param_List.Length) then S_Put (0, ");"); else S_Put (0, ";"); end if; New_Line_Count; Next (Cur); Count := Count + 1; end loop; else S_Put (0, ";"); New_Line_Count; end if; Param_List.Clear; end Generate_Default_Setter_Spec; ---------------------------------- -- Generate_Default_Setter_Body -- ---------------------------------- procedure Generate_Default_Setter_Body (Node : Element_Node) is ID : constant Markered_Data_Id := Generate_MD_Id (Node.Spec); Suffix : constant String := Hash_Suffix (ID); Param_List : Stubbed_Parameter_Lists.List := Filter_Private_Parameters (Get_Args_List (Node)); Cur : Stubbed_Parameter_Lists.Cursor; Empty_Case : Boolean := Param_List.Is_Empty; Abstract_Res_Profile : constant Boolean := not Empty_Case and then not Is_Nil (Param_List.Last_Element.Type_Elem) and then not Is_Only_Limited_Withed (Param_List.Last_Element.Type_Elem) and then Is_Abstract (Param_List.Last_Element.Type_Elem); SP : Stubbed_Parameter; Count : Natural; Non_Limited_Parameters : Boolean := False; begin Trace (Me, "Generating default setter body for " & Node.Spec_Name.all); if Abstract_Res_Profile and then not Empty_Case then -- No need to keep it in the parameters list. Param_List.Delete_Last; end if; Empty_Case := Param_List.Is_Empty; S_Put (3, "procedure " & Setter_Prefix & Node.Spec_Name.all & Suffix); if not Empty_Case then New_Line_Count; S_Put (5, "("); -- params declaration Cur := Param_List.First; Count := 1; while Cur /= Stubbed_Parameter_Lists.No_Element loop SP := Stubbed_Parameter_Lists.Element (Cur); if Count = 1 then S_Put (0, SP.Name.all & " : " & SP.Type_Full_Name_Image.all & " := " & Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & SP.Name.all); else S_Put (6, SP.Name.all & " : " & SP.Type_Full_Name_Image.all & " := " & Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & SP.Name.all); end if; if Count = Natural (Param_List.Length) then S_Put (0, ") is"); else S_Put (0, ";"); end if; New_Line_Count; Next (Cur); Count := Count + 1; end loop; S_Put (3, "begin"); New_Line_Count; -- params setting Cur := Param_List.First; while Cur /= Stubbed_Parameter_Lists.No_Element loop SP := Stubbed_Parameter_Lists.Element (Cur); if not Is_Limited (SP.Type_Elem) then S_Put (6, Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & SP.Name.all & " := " & SP.Name.all & ";"); New_Line_Count; Non_Limited_Parameters := True; end if; Next (Cur); end loop; if not Non_Limited_Parameters then S_Put (6, "null;"); end if; else S_Put (1, " is"); New_Line_Count; S_Put (3, "begin"); New_Line_Count; S_Put (6, "null;"); New_Line_Count; end if; New_Line_Count; S_Put (3, "end " & Setter_Prefix & Node.Spec_Name.all & Suffix & ";"); New_Line_Count; New_Line_Count; Param_List.Clear; end Generate_Default_Setter_Body; ------------------------- -- Generate_Entry_Body -- ------------------------- procedure Generate_Entry_Body (Node : Element_Node) is ID : constant Markered_Data_Id := Generate_MD_Id (Node.Spec); MD : Markered_Data_Type; Parameters : constant Asis.Element_List := Parameter_Profile (Node.Spec); Family_Def : constant Asis.Element := Entry_Family_Definition (Node.Spec); begin Trace (Me, "Generating entry body for " & Node.Spec_Name.all); S_Put (0, GT_Marker_Begin); New_Line_Count; Add_Entity_To_Local_List (Node, New_Line_Counter, Level * Indent_Level); S_Put (Level * Indent_Level, "entry " & Node.Spec_Name.all); if not Is_Nil (Family_Def) then S_Put (0, " (for I in " & To_String (ASIS_Trim (Element_Image (Family_Def))) & ")"); end if; New_Line_Count; if not Is_Nil (Parameters) then S_Put (Level * Indent_Level + 2, "("); for I in Parameters'Range loop if I = Parameters'First then S_Put (0, To_String (ASIS_Trim (Element_Image (Parameters (I))))); else S_Put ((Level + 1) * Indent_Level, To_String (ASIS_Trim (Element_Image (Parameters (I))))); end if; if I = Parameters'Last then S_Put (0, ") when"); else S_Put (0, ";"); end if; New_Line_Count; end loop; else S_Put (Level * Indent_Level + 2, "when"); New_Line_Count; end if; S_Put ((Level + 1) * Indent_Level, Generate_MD_Id_String (Node.Spec)); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "--"); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "-- This section can be used to change entry body."); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "--"); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; -- Put body if Markered_Data.Contains (ID) then -- Extract importing MD MD := Markered_Data.Element (ID); Put_Lines (MD, Comment_Out => False); Markered_Data.Delete (ID); else New_Line_Count; S_Put (Level * Indent_Level + 2, " Standard.True"); New_Line_Count; S_Put (Level * Indent_Level, "is"); New_Line_Count; S_Put ((Level) * Indent_Level, "begin"); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "null;"); New_Line_Count; end if; S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put ((Level) * Indent_Level, "end " & Node.Spec_Name.all & ";"); New_Line_Count; New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; end Generate_Entry_Body; ------------------------------------ -- Generate_Full_Type_Declaration -- ------------------------------------ procedure Generate_Full_Type_Declaration (Node : Element_Node) is Discr_Part : constant Asis.Element := Discriminant_Part (Node.Spec); Is_Tagged : constant Boolean := Flat_Element_Kind (Node.Spec) = A_Tagged_Incomplete_Type_Declaration; ID : constant Markered_Data_Id := Generate_MD_Id (Node.Spec); MD : Markered_Data_Type; begin Trace (Me, "Generating full type declaration for " & Node.Spec_Name.all); S_Put (0, GT_Marker_Begin); New_Line_Count; Add_Entity_To_Local_List (Node, New_Line_Counter, Level * Indent_Level); S_Put (Level * Indent_Level, "type " & Node.Spec_Name.all & " "); if Flat_Element_Kind (Discr_Part) = A_Known_Discriminant_Part then S_Put (0, To_String (ASIS_Trim (Element_Image (Discr_Part))) & " "); end if; S_Put (0, "is"); if Is_Tagged then S_Put (0, " tagged"); end if; New_Line_Count; S_Put ((Level) * Indent_Level, Generate_MD_Id_String (Node.Spec)); New_Line_Count; S_Put ((Level) * Indent_Level, "--"); New_Line_Count; S_Put ((Level) * Indent_Level, "-- This section can be used for changing type completion."); New_Line_Count; S_Put ((Level) * Indent_Level, "--"); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; -- Put bodies if Markered_Data.Contains (ID) then -- Extract importing MD MD := Markered_Data.Element (ID); Put_Lines (MD, Comment_Out => False); Markered_Data.Delete (ID); else New_Line_Count; S_Put ((Level) * Indent_Level + 2, "null record;"); New_Line_Count; New_Line_Count; end if; S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; end Generate_Full_Type_Declaration; ---------------------------- -- Generate_Function_Body -- ---------------------------- procedure Generate_Function_Body (Node : Element_Node) is ID : constant Markered_Data_Id := Generate_MD_Id (Node.Spec); MD : Markered_Data_Type; Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Node.Spec); Parameters : constant Asis.Element_List := Parameter_Profile (Node.Spec); Res_Profile : constant Asis.Element := Result_Profile (Node.Spec); Param_List : constant Stubbed_Parameter_Lists.List := Get_Args_List (Node); Cur : Stubbed_Parameter_Lists.Cursor; SP : Stubbed_Parameter; Suffix : constant String := Hash_Suffix (ID); Not_Empty_Stub : constant Boolean := Arg_Kind = A_Function_Declaration and then (not Node.Inside_Generic) and then Flat_Element_Kind (Enclosing_Element (Node.Spec)) /= A_Protected_Definition; Count : Natural; procedure Output_Fake_Parameters; -- Prints out the fake parameters of the fake recursive call of the -- function to itself function Func_Name_For_Warning (Decl : Asis.Declaration) return String is (if Defining_Name_Kind (First_Name (Decl)) = A_Defining_Operator_Symbol then """" & To_String_First_Name (Decl) & """" else To_String_First_Name (Decl)); procedure Output_Fake_Parameters is begin S_Put (0, " ("); for J in Parameters'Range loop declare Formal_Names : constant Asis.Element_List := Names (Parameters (J)); begin for K in Formal_Names'Range loop S_Put (0, To_String (Defining_Name_Image (Formal_Names (K))) & " => " & To_String (Defining_Name_Image (Formal_Names (K)))); if K /= Formal_Names'Last or else J /= Parameters'Last then S_Put (0, ", "); end if; end loop; end; end loop; S_Put (0, ");"); end Output_Fake_Parameters; Has_Limited_Params : Boolean := False; Has_Limited_View_Params : Boolean := False; Has_Private_Params : Boolean := False; begin Trace (Me, "Generating function body for " & Node.Spec_Name.all); Increase_Indent (Me); -- Node.Spec_Name cannot be referenced here since it will be translated -- for operators. S_Put (0, GT_Marker_Begin); New_Line_Count; Add_Entity_To_Local_List (Node, New_Line_Counter, Level * Indent_Level); if Is_Overriding_Declaration (Node.Spec) then S_Put (Level * Indent_Level, "overriding"); New_Line_Count; elsif Is_Not_Overriding_Declaration (Node.Spec) then S_Put (Level * Indent_Level, "not overriding"); New_Line_Count; end if; S_Put (Level * Indent_Level, "function " & To_String (Defining_Name_Image (First_Name (Node.Spec)))); if Is_Nil (Parameters) then S_Put (0, " return " & To_String (ASIS_Trim (Element_Image (Res_Profile))) & " is"); New_Line_Count; else New_Line_Count; S_Put (Level * Indent_Level + 2, "("); for I in Parameters'Range loop if I = Parameters'First then S_Put (0, To_String (ASIS_Trim (Element_Image (Parameters (I))))); else S_Put ((Level + 1) * Indent_Level, To_String (ASIS_Trim (Element_Image (Parameters (I))))); end if; if I = Parameters'Last then S_Put (0, ") return " & To_String (ASIS_Trim (Element_Image (Res_Profile))) & " is"); else S_Put (0, ";"); end if; New_Line_Count; end loop; end if; S_Put ((Level + 1) * Indent_Level, Generate_MD_Id_String (Node.Spec)); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "--"); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "-- This section can be used to change the function body."); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "--"); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; -- Put body if Markered_Data.Contains (ID) then -- Extract importing MD MD := Markered_Data.Element (ID); Put_Lines (MD, Comment_Out => False); Markered_Data.Delete (ID); else New_Line_Count; S_Put ((Level) * Indent_Level, "begin"); New_Line_Count; if Not_Empty_Stub then S_Put (6, Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & Stub_Counter_Var & " := " & Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & Stub_Counter_Var & " + 1;"); New_Line_Count; Count := 1; Cur := Param_List.First; -- Last one is the result of the function. Need to process it -- separately afterwards. while Cur /= Param_List.Last loop SP := Stubbed_Parameter_Lists.Element (Cur); if Is_Only_Limited_Withed (SP.Type_Elem) then Has_Limited_View_Params := True; elsif Is_Limited (SP.Type_Elem) then Has_Limited_Params := True; elsif Is_Fully_Private (SP.Type_Elem) then Has_Private_Params := True; else case SP.Kind is when Constrained => S_Put ((Level + 1) * Indent_Level, SP.Name.all & " := " & Stub_Data_Unit_Name & "." & Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & SP.Name.all & ";"); when Not_Constrained => S_Put ((Level + 1) * Indent_Level, SP.Name.all & " := " & Stub_Data_Unit_Name & "." & Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & SP.Name.all & ".all;"); when Access_Kind => S_Put ((Level + 1) * Indent_Level, SP.Name.all & ".all := " & Stub_Data_Unit_Name & "." & Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & SP.Name.all & ".all;"); end case; New_Line_Count; end if; Count := Count + 1; Next (Cur); end loop; -- processing result profile SP := Param_List.Last_Element; if Is_Only_Limited_Withed (SP.Type_Elem) or else Is_Abstract (SP.Type_Elem) or else Is_Limited (SP.Type_Elem) or else Is_Fully_Private (SP.Type_Elem) then S_Put ((Level + 1) * Indent_Level, "pragma Compile_Time_Warning"); New_Line_Count; S_Put ((Level + 1) * Indent_Level + 2, "(Standard.True,"); New_Line_Count; S_Put ((Level + 2) * Indent_Level, """Stub for " & Func_Name_For_Warning (Node.Spec) & " is unimplemented,"""); New_Line_Count; S_Put ((Level + 2) * Indent_Level, "& "" this might affect some tests"");"); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "raise Program_Error with ""Unimplemented stub for function " & Node.Spec_Name.all & """;"); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "return " & To_String (Defining_Name_Image (First_Name (Node.Spec)))); if Is_Nil (Parameters) then S_Put (0, ";"); else Output_Fake_Parameters; end if; else case SP.Kind is when Constrained | Access_Kind => S_Put ((Level + 1) * Indent_Level, "return " & Stub_Data_Unit_Name & "." & Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & SP.Name.all & ";"); when Not_Constrained => S_Put ((Level + 1) * Indent_Level, "return " & Stub_Data_Unit_Name & "." & Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & SP.Name.all & ".all;"); end case; end if; New_Line_Count; else S_Put ((Level + 1) * Indent_Level, "pragma Compile_Time_Warning"); New_Line_Count; S_Put ((Level + 1) * Indent_Level + 2, "(Standard.True,"); New_Line_Count; S_Put ((Level + 2) * Indent_Level, """Stub for " & Func_Name_For_Warning (Node.Spec) & " is unimplemented,"""); New_Line_Count; S_Put ((Level + 2) * Indent_Level, "& "" this might affect some tests"");"); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "raise Program_Error with ""Unimplemented stub for function " & Node.Spec_Name.all & """;"); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "return " & To_String (Defining_Name_Image (First_Name (Node.Spec)))); if Is_Nil (Parameters) then S_Put (0, ";"); else Output_Fake_Parameters; end if; New_Line_Count; end if; end if; S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put ((Level) * Indent_Level, "end " & To_String (Defining_Name_Image (First_Name (Node.Spec))) & ";"); New_Line_Count; New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; if Has_Limited_Params then Report_Std ("warning: (gnattest) " & Base_Name (To_String (Text_Name (Enclosing_Compilation_Unit (Node.Spec)))) & ":" & Trim (Integer'Image (First_Line_Number (Node.Spec)), Both) & ":" & Trim (Integer'Image (First_Column_Number (Node.Spec)), Both) & ": " & To_String (Defining_Name_Image (First_Name (Node.Spec))) & " has limited type parameter, generated setter is incomplete"); end if; if Has_Limited_View_Params then Report_Std ("warning: (gnattest) " & Base_Name (To_String (Text_Name (Enclosing_Compilation_Unit (Node.Spec)))) & ":" & Trim (Integer'Image (First_Line_Number (Node.Spec)), Both) & ":" & Trim (Integer'Image (First_Column_Number (Node.Spec)), Both) & ": " & Node.Spec_Name.all & " type of a parameter of this subprogram has limited view only, " & "generated setter is incomplete"); end if; if Has_Private_Params then Report_Std ("warning: (gnattest) " & Base_Name (To_String (Text_Name (Enclosing_Compilation_Unit (Node.Spec)))) & ":" & Trim (Integer'Image (First_Line_Number (Node.Spec)), Both) & ":" & Trim (Integer'Image (First_Column_Number (Node.Spec)), Both) & ": " & Node.Spec_Name.all & " has private type parameter, generated setter is incomplete"); end if; Decrease_Indent (Me); end Generate_Function_Body; --------------------------- -- Generate_MD_Id_String -- --------------------------- function Generate_MD_Id_String (Element : Asis.Element; Commented_Out : Boolean := False) return String is Id : constant Markered_Data_Id := Generate_MD_Id (Element); begin return Generate_MD_Id_String (Id, Commented_Out); end Generate_MD_Id_String; --------------------------- -- Generate_MD_Id_String -- --------------------------- function Generate_MD_Id_String (Id : Markered_Data_Id; Commented_Out : Boolean := False) return String is Res : constant String := "-- id:" & Hash_Version & "/" & MD_Kind_To_String (Id.Kind) & "/" & Id.Self_Hash.all & "/" & Id.Nesting_Hash.all & "/" & (if Commented_Out then "1" else "0") & "/" & Id.Name.all & "/"; begin return Res; end Generate_MD_Id_String; -------------------- -- Generate_MD_Id -- -------------------- function Generate_MD_Id (Element : Asis.Element) return Markered_Data_Id is Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Element); Id : Markered_Data_Id; begin Id.Hash_Version := new String'(Hash_Version); case Arg_Kind is when An_Incomplete_Type_Declaration | A_Tagged_Incomplete_Type_Declaration => Id.Kind := Type_MD; Id.Self_Hash := new String' (Substring_16 (GNAT.SHA1.Digest (To_String_First_Name (Element)))); when A_Task_Type_Declaration | A_Single_Task_Declaration => Id.Kind := Task_MD; Id.Self_Hash := new String' (Substring_16 (GNAT.SHA1.Digest (To_String_First_Name (Element)))); when A_Package_Declaration | A_Generic_Package_Declaration => Id.Kind := Package_MD; Id.Self_Hash := new String' (Substring_16 (GNAT.SHA1.Digest (To_String_First_Name (Element)))); when A_Generic_Procedure_Declaration | A_Generic_Function_Declaration | A_Procedure_Declaration | A_Function_Declaration => Id.Kind := Subprogram_MD; if Arg_Kind in A_Generic_Function_Declaration | A_Generic_Procedure_Declaration then Id.Self_Hash := new String' (Substring_16 (GNAT.SHA1.Digest (To_String_First_Name (Element)))); else Id.Self_Hash := new String' (Substring_16 (Mangle_Hash_Full (Element, For_Stubs => True))); end if; when An_Entry_Declaration => Id.Kind := Entry_MD; Id.Self_Hash := new String' (Substring_16 (GNAT.SHA1.Digest (To_String_First_Name (Element)))); when others => null; end case; Id.Nesting_Hash := new String' (Substring_16 (GNAT.SHA1.Digest (Get_Nesting (Element)))); Id.Name := new String' (To_String (Defining_Name_Image (First_Name (Element)))); return Id; end Generate_MD_Id; --------------------------- -- Generate_Package_Body -- --------------------------- procedure Generate_Package_Body (Node : Element_Node; Cursor : Element_Node_Trees.Cursor) is Cur : constant Element_Node_Trees.Cursor := Cursor; ID : Markered_Data_Id := Generate_MD_Id (Node.Spec); MD : Markered_Data_Type; begin if Is_Leaf (Cur) and then not Is_Root (Parent (Cur)) then -- nothing to worry about return; end if; Trace (Me, "Generating package body for " & Node.Spec_Name.all); -- Put local declaration section S_Put (0, GT_Marker_Begin); New_Line_Count; Add_Entity_To_Local_List (Node, New_Line_Counter, Level * Indent_Level); S_Put (Level * Indent_Level, "package body " & Node.Spec_Name.all); New_Line_Count; Level := Level + 1; S_Put ((Level) * Indent_Level, Generate_MD_Id_String (Node.Spec)); New_Line_Count; S_Put ((Level) * Indent_Level, "--"); New_Line_Count; S_Put ((Level) * Indent_Level, "-- This section can be used for local declarations."); New_Line_Count; S_Put ((Level) * Indent_Level, "--"); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; -- Put bodies if Markered_Data.Contains (ID) then -- Extract importing MD MD := Markered_Data.Element (ID); Put_Lines (MD, Comment_Out => False); Markered_Data.Delete (ID); else New_Line_Count; S_Put ((Level - 1) * Indent_Level, "is"); New_Line_Count; end if; S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; if not Is_Leaf (Cur) then Process_Siblings (First_Child (Cur)); end if; -- Put possible Elab sections S_Put (0, GT_Marker_Begin); New_Line_Count; ID.Kind := Elaboration_MD; S_Put ((Level) * Indent_Level, Generate_MD_Id_String (ID)); New_Line_Count; S_Put ((Level) * Indent_Level, "--"); New_Line_Count; S_Put (Level * Indent_Level, "-- This section can be used for elaboration statements."); New_Line_Count; S_Put ((Level) * Indent_Level, "--"); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; if Markered_Data.Contains (ID) then -- Extract importing MD MD := Markered_Data.Element (ID); Put_Lines (MD, Comment_Out => False); Markered_Data.Delete (ID); else New_Line_Count; end if; -- Put end package Level := Level - 1; S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put (Level * Indent_Level, "end " & Node.Spec_Name.all & ";"); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; -- If we are in the root package, we have to print all the dangling -- elements (if any); if Is_Root (Parent (Cur)) then if not Markered_Data.Is_Empty then Report_Std (" warning: " & Node.Spec_Name.all & " has dangling element(s)"); Put_Dangling_Elements; end if; end if; end Generate_Package_Body; ----------------------------- -- Generate_Procedure_Body -- ----------------------------- procedure Generate_Procedure_Body (Node : Element_Node) is ID : constant Markered_Data_Id := Generate_MD_Id (Node.Spec); MD : Markered_Data_Type; Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Node.Spec); Parameters : constant Asis.Element_List := Parameter_Profile (Node.Spec); Param_List : constant Stubbed_Parameter_Lists.List := Get_Args_List (Node); Cur : Stubbed_Parameter_Lists.Cursor; SP : Stubbed_Parameter; Suffix : constant String := Hash_Suffix (ID); Not_Empty_Stub : constant Boolean := Arg_Kind = A_Procedure_Declaration and then (not Node.Inside_Generic) and then Flat_Element_Kind (Enclosing_Element (Node.Spec)) /= A_Protected_Definition; Has_Limited_Params : Boolean := False; Has_Limited_View_Params : Boolean := False; Has_Private_Params : Boolean := False; begin Trace (Me, "Generating procedure body for " & Node.Spec_Name.all); Increase_Indent (Me); S_Put (0, GT_Marker_Begin); New_Line_Count; Add_Entity_To_Local_List (Node, New_Line_Counter, Level * Indent_Level); if Is_Overriding_Declaration (Node.Spec) then S_Put (Level * Indent_Level, "overriding"); New_Line_Count; elsif Is_Not_Overriding_Declaration (Node.Spec) then S_Put (Level * Indent_Level, "not overriding"); New_Line_Count; end if; S_Put (Level * Indent_Level, "procedure " & Node.Spec_Name.all); if Is_Nil (Parameters) then S_Put (0, " is"); New_Line_Count; else New_Line_Count; S_Put (Level * Indent_Level + 2, "("); for I in Parameters'Range loop if I = Parameters'First then S_Put (0, To_String (ASIS_Trim (Element_Image (Parameters (I))))); else S_Put ((Level + 1) * Indent_Level, To_String (ASIS_Trim (Element_Image (Parameters (I))))); end if; if I = Parameters'Last then S_Put (0, ") is"); else S_Put (0, ";"); end if; New_Line_Count; end loop; end if; S_Put ((Level + 1) * Indent_Level, Generate_MD_Id_String (Node.Spec)); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "--"); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "-- This section can be used to change the procedure body."); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "--"); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; -- Put body if Markered_Data.Contains (ID) then -- Extract importing MD MD := Markered_Data.Element (ID); Put_Lines (MD, Comment_Out => False); Markered_Data.Delete (ID); else New_Line_Count; S_Put ((Level) * Indent_Level, "begin"); New_Line_Count; if Not_Empty_Stub then New_Line_Count; S_Put (6, Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & Stub_Counter_Var & " := " & Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & Stub_Counter_Var & " + 1;"); New_Line_Count; if not Param_List.Is_Empty then Cur := Param_List.First; while Cur /= Stubbed_Parameter_Lists.No_Element loop SP := Stubbed_Parameter_Lists.Element (Cur); if Is_Only_Limited_Withed (SP.Type_Elem) then Has_Limited_View_Params := True; elsif Is_Limited (SP.Type_Elem) then Has_Limited_Params := True; elsif Is_Fully_Private (SP.Type_Elem) then Has_Private_Params := True; else case SP.Kind is when Constrained => S_Put ((Level + 1) * Indent_Level, SP.Name.all & " := " & Stub_Data_Unit_Name & "." & Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & SP.Name.all & ";"); when Not_Constrained => S_Put ((Level + 1) * Indent_Level, SP.Name.all & " := " & Stub_Data_Unit_Name & "." & Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & SP.Name.all & ".all;"); when Access_Kind => S_Put ((Level + 1) * Indent_Level, SP.Name.all & ".all := " & Stub_Data_Unit_Name & "." & Stub_Object_Prefix & Node.Spec_Name.all & Suffix & "." & SP.Name.all & ".all;"); end case; New_Line_Count; end if; Next (Cur); end loop; end if; else S_Put ((Level + 1) * Indent_Level, "pragma Compile_Time_Warning"); New_Line_Count; S_Put ((Level + 1) * Indent_Level + 2, "(Standard.True,"); New_Line_Count; S_Put ((Level + 2) * Indent_Level, """Stub for " & Node.Spec_Name.all & " is unimplemented,"""); New_Line_Count; S_Put ((Level + 2) * Indent_Level, "& "" this might affect some tests"");"); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "null;"); New_Line_Count; end if; end if; S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put ((Level) * Indent_Level, "end " & Node.Spec_Name.all & ";"); New_Line_Count; New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; if Has_Limited_Params then Report_Std ("warning: (gnattest) " & Base_Name (To_String (Text_Name (Enclosing_Compilation_Unit (Node.Spec)))) & ":" & Trim (Integer'Image (First_Line_Number (Node.Spec)), Both) & ":" & Trim (Integer'Image (First_Column_Number (Node.Spec)), Both) & ": " & Node.Spec_Name.all & " has limited type parameter, generated setter is incomplete"); end if; if Has_Limited_View_Params then Report_Std ("warning: (gnattest) " & Base_Name (To_String (Text_Name (Enclosing_Compilation_Unit (Node.Spec)))) & ":" & Trim (Integer'Image (First_Line_Number (Node.Spec)), Both) & ":" & Trim (Integer'Image (First_Column_Number (Node.Spec)), Both) & ": " & Node.Spec_Name.all & " has parameter of a limited view type, " & "generated setter is incomplete"); end if; if Has_Private_Params then Report_Std ("warning: (gnattest) " & Base_Name (To_String (Text_Name (Enclosing_Compilation_Unit (Node.Spec)))) & ":" & Trim (Integer'Image (First_Line_Number (Node.Spec)), Both) & ":" & Trim (Integer'Image (First_Column_Number (Node.Spec)), Both) & ": " & Node.Spec_Name.all & " has private type parameter, generated setter is incomplete"); end if; Decrease_Indent (Me); end Generate_Procedure_Body; ----------------------------- -- Generate_Protected_Body -- ----------------------------- procedure Generate_Protected_Body (Node : Element_Node; Cursor : Element_Node_Trees.Cursor) is Cur : constant Element_Node_Trees.Cursor := Cursor; begin Trace (Me, "Generating protected body for " & Node.Spec_Name.all); S_Put (0, GT_Marker_Begin); New_Line_Count; Add_Entity_To_Local_List (Node, New_Line_Counter, Level * Indent_Level); S_Put (Level * Indent_Level, "protected body " & Node.Spec_Name.all & " is"); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; Level := Level + 1; if not Is_Leaf (Cur) then Process_Siblings (First_Child (Cur)); end if; Level := Level - 1; S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put (Level * Indent_Level, "end " & Node.Spec_Name.all & ";"); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; end Generate_Protected_Body; ------------------------ -- Generate_Stub_Data -- ------------------------ procedure Generate_Stub_Data (Stub_Data_File_Spec : String; Stub_Data_File_Body : String; Data : Data_Holder) is Node : Element_Node; Root_Node : constant Element_Node := Element_Node_Trees.Element (First_Child (Data.Elem_Tree.Root)); Tmp_File_Name : constant String := "gnattest_tmp_stub_body"; Success : Boolean; Cur : Element_Node_Lists.Cursor; MD_Cur : Markered_Data_Maps.Cursor; ID : Markered_Data_Id; MD : Markered_Data_Type; D_Cur : Access_Dictionaries.Cursor; begin if Data.Flat_List.Is_Empty then Excluded_Test_Data_Files.Include (Base_Name (Stub_Data_File_Spec)); Excluded_Test_Data_Files.Include (Base_Name (Stub_Data_File_Body)); return; end if; -- Spec Gather_Markered_Data (Stub_Data_File_Spec, Markered_Subp_Data); Trace (Me, "generating stub data spec for " & Root_Node.Spec_Name.all & "." & Stub_Data_Unit_Name); Increase_Indent (Me); Create (Tmp_File_Name); Reset_Line_Counter; Put_Import_Section (Markered_Subp_Data); S_Put (0, "package " & Root_Node.Spec_Name.all & "." & Stub_Data_Unit_Name & " is"); New_Line_Count; D_Cur := Dictionary.First; while D_Cur /= Access_Dictionaries.No_Element loop S_Put (3, Access_Dictionaries.Element (D_Cur).Entry_Str.all); New_Line_Count; Next (D_Cur); end loop; New_Line_Count; Cur := Data.Flat_List.First; while Cur /= Element_Node_Lists.No_Element loop Node := Element_Node_Lists.Element (Cur); S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put (3, Generate_MD_Id_String (Node.Spec)); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; ID := Generate_MD_Id (Node.Spec); if Markered_Subp_Data.Contains (ID) then MD := Markered_Subp_Data.Element (ID); Put_Lines (MD, Comment_Out => False); Markered_Subp_Data.Delete (ID); else Generate_Default_Setter_Spec (Node); end if; S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; Next (Cur); end loop; if not Markered_Subp_Data.Is_Empty then Report_Std (" warning: " & Root_Node.Spec_Name.all & "." & Stub_Data_Unit_Name & " has dangling setter spec(s)"); S_Put (3, "----------------------"); New_Line_Count; S_Put (3, "-- Unused Setters --"); New_Line_Count; S_Put (3, "----------------------"); New_Line_Count; New_Line_Count; MD_Cur := Markered_Subp_Data.First; while MD_Cur /= Markered_Data_Maps.No_Element loop ID := Markered_Data_Maps.Key (MD_Cur); MD := Markered_Data_Maps.Element (MD_Cur); S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put (3, Generate_MD_Id_String (ID)); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; Put_Lines (MD, Comment_Out => False); S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; Next (MD_Cur); end loop; end if; S_Put (0, "end " & Root_Node.Spec_Name.all & "." & Stub_Data_Unit_Name & ";"); New_Line_Count; Close_File; Markered_Subp_Data.Clear; -- At this point temp package is coplete and it is safe -- to replace the old one with it. if Is_Regular_File (Stub_Data_File_Spec) then Delete_File (Stub_Data_File_Spec, Success); if not Success then Report_Err ("cannot delete " & Stub_Data_File_Spec); raise Fatal_Error; end if; end if; Copy_File (Tmp_File_Name, Stub_Data_File_Spec, Success); if not Success then Report_Err ("cannot copy tmp test package to " & Stub_Data_File_Spec); raise Fatal_Error; end if; Delete_File (Tmp_File_Name, Success); if not Success then Report_Err ("cannot delete tmp test package"); raise Fatal_Error; end if; Decrease_Indent (Me); -- Body Gather_Markered_Data (Stub_Data_File_Body, Markered_Subp_Data); Trace (Me, "generating stub data body for " & Root_Node.Spec_Name.all & "." & Stub_Data_Unit_Name); Increase_Indent (Me); Create (Tmp_File_Name); Reset_Line_Counter; Put_Import_Section (Markered_Subp_Data); S_Put (0, "package body " & Root_Node.Spec_Name.all & "." & Stub_Data_Unit_Name & " is"); New_Line_Count; Cur := Data.Flat_List.First; while Cur /= Element_Node_Lists.No_Element loop Node := Element_Node_Lists.Element (Cur); S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put (3, Generate_MD_Id_String (Node.Spec)); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; Update_Local_Entity_With_Setter (Node, New_Line_Counter, 4); ID := Generate_MD_Id (Node.Spec); if Markered_Subp_Data.Contains (ID) then MD := Markered_Subp_Data.Element (ID); Put_Lines (MD, Comment_Out => False); Markered_Subp_Data.Delete (ID); else Generate_Default_Setter_Body (Node); end if; S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; Next (Cur); end loop; if not Markered_Subp_Data.Is_Empty then Report_Std (" warning: " & Root_Node.Spec_Name.all & "." & Stub_Data_Unit_Name & " has dangling setter body(ies)"); S_Put (3, "----------------------"); New_Line_Count; S_Put (3, "-- Unused Setters --"); New_Line_Count; S_Put (3, "----------------------"); New_Line_Count; New_Line_Count; MD_Cur := Markered_Subp_Data.First; while MD_Cur /= Markered_Data_Maps.No_Element loop ID := Markered_Data_Maps.Key (MD_Cur); MD := Markered_Data_Maps.Element (MD_Cur); S_Put (0, GT_Marker_Begin); New_Line_Count; Local_Stub_Unit_Mapping.D_Setters.Append ((New_Line_Counter, 0)); S_Put (3, Generate_MD_Id_String (ID)); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; Put_Lines (MD, Comment_Out => False); S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; Next (MD_Cur); end loop; end if; S_Put (0, "end " & Root_Node.Spec_Name.all & "." & Stub_Data_Unit_Name & ";"); New_Line_Count; Close_File; Markered_Subp_Data.Clear; -- At this point temp package is coplete and it is safe -- to replace the old one with it. if Is_Regular_File (Stub_Data_File_Body) then Delete_File (Stub_Data_File_Body, Success); if not Success then Report_Err ("cannot delete " & Stub_Data_File_Body); raise Fatal_Error; end if; end if; Copy_File (Tmp_File_Name, Stub_Data_File_Body, Success); if not Success then Report_Err ("cannot copy tmp test package to " & Stub_Data_File_Body); raise Fatal_Error; end if; Delete_File (Tmp_File_Name, Success); if not Success then Report_Err ("cannot delete tmp test package"); raise Fatal_Error; end if; Decrease_Indent (Me); end Generate_Stub_Data; ------------------------ -- Generate_Task_Body -- ------------------------ procedure Generate_Task_Body (Node : Element_Node) is ID : constant Markered_Data_Id := Generate_MD_Id (Node.Spec); MD : Markered_Data_Type; begin Trace (Me, "Generating task body for " & Node.Spec_Name.all); S_Put (0, GT_Marker_Begin); New_Line_Count; Add_Entity_To_Local_List (Node, New_Line_Counter, Level * Indent_Level); S_Put (Level * Indent_Level, "task body " & Node.Spec_Name.all & " is"); New_Line_Count; S_Put ((Level + 1) * Indent_Level, Generate_MD_Id_String (Node.Spec)); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "--"); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "-- This section can be used to change task body."); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "--"); New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; -- Put body if Markered_Data.Contains (ID) then -- Extract importing MD MD := Markered_Data.Element (ID); Put_Lines (MD, Comment_Out => False); Markered_Data.Delete (ID); else New_Line_Count; S_Put ((Level) * Indent_Level, "begin"); New_Line_Count; S_Put ((Level + 1) * Indent_Level, "delay until Ada.Real_Time.Time_Last;"); New_Line_Count; end if; S_Put (0, GT_Marker_Begin); New_Line_Count; S_Put ((Level) * Indent_Level, "end " & Node.Spec_Name.all & ";"); New_Line_Count; New_Line_Count; S_Put (0, GT_Marker_End); New_Line_Count; New_Line_Count; end Generate_Task_Body; -------------------------- -- Get_Access_Type_Name -- -------------------------- function Get_Access_Type_Name (Elem : Asis.Element) return String is Attr_Suff : constant String := (if Expression_Kind (Elem) = An_Attribute_Reference then "_" & To_String (ASIS_Trim (Element_Image (Attribute_Designator_Identifier (Elem)))) else ""); Decl : constant Asis.Declaration := Get_Declaration (Elem); S : String_Access; begin if Get_Nesting (Decl) = "Standard" then S := new String' (To_String_First_Name (Decl) & Attr_Suff); else S := new String' (Get_Nesting (Decl) & "." & To_String_First_Name (Decl) & Attr_Suff); end if; for I in S'Range loop if S (I) = '.' then S (I) := '_'; end if; end loop; return S.all & "_Access"; end Get_Access_Type_Name; ------------------- -- Get_Args_List -- ------------------- function Get_Args_List (Node : Element_Node) return Stubbed_Parameter_Lists.List is Result : Stubbed_Parameter_Lists.List := Stubbed_Parameter_Lists.Empty_List; Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Node.Spec); Parameters : constant Asis.Element_List := Parameter_Profile (Node.Spec); SP : Stubbed_Parameter; function Can_Declare_Variable (Param_Type : Asis.Element) return Boolean; function Can_Declare_Variable (Param_Type : Asis.Element) return Boolean is begin if not Is_Definite_Subtype (Corresponding_Name_Declaration (Normalize_Reference (Param_Type))) then return False; end if; if Expression_Kind (Param_Type) = An_Attribute_Reference and then Attribute_Kind (Param_Type) = A_Class_Attribute then return False; end if; return True; end Can_Declare_Variable; begin Trace (Me, "Getting argument list for " & Node.Spec_Name.all); Increase_Indent (Me); if not Is_Nil (Parameters) then for J in Parameters'Range loop declare Parameter : constant Asis.Parameter_Specification := Parameters (J); Name_List : constant Defining_Name_List := Names (Parameter); Param_Type : constant Asis.Element := Object_Declaration_View (Parameter); begin for I in Name_List'Range loop if Is_Only_Limited_Withed (Param_Type) or else not Is_Abstract (Param_Type) then if Definition_Kind (Param_Type) = An_Access_Definition and then Access_Definition_Kind (Param_Type) = An_Anonymous_Access_To_Variable then SP.Name := new String' (To_String (Defining_Name_Image (Name_List (I)))); SP.Type_Image := new String' (To_String (ASIS_Trim (Element_Image (Param_Type)))); SP.Type_Full_Name_Image := new String' (Get_Type_Image (Param_Type)); SP.Kind := Access_Kind; SP.Type_Elem := Param_Type; Result.Append (SP); else if Mode_Kind (Parameter) in An_Out_Mode | An_In_Out_Mode then SP.Type_Elem := Param_Type; if Can_Declare_Variable (Param_Type) then SP.Name := new String' (To_String (Defining_Name_Image (Name_List (I)))); SP.Type_Image := new String' (To_String (ASIS_Trim (Element_Image (Param_Type)))); SP.Type_Full_Name_Image := new String' (Get_Type_Image (Param_Type)); SP.Kind := Constrained; else SP.Name := new String' (To_String (Defining_Name_Image (Name_List (I)))); SP.Type_Image := new String' (Get_Access_Type_Name (Param_Type)); SP.Type_Full_Name_Image := new String' (Get_Access_Type_Name (Param_Type)); SP.Kind := Not_Constrained; if not Is_Fully_Private (Param_Type) then Add_Unconstrained_Type_To_Dictionary (Param_Type); end if; end if; Result.Append (SP); end if; end if; end if; end loop; end; end loop; end if; if Arg_Kind = A_Function_Declaration then declare Res_Profile : constant Asis.Element := Result_Profile (Node.Spec); begin if Definition_Kind (Res_Profile) = An_Access_Definition then SP.Name := new String' (Node.Spec_Name.all & Stub_Result_Suffix); SP.Type_Image := new String' (To_String (ASIS_Trim (Element_Image (Res_Profile)))); SP.Type_Full_Name_Image := new String' (Get_Type_Image (Res_Profile)); SP.Kind := Access_Kind; SP.Type_Elem := Res_Profile; Result.Append (SP); else if Can_Declare_Variable (Res_Profile) then SP.Name := new String' (Node.Spec_Name.all & Stub_Result_Suffix); SP.Type_Image := new String' (To_String (ASIS_Trim (Element_Image (Res_Profile)))); SP.Type_Full_Name_Image := new String' (Get_Type_Image (Res_Profile)); SP.Kind := Constrained; SP.Type_Elem := Res_Profile; Result.Append (SP); else SP.Name := new String' (Node.Spec_Name.all & Stub_Result_Suffix); SP.Type_Image := new String' (Get_Access_Type_Name (Res_Profile)); SP.Type_Full_Name_Image := new String' (Get_Access_Type_Name (Res_Profile)); SP.Kind := Not_Constrained; SP.Type_Elem := Res_Profile; if not Is_Fully_Private (Res_Profile) then Add_Unconstrained_Type_To_Dictionary (Res_Profile); end if; Result.Append (SP); end if; end if; end; end if; Decrease_Indent (Me); return Result; end Get_Args_List; -------------------- -- Get_Type_Image -- -------------------- function Get_Type_Image (Param_Type : Asis.Element) return String is Elem : Asis.Element := Param_Type; Overall_Image : constant String := To_String (ASIS_Trim (Element_Image (Param_Type))); Replacement, Head, Tail : String_Access; Decl : Asis.Element; Overall_Span, Subspan, Tmp_Span : Span; function Span_Image (El : Asis.Element; Sp : Span) return String; function Span_Image (El : Asis.Element; Sp : Span) return String is Tmp, Res : String_Access; Lines_List : constant Line_List := Lines (El, Sp); begin Res := new String'(""); for I in Lines_List'Range loop Tmp := new String' (Res.all & To_String (Non_Comment_Image (Lines_List (I)))); Free (Res); Res := Tmp; end loop; return Res.all; end Span_Image; begin if Definition_Kind (Param_Type) = An_Access_Definition then if Access_Definition_Kind (Param_Type) in An_Anonymous_Access_To_Variable | An_Anonymous_Access_To_Constant then Elem := Anonymous_Access_To_Object_Subtype_Mark (Elem); else return Overall_Image; end if; end if; while Expression_Kind (Elem) = An_Attribute_Reference loop Elem := Prefix (Elem); end loop; Subspan := Element_Span (Elem); Decl := Corresponding_Name_Declaration (Normalize_Reference (Elem)); if To_Lower (Get_Nesting (Decl)) = "standard" then return Overall_Image; end if; -- No point in replacing non-nested types. Those are already visible. if Is_Nil (Enclosing_Element (Enclosing_Element (Decl))) then return Overall_Image; end if; Replacement := new String' (Get_Nesting (Decl) & "." & To_String_First_Name (Decl)); Overall_Span := Element_Span (Param_Type); if Overall_Span.First_Line = Subspan.First_Line and then Overall_Span.First_Column = Subspan.First_Column then Head := new String'(""); else Tmp_Span.First_Line := Overall_Span.First_Line; Tmp_Span.First_Column := Overall_Span.First_Column; Tmp_Span.Last_Line := Subspan.First_Line; Tmp_Span.Last_Column := Subspan.First_Column - 1; Head := new String' (Trim (Span_Image (Param_Type, Tmp_Span), Left)); end if; if Overall_Span.Last_Line = Subspan.Last_Line and then Overall_Span.Last_Column = Subspan.Last_Column then Tail := new String'(""); else Tmp_Span.First_Line := Subspan.Last_Line; Tmp_Span.First_Column := Subspan.Last_Column + 1; Tmp_Span.Last_Line := Overall_Span.Last_Line; Tmp_Span.Last_Column := Overall_Span.Last_Column; Tail := new String' (Trim (Span_Image (Param_Type, Tmp_Span), Left)); end if; return Head.all & Replacement.all & Tail.all; end Get_Type_Image; --------------------- -- Get_Declaration -- --------------------- function Get_Declaration (Elem : Asis.Element) return Asis.Declaration is begin return Corresponding_Name_Declaration (Normalize_Reference (if Expression_Kind (Elem) = An_Attribute_Reference then Prefix (Elem) else Elem)); end Get_Declaration; ----------------- -- Hash_Suffix -- ----------------- function Hash_Suffix (ID : Markered_Data_Id) return String is Self_First : constant Integer := ID.Self_Hash.all'First; Self_Last : constant Integer := ID.Self_Hash.all'First + 5; Nesting_First : constant Integer := ID.Nesting_Hash.all'First; Nesting_Last : constant Integer := ID.Nesting_Hash.all'First + 5; begin return "_" & ID.Self_Hash.all (Self_First .. Self_Last) & "_" & ID.Nesting_Hash.all (Nesting_First .. Nesting_Last); end Hash_Suffix; ----------------- -- Is_Abstract -- ----------------- function Is_Abstract (Param_Type : Asis.Element) return Boolean is Decl, Def : Asis.Element; Elem : Asis.Element := Param_Type; begin if Verbose then Trace (Me, "Is_Abstract called for"); Trace (Me, To_String (Debug_Image (Elem))); end if; if Definition_Kind (Param_Type) = An_Access_Definition then if Access_Definition_Kind (Param_Type) in An_Anonymous_Access_To_Variable | An_Anonymous_Access_To_Constant then Elem := Anonymous_Access_To_Object_Subtype_Mark (Elem); else -- Anonymous access to subprogram cannot be abstract anyway. return False; end if; end if; if Expression_Kind (Elem) = An_Attribute_Reference then Elem := Prefix (Elem); end if; Decl := Corresponding_Name_Declaration (Normalize_Reference (Elem)); if Declaration_Kind (Decl) = A_Subtype_Declaration then Decl := Corresponding_First_Subtype (Decl); end if; if Is_From_Limited_View (Decl) then Decl := Get_Nonlimited_View (Decl); end if; if Declaration_Kind (Decl) = A_Formal_Type_Declaration or else Declaration_Kind (Decl) = A_Formal_Incomplete_Type_Declaration then return False; end if; if Flat_Element_Kind (Decl) = A_Tagged_Incomplete_Type_Declaration or else Flat_Element_Kind (Decl) = An_Incomplete_Type_Declaration then Decl := Corresponding_Type_Completion (Decl); end if; Def := Type_Declaration_View (Decl); if Type_Kind (Def) = An_Interface_Type_Definition then return True; end if; if Trait_Kind (Type_Declaration_View (Decl)) in An_Abstract_Trait | An_Abstract_Private_Trait | An_Abstract_Limited_Trait | An_Abstract_Limited_Private_Trait then return True; end if; Decl := Corresponding_Type_Partial_View (Decl); if Flat_Element_Kind (Decl) = A_Tagged_Incomplete_Type_Declaration or else Flat_Element_Kind (Decl) = An_Incomplete_Type_Declaration then return False; end if; if not Is_Nil (Decl) then if Trait_Kind (Type_Declaration_View (Decl)) in An_Abstract_Trait | An_Abstract_Private_Trait | An_Abstract_Limited_Trait | An_Abstract_Limited_Private_Trait then return True; end if; end if; return False; end Is_Abstract; ---------------------- -- Is_Fully_Private -- ---------------------- function Is_Fully_Private (Param_Type : Asis.Element) return Boolean is Decl : Asis.Element; Elem : Asis.Element := Param_Type; begin if Verbose then Trace (Me, "Is_Fully_Private called for"); Trace (Me, To_String (Debug_Image (Elem))); end if; if Definition_Kind (Param_Type) = An_Access_Definition then if Access_Definition_Kind (Param_Type) in An_Anonymous_Access_To_Variable | An_Anonymous_Access_To_Constant then Elem := Anonymous_Access_To_Object_Subtype_Mark (Elem); else -- Anonymous access to subprogram cannot be private anyway. return False; end if; end if; if Expression_Kind (Elem) = An_Attribute_Reference then Elem := Prefix (Elem); end if; Decl := Corresponding_Name_Declaration (Normalize_Reference (Elem)); if Declaration_Kind (Decl) = A_Subtype_Declaration then Decl := Corresponding_First_Subtype (Decl); end if; if Is_From_Limited_View (Decl) then Decl := Get_Nonlimited_View (Decl); end if; if Declaration_Kind (Decl) = A_Formal_Type_Declaration or else Declaration_Kind (Decl) = A_Formal_Incomplete_Type_Declaration then return False; end if; if not Is_Private (Decl) then return False; end if; if Flat_Element_Kind (Decl) = A_Tagged_Incomplete_Type_Declaration or else Flat_Element_Kind (Decl) = An_Incomplete_Type_Declaration then Decl := Corresponding_Type_Completion (Decl); end if; if not Is_Private (Decl) then return False; end if; Decl := Corresponding_Type_Partial_View (Decl); if not Is_Nil (Decl) then if not Is_Private (Decl) then return False; end if; end if; return True; end Is_Fully_Private; ---------------- -- Is_Limited -- ---------------- function Is_Limited (Param_Type : Asis.Element) return Boolean is Decl, Decl2 : Asis.Element; Elem : Asis.Element := Param_Type; begin if Verbose then Trace (Me, "Is_Limited called for"); Trace (Me, To_String (Debug_Image (Elem))); end if; if Definition_Kind (Elem) = An_Access_Definition then if Access_Definition_Kind (Elem) in An_Anonymous_Access_To_Variable | An_Anonymous_Access_To_Constant then Elem := Anonymous_Access_To_Object_Subtype_Mark (Elem); else -- Anonymous access to subprogram cannot be limited anyway. return False; end if; end if; if Expression_Kind (Elem) = An_Attribute_Reference then Elem := Prefix (Elem); end if; Decl := Corresponding_Name_Declaration (Normalize_Reference (Elem)); if Is_From_Limited_View (Decl) then return True; end if; while not Is_Nil (Decl) loop if Declaration_Kind (Decl) = A_Subtype_Declaration then Decl := Corresponding_First_Subtype (Decl); end if; if Has_Limited (Decl) then return True; end if; if Declaration_Kind (Decl) = A_Formal_Type_Declaration or else Declaration_Kind (Decl) = A_Formal_Incomplete_Type_Declaration then -- Not really relevant if we return true or false, since generic -- subprograms do not have setters and stub data structures. return False; end if; Decl2 := Corresponding_Type_Partial_View (Decl); if not Is_Nil (Decl2) then if Has_Limited (Decl2) then return True; end if; end if; Decl := Parent_Type_Declaration (Decl); end loop; return False; end Is_Limited; ---------------------------- -- Is_Only_Limited_Withed -- ---------------------------- function Is_Only_Limited_Withed (Param_Type : Asis.Element) return Boolean is Decl : Asis.Element; Elem : Asis.Element := Param_Type; begin if Verbose then Trace (Me, "Is_Only_Limited_Withed called for"); Trace (Me, To_String (Debug_Image (Elem))); end if; if Definition_Kind (Elem) = An_Access_Definition then if Access_Definition_Kind (Elem) in An_Anonymous_Access_To_Variable | An_Anonymous_Access_To_Constant then Elem := Anonymous_Access_To_Object_Subtype_Mark (Elem); else return False; end if; end if; if Expression_Kind (Elem) = An_Attribute_Reference then Elem := Prefix (Elem); end if; Decl := Corresponding_Name_Declaration (Normalize_Reference (Elem)); if Has_Limited_View_Only (Enclosing_Compilation_Unit (Decl)) then return True; end if; if Declaration_Kind (Decl) = A_Subtype_Declaration then Decl := Corresponding_First_Subtype (Decl); end if; if Has_Limited_View_Only (Enclosing_Compilation_Unit (Decl)) then return True; end if; return False; end Is_Only_Limited_Withed; ------------------------------- -- Filter_Private_Parameters -- ------------------------------- function Filter_Private_Parameters (Param_List : Stubbed_Parameter_Lists.List) return Stubbed_Parameter_Lists.List is SP : Stubbed_Parameter; Cur : Stubbed_Parameter_Lists.Cursor := Param_List.First; Res : Stubbed_Parameter_Lists.List := Stubbed_Parameter_Lists.Empty_List; begin while Cur /= Stubbed_Parameter_Lists.No_Element loop SP := Stubbed_Parameter_Lists.Element (Cur); if not Is_Fully_Private (SP.Type_Elem) then Res.Append (SP); end if; Next (Cur); end loop; return Res; end Filter_Private_Parameters; ------------------------- -- MD_Kind_From_String -- ------------------------- function MD_Kind_From_String (Str : String) return Markered_Data_Kinds is begin if Str = "00" then return Import_MD; end if; if Str = "01" then return Type_MD; end if; if Str = "02" then return Task_MD; end if; if Str = "03" then return Package_MD; end if; if Str = "04" then return Subprogram_MD; end if; if Str = "05" then return Entry_MD; end if; if Str = "06" then return Elaboration_MD; end if; return Unknown_MD; end MD_Kind_From_String; ----------------------- -- MD_Kind_To_String -- ----------------------- function MD_Kind_To_String (MD : Markered_Data_Kinds) return String is begin case MD is when Import_MD => return "00"; when Type_MD => return "01"; when Task_MD => return "02"; when Package_MD => return "03"; when Subprogram_MD => return "04"; when Entry_MD => return "05"; when Elaboration_MD => return "06"; when Unknown_MD => return "99"; end case; end MD_Kind_To_String; ------------------- -- Requires_Body -- ------------------- function Requires_Body (El : Asis.Element) return Boolean is Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (El); Encl_El : Asis.Element; Encl_El_Kind : Flat_Element_Kinds; Result : Boolean := False; begin case Arg_Kind is when An_Incomplete_Type_Declaration | A_Tagged_Incomplete_Type_Declaration => if Is_Nil (Corresponding_Type_Declaration (El)) then Result := True; else Result := not Is_Equal (Enclosing_Compilation_Unit (El), Enclosing_Compilation_Unit (Corresponding_Type_Declaration (El))); end if; when A_Task_Type_Declaration | A_Protected_Type_Declaration | A_Single_Task_Declaration | A_Single_Protected_Declaration | A_Package_Declaration | A_Generic_Procedure_Declaration | A_Generic_Function_Declaration | A_Generic_Package_Declaration => -- there is no harm to generate a local body sample for a local -- package or generic package Result := True; when A_Procedure_Declaration | A_Function_Declaration => -- there are two cases when a subprogram does not require -- completion: when it is already completed by renaming-as-body -- in a package spec or when it is abstract if Trait_Kind (El) /= An_Abstract_Trait then -- Result := Is_Nil (Corresponding_Body (El)); ??? -- ??? the statement below implements the temporary solution -- ??? for subprograms completed by pragmas Import. -- ??? it should be revised when Asis.Extensions.Is_Completed -- ??? gets in a proper shape. if not Is_Nil (Corresponding_Body (El)) then if Is_Equal (Enclosing_Compilation_Unit (El), Enclosing_Compilation_Unit (Corresponding_Body (El))) then return False; end if; end if; declare Pragma_List : constant Asis.Pragma_Element_List := Corresponding_Pragmas (El); begin Result := True; for I in Pragma_List'Range loop if To_Lower (To_String (Pragma_Name_Image (Pragma_List (I)))) in "import" | "interface" | "import_function" then Result := False; exit; end if; end loop; end; end if; when An_Entry_Declaration => Encl_El := Enclosing_Element (El); Encl_El_Kind := Flat_Element_Kind (Encl_El); Result := Encl_El_Kind = A_Protected_Definition; when others => null; end case; return Result; end Requires_Body; ------------------------------------- -- Update_Local_Entity_With_Setter -- ------------------------------------- procedure Update_Local_Entity_With_Setter (Node : Element_Node; New_First_Line, New_First_Column : Natural) is Cur : Entity_Stub_Mapping_List.Cursor; Local_Entity : Entity_Stub_Mapping; begin Trace (Me_Mapping, "adding setter info for " & Node.Spec_Name.all); Increase_Indent (Me_Mapping); Local_Entity.Name := new String'(Node.Spec_Name.all); Local_Entity.Line := First_Line_Number (Node.Spec); Local_Entity.Column := First_Column_Number (Node.Spec); Cur := Local_Stub_Unit_Mapping.Entities.Find (Local_Entity); if Cur = Entity_Stub_Mapping_List.No_Element then Trace (Me_Mapping, "no entity found for setter (" & Local_Entity.Name.all & ":" & Trim (Natural'Image (Local_Entity.Line), Both) & ":" & Trim (Natural'Image (Local_Entity.Column), Both)); return; end if; Local_Entity := Entity_Stub_Mapping_List.Element (Cur); Local_Entity.Setter.Line := New_First_Line; Local_Entity.Setter.Column := New_First_Column; Local_Stub_Unit_Mapping.Entities.Replace_Element (Cur, Local_Entity); Decrease_Indent (Me_Mapping); end Update_Local_Entity_With_Setter; end GNATtest.Stub.Generator;