------------------------------------------------------------------------------ -- -- -- GNATSTUB COMPONENTS -- -- -- -- G N A T S T U B . S A M P L E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 1997-2017, Free Software Foundation, Inc. -- -- -- -- Gnatstub is free software; you can redistribute it and/or modify it -- -- under the terms of the GNU General Public License as published by the -- -- Free Software Foundation; either version 3 or (at your option) any later -- -- version. Gnatstub is distributed in the hope that it will be useful, but -- -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABI- -- -- LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public Li- -- -- cense for more details. You should have received a copy of the GNU -- -- General Public License distributed with GNAT; see file COPYING3. If not, -- -- go to http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- Gnatstub was originally developed by Alexei Kuchumov as a part of -- -- collaboration between Software Engineering Laboratory of the Swiss -- -- Federal Institute of Technology in Lausanne, Switzerland, and the -- -- Scientific Research Computer Center of the Moscow State University, -- -- Russia. This work was supported by a grant from the Swiss National -- -- Science Foundation, no 7SUPJ048247, funding a project "Development of -- -- ASIS for GNAT with industry quality". -- -- -- -- Gnatstub is now maintained by AdaCore (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ pragma Ada_2012; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Wide_Characters.Handling; use Ada.Wide_Characters.Handling; with GNAT.Directory_Operations; with Ada.IO_Exceptions; with Ada.Strings; use Ada.Strings; with Ada.Strings.Wide_Fixed; use Ada.Strings.Wide_Fixed; with Ada.Unchecked_Deallocation; with Ada.Text_IO; with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNATCOLL.Projects; use GNATCOLL.Projects; with GNATCOLL.VFS; use GNATCOLL.VFS; with Asis.Ada_Environments; use Asis.Ada_Environments; with Asis.Compilation_Units; use Asis.Compilation_Units; with Asis.Declarations; use Asis.Declarations; with Asis.Elements; use Asis.Elements; with Asis.Errors; with Asis.Exceptions; use Asis.Exceptions; with Asis.Extensions; use Asis.Extensions; with Asis.Extensions.Flat_Kinds; use Asis.Extensions.Flat_Kinds; with Asis.Implementation; use Asis.Implementation; with Asis.Iterator; use Asis.Iterator; with Asis.Text; use Asis.Text; with Hostparm; with Opt; use all type Opt.Ada_Version_Type; with ASIS_UL.Common; use ASIS_UL.Common; with ASIS_UL.Compiler_Options; use ASIS_UL.Compiler_Options; with ASIS_UL.Debug; use ASIS_UL.Debug; with ASIS_UL.Environment; with ASIS_UL.Misc; use ASIS_UL.Misc; with ASIS_UL.Options; use ASIS_UL.Options; with ASIS_UL.Output; use ASIS_UL.Output; with ASIS_UL.String_Utilities; use ASIS_UL.String_Utilities; with ASIS_UL.Utilities; use ASIS_UL.Utilities; with Gnatstub.Options; use Gnatstub.Options; with Gnatstub.Projects; package body Gnatstub.Sampler is use type Asis.Errors.Error_Kinds; My_Context : Asis.Context; Level : Integer := 0; -- nesting level of a spec being processed Body_File : File_Type; Tree_File : File_Type; Spec_File : File_Type; Arg_File_Info : File_Info; Arg_Virt_File : Virtual_File; -- Needed when creating separate bodies: Subunit_Name_Temlate : String_Access; -- Used to create the name of a separate body to generate. Has the -- following structure: -- -- -- -- where is the suffix defined for separate bodies by the argument -- project file (if any) or just ".adb" First_Idx : Natural; Last_Idx : Natural; Insert_Idx : Natural; -- Indexes into Subunit_Name_Temlate. Insert_Idx points to the place where -- the separate body name should be inserted to get the subunit name - -- to the last character of type Subunit_Name_Casings is (Lowercase, Uppercase, Mixedcase); Subunit_Name_Casing : Subunit_Name_Casings := Lowercase; ------------------------------------ -- The note about pretty-printing -- ------------------------------------ -- We do not put any special efforts in getting a very nice formatting of -- the sample body code generated by gnatstub. This code is supposed to be -- revised manually by a gnatstub user, so only some very general elements -- of pretty-printing are implemented in gnatstub ----------------------- -- Local subprograms -- ----------------------- function Get_Tree_Name return String; -- Computes the name of the tree file from Short_File_Name. procedure Check_Parameters; -- Checks, that Gnatstub options and files existing in the file -- system fit each other. If the check fails, generates the diagnostic -- message and raises Parameter_Error procedure Prepare_Context; -- If in NON-GNSA mode, this procedure creates a tree file or checks if the -- tree file already exists, depending on options. Then it defines and -- opens the ASIS Context. -- In GNSA mode, it defines and opens the ASIS GNSA Context type Element_Node; type Link is access all Element_Node; type Element_Node is record Spec : Asis.Element := Nil_Element; Spec_Name : Program_Text_Access; -- not used for incomplete type declarations Up : Link; Down : Link; Prev : Link; Next : Link; Last : Link; end record; -- An element of a dynamic structure representing a "skeleton" of the body -- to be generated -- -- Logically this structure is a list of elements representing local -- bodies and sublists representing the bodies which are a components of -- some local body. Each list and sublist is represented by its first -- element. For this first list element, the field Last is used to point -- to the last element in this list to speed up adding the new element if -- we do not have to order alphabetically the local bodies. Body_Structure : aliased Element_Node; Body_Structure_Access : constant Link := Body_Structure'Access; -- this is a "design" for a body to generate. It contains references -- to the elements from the argument spec for which body samples should -- be generated, ordered alphabetically. The top of this link structure -- is the Element representing a unit declaration from the argument -- compilation unit. procedure Free is new Ada.Unchecked_Deallocation (Object => Element_Node, Name => Link); procedure Free_Body_Structure; -- Releases all the memory occupied by the internal representation of the -- body stub to generate. Is needed when separate units are generated, in -- this case the internal representation is created for each separate body. ------------------------------------------------- -- Actuals for Traverse_Element instantiation -- ------------------------------------------------- type Body_State is record Argument_Spec : Boolean := True; -- flag indicating if we are in the very beginning (very top) -- of scanning the argument library unit declaration Current_List : Link; -- declaration list in which a currently processed spec -- should be inserted; Last_Top : Link; -- an element which represents a declaration from which the currently -- processed sublist was originated New_List_Needed : Boolean := False; -- flag indication if a new sublist should be created end record; Initial_State : constant Body_State := (Argument_Spec => True, Current_List => null, Last_Top => null, New_List_Needed => False); procedure Create_Element_Node (Element : Asis.Element; Control : in out Traverse_Control; State : in out Body_State); -- when visiting an Element representing something for which a body -- sample may be required, we check if the body is really required -- and insert the corresponding Element on the right place in Body_State -- if it is. procedure Go_Up (Element : Asis.Element; Control : in out Traverse_Control; State : in out Body_State); -- when leaving a [generic] package declaration or a protected [type] -- declaration, we have to go one step up in Body_State structure. procedure Create_Body_Structure is new Traverse_Element (State_Information => Body_State, Pre_Operation => Create_Element_Node, Post_Operation => Go_Up); -- Creates Body_Structure by traversing an argument spec and choosing -- specs to create body samples for function Requires_Body (El : Element) return Boolean; -- checks if a body sample should be created for an element function Name (El : Asis.Element) return Program_Text; -- returns a defining name string image for a declaration which -- defines exactly one name. This should definitely be made an extension -- query function Bodyless_Package (Node : Link) return Boolean; -- Checks if Node represents a local package which does not require -- a body. (It is an error to call this function for a null -- argument procedure Generate_CU_Header (Success : out Boolean; For_Subunit : Boolean := False; Subunit_Name : Asis.Element := Nil_Element); -- Generates in Body_File the comment header for the sample body. Sets -- Success to True if the comment header is successfully generated. -- If For_Subunit is ON, Subunit_Name should be set to the defining name -- of the separate unit. In this case the standard header contains the -- name of the separate unit, but not the argument unit. If -- Gnatstub.Options.Header is set to From_Spec, for subunit it does NOT -- contain the subunit name, the only change is replacing "S p e c' with -- 'B o d y' -- ??? Do we really need the Success parameter??? procedure Generate_Unit_Header (Node : Link); -- Generates the comment header for a local program unit body. Does nothing -- if No_Local_Comment_Headers is ON. procedure Generate_Body_Structure; -- generates in Body_File the Ada part of the sample body, using -- the list structure created in Body_Structure as a template -- The following group of subprograms generate completion for specific -- kinds of specs: procedure Generate_Package_Body (Node : Link); procedure Generate_Function_Body (Node : Link); procedure Generate_Procedure_Body (Node : Link); procedure Generate_Entry_Body (Node : Link); procedure Generate_Protected_Body (Node : Link); procedure Generate_Task_Body (Node : Link); procedure Generate_Full_Type_Declaration (Node : Link); procedure Generate_Separate_Stubs (Body_Unit : Asis.Compilation_Unit); -- If Body_Unit is a library unit body, this procedure generates stub -- subunits for the body stubs contained in this unit procedure Generate_Profile (Node : Link; Change_Line : out Boolean); -- Generates an entry_body_formal_part, parameter or parameter and result -- profile for the body of a program unit represented by Node. Upon exit, -- sets Change_Line is set True if the following "is" for the body should -- be generated on a new line; function Image_For_String (S : Program_Text) return Program_Text; -- If S starts and ends with '"', return '"' & S & '"", otherwise return S. -- This is needed to create an image of an operator symbol in generated -- string constants. procedure Emergency_Clean_Up; -- Does clean up actions in case if an exception was raised during -- creating a body sample (closes a Context, dissociates it, finalizes -- ASIS, closes and deletes needed files. function Allows_Var_Declaration (Res_Profile : Asis.Element) return Boolean; -- This function assumes that Res_Profile represents the result profile -- from a function specification, it checks if this profile denotes a type -- that allow creating a local object of this type (to return as the -- function result in the function body stub). ---------------------------- -- Allows_Var_Declaration -- ---------------------------- function Allows_Var_Declaration (Res_Profile : Asis.Element) return Boolean is Tmp : Asis.Element; Result : Boolean := False; begin if Element_Kind (Res_Profile) = An_Expression then -- Definitely False for functions returning anonymous access -- definitions if Attribute_Kind (Res_Profile) = A_Base_Attribute then Result := True; else Tmp := Normalize_Reference (Res_Profile); Result := Can_Create_Return_Object (Tmp); end if; end if; return Result; end Allows_Var_Declaration; ---------------------- -- Bodyless_Package -- ---------------------- function Bodyless_Package (Node : Link) return Boolean is Result : Boolean := False; Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Node.Spec); Next_Node : Link; Next_List : Link; begin if Arg_Kind = A_Package_Declaration or else Arg_Kind = A_Generic_Package_Declaration then Result := True; if Node.Down /= null then Next_List := Node.Down; while Next_List.Prev /= null loop Next_List := Next_List.Prev; end loop; Next_Node := Next_List; while Next_Node /= null loop if not Bodyless_Package (Next_Node) then Result := False; exit; end if; Next_Node := Next_Node.Next; end loop; end if; end if; return Result; end Bodyless_Package; ---------------- -- Brief_Help -- ---------------- procedure Brief_Help is begin pragma Style_Checks (Off); Info ("Usage: gnatstub [options] filename [-cargs gcc_switches]"); Info (""); Info (" filename Ada source file"); Info (""); Info ("options:"); Info (" --version Display version and exit"); Info (" --help Display usage and exit"); Info (""); Info (" -Pproject Use project file project. Only one such switch."); Info (" can be used."); Info (" -Xname=value specify an external reference for argument"); Info (" project file"); Info (" -eL follow all symbolic links when processing"); Info (" project files"); Info (""); Info (" --subunits generate separate bodies for body stubs"); Info (""); Info (" -f replace an existing body file (if any), with a body"); Info (" sample (is not allowed with '--subunits')"); Info (" -gnatec use additional configuration file,"); Info (" same meaning as for gcc"); Info (" -gnatyMnnn maximum line length in a sample body"); Info (" -gnatyn (n in 1 .. 9) number of spaces used for indentation in"); Info (" a sample body"); Info (" -gnatyo alphabetically order local bodies"); Info (" -hg insert a sample comment header"); Info (" -hs insert the comment header from the spec"); Info (" --header-file=filename insert the comment header from the specified file"); Info (" -Idir source search dir, has the same meaning as for"); Info (" gcc and gnatmake"); Info (" -I- do not look for the sources in the default directory"); Info (" -in same as -gnatyn"); Info (" -k do not remove the tree file"); Info (" -lnnn same as -gnatyMnnn"); Info (" --no-exception avoid raising Program_Error in stubs"); Info (" --no-local-header no local comment headers for unit stubs"); Info (" -o body-name the name of the file to place the body into."); Info (" --dir=directory place generated file(s) into directory"); Info (" -W(h|u|s|e|8|b) sets the wide character encoding of the result file"); Info (" h - Hex ESC encoding"); Info (" u - Upper half encoding"); Info (" s - Shift-JIS encoding"); Info (" e - EUC Encoding"); Info (" 8 - UTF-8 encoding"); Info (" b - Brackets encoding (this is the default)"); Info (""); Info (" -q quiet mode"); Info (" -r reuse the tree file (if any) instead of creating it"); Info (" (-r also implies -k)"); Info (" -t overwrite the existing tree file"); Info (" -v verbose mode"); Info (" gcc_switches switches to be passed to gcc called by " & ASIS_UL.Common.Tool_Name.all); pragma Style_Checks (On); end Brief_Help; ---------------------- -- Check_Parameters -- ---------------------- procedure Check_Parameters is Str_Tmp : String_Access; begin -- First, check for incompatible combination of options: if Generate_Subunits then if Body_Form /= null then Error ("result body name cannot be specified " & "when generating subunits"); raise Parameter_Error; end if; if Overwrite_Body then Error ("overwrite mode cannot be specified " & "when generating subunits"); raise Parameter_Error; end if; end if; if Body_Form = null then Body_Form := new String'(""); end if; -- checking if the file to process really exists: if Gnatstub.Projects.Is_Specified (Gnatstub.Options.Gnatstub_Prj) then Arg_Virt_File := Gnatstub.Projects.Create (Gnatstub.Options.Gnatstub_Prj, +File_Name.all); if Arg_Virt_File = No_File then Error ("cannot find " & File_Name.all); raise Parameter_Error; end if; Arg_File_Info := Info (Gnatstub.Options.Gnatstub_Prj, Arg_Virt_File); Str_Tmp := new String'(+Full_Name (Arg_Virt_File)); Free (File_Name); File_Name := new String'(Str_Tmp.all); Free (Str_Tmp); elsif not Is_Regular_File (File_Name.all) then Error ("cannot find " & File_Name.all); raise Parameter_Error; end if; if Test_Mode then Alphabetical_Ordering := True; Quiet_Mode := True; Overwrite_Tree := True; end if; -- Naming for the result file(s): File_Name_Len := File_Name'Length; File_Name_First := File_Name'First; File_Name_Last := File_Name'Last; if Generate_Subunits then if not Gnatstub.Projects.Is_Specified (Gnatstub.Options.Gnatstub_Prj) and then not (File_Name_Len >= 5 and then File_Name (File_Name_Last - 3 .. File_Name_Last) = ".adb") then -- If we do not have a project file, than we expect a standard -- naming scheme Error ("standard naming scheme is expected " & "for generating subunits"); raise Parameter_Error; end if; else if not (File_Name_Len >= 5 and then File_Name (File_Name_Last - 3 .. File_Name_Last) = ".ads") and then Body_Name = null then if Gnatstub.Projects.Is_Specified (Gnatstub.Options.Gnatstub_Prj) then -- Try to compute the name of the result body from the project Body_Name := new String'(+GNATCOLL.Projects.File_From_Unit (Project => Project (Arg_File_Info), Unit_Name => Unit_Name (Arg_File_Info), Part => Unit_Body, Language => "Ada", File_Must_Exist => False)); else if File_Name_Len >= 5 and then File_Name (File_Name_Last - 3 .. File_Name_Last) = ".adb" then -- A special case: the argument file looks like a body file Error ("input file looks like a body"); end if; -- The general case Error ("output file name should be provided because " & File_Name.all & " does not follow GNAT naming rules for " & "spec files"); raise Parameter_Error; end if; end if; end if; -- if destination is set, check if the destination directory exists: if Destination_Dir.all /= "" and then not Is_Directory (Destination_Dir.all) then Error ("directory " & Destination_Dir.all & " does not exist"); raise Parameter_Error; end if; -- If subunits should be generated, we will prepare the template for -- subunit file name if Generate_Subunits then if Gnatstub.Projects.Is_Specified (Gnatstub.Options.Gnatstub_Prj) then declare Arrt_Dot_Replacement : constant Attribute_Pkg_String := Build (Naming_Package, "Dot_Replacement"); Arrt_Body_Suffix : constant Attribute_Pkg_String := Build (Naming_Package, "Body_Suffix"); Arrt_Separate_Suffix : constant Attribute_Pkg_String := Build (Naming_Package, "Separate_Suffix"); Arrt_Casing : constant Attribute_Pkg_String := Build (Naming_Package, "Casing"); Dot_Rep : constant String := Attribute_Value (Project => Project (Arg_File_Info), Attribute => Arrt_Dot_Replacement, Use_Extended => True); Body_Suf : constant String := Attribute_Value (Project => Project (Arg_File_Info), Index => "Ada", Attribute => Arrt_Body_Suffix, Use_Extended => True); Sep_Suf : constant String := Attribute_Value (Project => Project (Arg_File_Info), Attribute => Arrt_Separate_Suffix, Use_Extended => True); Casing_Str : constant String := Attribute_Value (Project => Project (Arg_File_Info), Attribute => Arrt_Casing, Use_Extended => True); begin if Destination_Dir.all /= "" then Str_Tmp := new String' (Destination_Dir.all & Directory_Separator & GNAT.Directory_Operations.Base_Name (File_Name.all)); else Str_Tmp := new String'(File_Name.all); end if; First_Idx := Str_Tmp'First; Insert_Idx := Natural'Max (Index (Str_Tmp.all, Body_Suf, Backward), Index (Str_Tmp.all, Sep_Suf, Backward)); Subunit_Name_Temlate := new String' (Str_Tmp (First_Idx .. Insert_Idx - 1) & Dot_Rep & Sep_Suf); Insert_Idx := Insert_Idx + Dot_Rep'Length - 1; if Casing_Str = "lowercase" then Subunit_Name_Casing := Lowercase; elsif Casing_Str = "uppercase" then Subunit_Name_Casing := Uppercase; elsif Casing_Str = "mixedcase" then Subunit_Name_Casing := Mixedcase; else Error ("cannot detect subunit file name casing"); end if; Free (Str_Tmp); end; else First_Idx := File_Name'First; Insert_Idx := File_Name'Last - 4; Subunit_Name_Temlate := new String'(File_Name (First_Idx .. Insert_Idx) & "-.adb"); Insert_Idx := Insert_Idx + 1; end if; Last_Idx := Subunit_Name_Temlate'Last; end if; -- Compute the body file name if it is not set or check that it does -- not contain the directory info otherwise Short_File_Name := new String'(GNAT.Directory_Operations.Base_Name (File_Name.all)); Short_File_Name_Len := Short_File_Name'Length; Short_File_Name_First := Short_File_Name'First; Short_File_Name_Last := Short_File_Name'Last; if not Generate_Subunits then if Body_Name = null then if Destination_Dir.all = "" then Body_Name := new String'(Short_File_Name.all); else Body_Name := new String' (Destination_Dir.all & Directory_Separator & Short_File_Name.all); end if; Body_Name (Body_Name'Last) := 'b'; else if GNAT.Directory_Operations.Base_Name (Body_Name.all) /= Body_Name.all then Error ("output file name should not contain any path information"); raise Parameter_Error; end if; if Destination_Dir.all /= "" then Str_Tmp := new String'(Destination_Dir.all & Directory_Separator & Body_Name.all); Free (Body_Name); Body_Name := new String'(Str_Tmp.all); Free (Str_Tmp); end if; end if; Full_Body_Name := -- new String'(Str_Tmp.all); new String'(GNAT.Directory_Operations.Format_Pathname (Normalize_Pathname (Body_Name.all))); -- Normalizing the argument name Str_Tmp := new String'(GNAT.Directory_Operations.Format_Pathname (Normalize_Pathname (File_Name.all))); Full_File_Name := new String'(Str_Tmp.all); Free (Str_Tmp); -- Check if the source and the destination are not the same if Full_File_Name.all = Full_Body_Name.all then Error ("output file is the same as the argument file - " & "check the file names"); raise Parameter_Error; end if; -- checking if a body already exists: if Is_Regular_File (Body_Name.all) then if Overwrite_Body then if Is_Writable_File (Body_Name.all) then begin Open (Body_File, Out_File, Body_Name.all, Body_Form.all); Delete (Body_File); exception when others => Error ("cannot delete the existing body for " & File_Name.all); raise Parameter_Error; end; else Error ("the existing body for " & File_Name.all & " cannot be overwritten"); raise Parameter_Error; end if; else Error ("the body for " & File_Name.all & " already exists; " & "use -f to overwrite it"); raise Parameter_Error; end if; end if; end if; -- Check that the comment header file exists: if Header = From_File and then not Is_Regular_File (Header_File_Name.all) then Error ("the file " & Header_File_Name.all & " to take the comment header from does not exists"); raise Parameter_Error; end if; -- now, checking the situation with the tree file: Tree_Name := new String'(Get_Tree_Name); if Is_Regular_File (Tree_Name.all) then Tree_Exists := True; if not (Reuse_Tree or else Overwrite_Tree) then Error ("tree file " & Tree_Name.all & " already exists" & " use -r or -t to reuse or to overwrite it"); raise Parameter_Error; end if; else if Reuse_Tree then Error ("cannot find tree file" & Tree_Name.all & " (-r is set)"); raise Parameter_Error; end if; end if; if Reuse_Tree then Delete_Tree := False; Overwrite_Tree := False; end if; Store_I_Options; Free (Destination_Dir); if Gnatstub.Options.Gnatstub_Prj.Is_Specified then Gnatstub.Projects.Set_Global_Result_Dirs (Gnatstub.Options.Gnatstub_Prj); Gnatstub.Projects.Set_Individual_Source_Options (Gnatstub.Options.Gnatstub_Prj); Set_Arg_List; end if; Set_Arg_List; end Check_Parameters; -------------- -- Clean_Up -- -------------- procedure Clean_Up is begin if Delete_Tree and then Tree_Exists then -- Deleting the tree file itself Open (Tree_File, In_File, Tree_Name.all); Delete (Tree_File); -- Deleting the ALI file which was created along with the tree file -- We use the modified Tree_Name for this, because we do not need -- Tree_Name any more Tree_Name (Tree_Name'Last - 2 .. Tree_Name'Last) := "ali"; if Is_Regular_File (Tree_Name.all) then Open (Tree_File, In_File, Tree_Name.all); Delete (Tree_File); end if; end if; if Need_Tmp_ADA_PRJ_INCLUDE_FILE and then ADA_PRJ_INCLUDE_FILE_Full_Name /= null then Open (Tree_File, In_File, ADA_PRJ_INCLUDE_FILE_Full_Name.all); Delete (Tree_File); end if; ASIS_UL.Environment.Clean_Up; end Clean_Up; ------------------------- -- Create_Element_Node -- ------------------------- procedure Create_Element_Node (Element : Asis.Element; Control : in out Traverse_Control; State : in out Body_State) is Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Element); Current_Node : Link; procedure Insert_In_List (State : in out Body_State; El : Asis.Element; New_Node : out Link); -- inserts an argument Element in the current list, keeping the -- alphabetic ordering. Creates a new sublist if needed. -- New_Node returns the reference to the newly inserted node -------------------- -- Insert_In_List -- -------------------- procedure Insert_In_List (State : in out Body_State; El : Asis.Element; New_Node : out Link) is Next_Node : Link; Insert_After : Link; Insert_First : Boolean := False; Insert_Last : Boolean := False; begin New_Node := new Element_Node; New_Node.Spec := El; New_Node.Spec_Name := new Program_Text'(Name (El)); if State.New_List_Needed then -- here we have to set up a new sub-list: State.Current_List := New_Node; New_Node.Up := State.Last_Top; State.Last_Top.Down := New_Node; State.New_List_Needed := False; New_Node.Last := New_Node; -- We've just created a new list. It contains a single element -- which is its last Element, so we are setting the link to the -- last element to the Prev field of the list head element else -- here we have to insert New_Node in an existing list, -- keeping the alphabetical order of program unit names New_Node.Up := State.Current_List.Up; if Arg_Kind in An_Incomplete_Type_Declaration .. A_Tagged_Incomplete_Type_Declaration then -- no need for alphabetical ordering, inserting in the -- very beginning: New_Node.Last := State.Current_List.Last; -- New_Node will be the head element of the list, so we have -- to copy into this new head element the reference to the -- last element of the list. New_Node.Next := State.Current_List; State.Current_List.Prev := New_Node; State.Current_List := New_Node; else if Alphabetical_Ordering then Next_Node := State.Current_List; -- finding the right place in the current list loop if Flat_Element_Kind (Next_Node.Spec) in An_Incomplete_Type_Declaration .. A_Tagged_Incomplete_Type_Declaration then if Next_Node.Next = null then -- nothing except incomplete types in the list: Insert_After := Next_Node; exit; end if; else -- here we have a program unit spec if To_Lower_Case (New_Node.Spec_Name.all) < To_Lower_Case (Next_Node.Spec_Name.all) then if Next_Node.Prev = null then Insert_First := True; else Insert_After := Next_Node.Prev; end if; exit; end if; end if; if Next_Node.Next = null then Insert_After := Next_Node; Insert_Last := True; exit; else Next_Node := Next_Node.Next; end if; end loop; else Insert_After := State.Current_List.Last; Insert_Last := True; end if; -- inserting in the list: if Insert_First then -- inserting in the beginning: New_Node.Next := State.Current_List; State.Current_List.Prev := New_Node; State.Current_List := New_Node; elsif Insert_Last then New_Node.Prev := Insert_After; Insert_After.Next := New_Node; State.Current_List.Last := New_Node; else New_Node.Next := Insert_After.Next; Insert_After.Next.Prev := New_Node; New_Node.Prev := Insert_After; Insert_After.Next := New_Node; end if; end if; end if; end Insert_In_List; -- start of the processing of Create_Element_Node begin if State.Argument_Spec then Body_Structure.Spec := Element; State.Argument_Spec := False; Body_Structure.Spec_Name := new Program_Text'(Name (Element)); Current_Node := Body_Structure'Access; elsif Arg_Kind = A_Defining_Identifier then -- skipping a defining name of a spec which may contain local -- specs requiring bodies null; elsif Arg_Kind = A_Protected_Definition then -- we just have to go one level down to process protected items: null; elsif not Requires_Body (Element) then Control := Abandon_Children; return; else Insert_In_List (State, Element, Current_Node); end if; if Arg_Kind = A_Package_Declaration or else Arg_Kind = A_Generic_Package_Declaration or else Arg_Kind = A_Single_Protected_Declaration or else Arg_Kind = A_Protected_Type_Declaration then -- here we may have specs requiring bodies inside a construct State.New_List_Needed := True; State.Last_Top := Current_Node; elsif Arg_Kind = A_Protected_Definition then -- we have to skip this syntax level null; else -- no need to go deeper Control := Abandon_Children; end if; end Create_Element_Node; ------------------- -- Create_Sample -- ------------------- procedure Create_Sample is CU : Asis.Compilation_Unit; CU_Kind : Unit_Kinds; My_Control : Traverse_Control := Continue; My_State : Body_State; Header_Created : Boolean; begin CU := Main_Unit_In_Current_Tree (My_Context); CU_Kind := Unit_Kind (CU); if Is_Nil (CU) then Error ("file " & Gnatstub.Options.File_Name.all & " does not contain a unit to process"); return; end if; if Generate_Subunits then Generate_Separate_Stubs (CU); else if not (CU_Kind in A_Subprogram_Declaration or else CU_Kind in A_Generic_Unit_Declaration or else CU_Kind = A_Package) then Error ("Compilation unit " & To_String (Unit_Full_Name (CU)) & " cannot have a body" & (if not Quiet_Mode then " Unit Kind: " & (CU_Kind'Img) else "")); return; elsif not Asis.Extensions.CU_Requires_Body (CU) then Error ("Compilation unit " & To_String (Unit_Full_Name (CU)) & " does not require a body"); return; else -- and here we have to do the job: begin Create (Body_File, Out_File, Body_Name.all, Body_Form.all); exception when Ada.IO_Exceptions.Name_Error => Put_Line (Standard_Error, "gnatstub: cannot create " & "check the file name"); raise Fatal_Error; end; Create_Body_Structure ( Element => Unit_Declaration (CU), Control => My_Control, State => My_State); -- first, trying to create the header, if needed: Generate_CU_Header (Header_Created); if Header_Created then Put_Line (Body_File, "pragma Ada_2012;"); Generate_Body_Structure; Close (Body_File); if not Quiet_Mode then Info ("body is created for " & Gnatstub.Options.File_Name.all); end if; else Error ("failed to write the comment header for the body for " & Gnatstub.Options.File_Name.all); end if; end if; end if; Close (My_Context); Dissociate (My_Context); Asis.Implementation.Finalize; exception when Ex : Asis.Exceptions.ASIS_Inappropriate_Context | Asis.Exceptions.ASIS_Inappropriate_Container | Asis.Exceptions.ASIS_Inappropriate_Compilation_Unit | Asis.Exceptions.ASIS_Inappropriate_Element | Asis.Exceptions.ASIS_Inappropriate_Line | Asis.Exceptions.ASIS_Inappropriate_Line_Number | Asis.Exceptions.ASIS_Failed => New_Line (File => Standard_Error); if Asis.Implementation.Status = Asis.Errors.Use_Error and then Reuse_Tree and then Tree_Exists then Error ("the tree you try to reuse may be obsolete"); Error_No_Tool_Name ("either recreate the tree or do not use -r option"); else Report_Unhandled_ASIS_Exception (Ex); end if; Emergency_Clean_Up; raise Fatal_Error; when others => Emergency_Clean_Up; raise; end Create_Sample; --------------------- -- Prepare_Context -- --------------------- procedure Prepare_Context is separate; -- We need different bodies for GNSA and non-GNSA versions ------------------------ -- Emergency_Clean_Up -- ------------------------ procedure Emergency_Clean_Up is begin if Is_Open (My_Context) then Close (My_Context); end if; Dissociate (My_Context); Asis.Implementation.Finalize; if Is_Open (Body_File) then -- No need to keep a broken body in case of an emergency clean up Delete (Body_File); end if; if Is_Open (Spec_File) then -- No need to keep a broken body in case of an emergency clean up Close (Spec_File); end if; end Emergency_Clean_Up; ------------------------- -- Free_Body_Structure -- ------------------------- procedure Free_Body_Structure is procedure Free_Node (Node : in out Link); procedure Free_List (L : Link); procedure Free_Node (Node : in out Link) is begin Free (Node.Spec_Name); Free_List (Node.Down); Free (Node); end Free_Node; procedure Free_List (L : Link) is Current, Next : Link; begin Current := L; while Current /= null loop Next := Current.Next; Free_Node (Current); Current := Next; end loop; end Free_List; begin Free_List (Body_Structure_Access.Down); Free (Body_Structure_Access.Spec_Name); end Free_Body_Structure; ----------------------------- -- Generate_Body_Structure -- ----------------------------- procedure Generate_Body_Structure is procedure Print_Node (Node : Link); -- outputs a Node into Body_File procedure Print_Node_List (List : Link); -- outputs a list of nodes into Body_File. These two procedures - -- Print_Node and Print_Node_List call each other recursively procedure Print_Node (Node : Link) is Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Node.Spec); begin if Node /= Body_Structure'Access and then Bodyless_Package (Node) then return; end if; if Level /= 0 and then Arg_Kind not in An_Incomplete_Type_Declaration .. A_Tagged_Incomplete_Type_Declaration then Generate_Unit_Header (Node); end if; case Arg_Kind is when A_Package_Declaration | A_Generic_Package_Declaration => Generate_Package_Body (Node); 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); 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 => Put (Standard_Error, "gnatstub: unexpected element "); Put_Line (Standard_Error, "in the body structure"); raise Fatal_Error; end case; if Node.Down /= null then Print_Node_List (Node.Down); end if; end Print_Node; procedure Print_Node_List (List : Link) is Next_Node : Link; List_Start : Link := List; begin Level := Level + 1; -- here we have to go to the beginning of the list: while List_Start.Prev /= null loop List_Start := List_Start.Prev; end loop; Next_Node := List_Start; loop Print_Node (Next_Node); if Next_Node.Next /= null then Next_Node := Next_Node.Next; else exit; end if; end loop; -- finalizing the enclosing construct: Level := Level - 1; Next_Node := Next_Node.Up; Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "end " & Next_Node.Spec_Name.all & ";"); if List.Up /= Body_Structure'Access then New_Line (Body_File); end if; end Print_Node_List; begin Print_Node (Body_Structure_Access); end Generate_Body_Structure; ------------------------ -- Generate_CU_Header -- ------------------------ procedure Generate_CU_Header (Success : out Boolean; For_Subunit : Boolean := False; Subunit_Name : Asis.Element := Nil_Element) is -- This local declarations are used to generate a sample comment -- header Unit_Name_Len : Positive := (if For_Subunit then Body_Structure.Spec_Name'Length + 1 else Body_Structure.Spec_Name'Length); Left_Unit_Name_Spaces : Positive; Right_Unit_Name_Spaces : Positive; Left_Body_Spaces : Positive; Right_Body_Spaces : Positive; Name_With_Spaces : Boolean := True; Body_String : constant Program_Text := "B o d y"; Body_String_Len : constant Positive := Body_String'Length; -- These local declarations are used to copy a comment header from the -- argument spec Header_File : File_Type; String_Buf : Program_Text (1 .. Hostparm.Max_Line_Length); Header_Line_Len : Natural; Idx : Natural; Line_Count : Natural := 0; Spec_String_Start : Natural; Subunit_Name_On_Separate_Line : Boolean := False; Subunit_Name_Str : constant Program_Text := (if For_Subunit then Defining_Name_Image (Subunit_Name) else ""); Subunit_Name_Len : Natural := Subunit_Name_Str'Length; Left_Subunit_Name_Spaces : Positive; Right_Subunit_Name_Spaces : Positive; Total_Subunit_Name_Len : Positive; procedure Strip_Trailing_Spaces; -- Strips trailing spaces from the string stored in String_Buf -- (assuming that Header_Line_Len points to the last character of this -- string) and resets Header_Line_Len accordingly. procedure Strip_Trailing_Spaces is begin for J in reverse 1 .. Header_Line_Len loop if not Is_White_Space (String_Buf (J)) then Header_Line_Len := J; exit; end if; end loop; end Strip_Trailing_Spaces; begin Success := False; case Header is when No_Header => null; when Stand_Header => -- first, checking if we can fit the maximum line length: if Unit_Name_Len + 6 > Max_Body_Line_Length or else (For_Subunit and then Subunit_Name_Len + 6 > Max_Body_Line_Length) then Put (Standard_Error, "gnatstub: unit name is too "); Put_Line (Standard_Error, "long to generate a comment header"); Put (Standard_Error, "gnatstub: try to increase "); Put_Line (Standard_Error, "the maximum body line length"); raise Fatal_Error; end if; if (2 * Unit_Name_Len - 1) + 6 > Max_Body_Line_Length or else (For_Subunit and then (2 * Subunit_Name_Len - 1) + 6 > Max_Body_Line_Length) then Name_With_Spaces := False; else Unit_Name_Len := 2 * Unit_Name_Len - 1; if For_Subunit then Subunit_Name_Len := 2 * Subunit_Name_Len - 1; end if; end if; if For_Subunit then Total_Subunit_Name_Len := Unit_Name_Len + Subunit_Name_Len; if Name_With_Spaces then Total_Subunit_Name_Len := Total_Subunit_Name_Len + 1; end if; if Total_Subunit_Name_Len + 6 > Max_Body_Line_Length then Subunit_Name_On_Separate_Line := True; Left_Subunit_Name_Spaces := (Max_Body_Line_Length - 4 - Subunit_Name_Len) / 2; Right_Subunit_Name_Spaces := Max_Body_Line_Length - Subunit_Name_Len - 4 - Left_Subunit_Name_Spaces; else Unit_Name_Len := Total_Subunit_Name_Len; end if; end if; Left_Unit_Name_Spaces := (Max_Body_Line_Length - 4 - Unit_Name_Len) / 2; Right_Unit_Name_Spaces := Max_Body_Line_Length - Unit_Name_Len - 4 - Left_Unit_Name_Spaces; Left_Body_Spaces := (Max_Body_Line_Length - 4 - Body_String_Len) / 2; Right_Body_Spaces := Max_Body_Line_Length - Body_String_Len - 4 - Left_Body_Spaces; Put_Line (Body_File, Max_Body_Line_Length * '-'); Put_Line (Body_File, "--" & (Max_Body_Line_Length - 4) * ' ' & "--"); Put (Body_File, "--" & Left_Unit_Name_Spaces * ' '); if Name_With_Spaces then Put (Body_File, To_Upper (Body_Structure.Spec_Name (Body_Structure.Spec_Name'First))); for I in Body_Structure.Spec_Name'First + 1 .. Body_Structure.Spec_Name'Last loop Put (Body_File, ' ' & To_Upper (Body_Structure.Spec_Name (I))); end loop; if For_Subunit and then not Subunit_Name_On_Separate_Line then Put (Body_File, " ."); for I in Subunit_Name_Str'Range loop Put (Body_File, ' ' & To_Upper (Subunit_Name_Str (I))); end loop; end if; else Put (Body_File, To_Upper (Body_Structure.Spec_Name.all)); if For_Subunit and then not Subunit_Name_On_Separate_Line then Put (Body_File, '.' & To_Upper (Subunit_Name_Str)); end if; end if; Put_Line (Body_File, Right_Unit_Name_Spaces * ' ' & "--"); if For_Subunit and then Subunit_Name_On_Separate_Line then Put (Body_File, "--" & Left_Subunit_Name_Spaces * ' '); if Name_With_Spaces then Put (Body_File, To_Upper (Subunit_Name_Str (Subunit_Name_Str'First))); for I in Subunit_Name_Str'First + 1 .. Subunit_Name_Str'Last loop Put (Body_File, ' ' & To_Upper (Subunit_Name_Str (I))); end loop; else Put (Body_File, To_Upper (Subunit_Name_Str)); end if; Put_Line (Body_File, Right_Subunit_Name_Spaces * ' ' & "--"); end if; Put_Line (Body_File, "--" & (Max_Body_Line_Length - 4) * ' ' & "--"); Put_Line (Body_File, "--" & Left_Body_Spaces * ' ' & Body_String & Right_Body_Spaces * ' ' & "--"); Put_Line (Body_File, "--" & (Max_Body_Line_Length - 4) * ' ' & "--"); Put_Line (Body_File, Max_Body_Line_Length * '-'); New_Line (Body_File); when From_Spec => Open (Header_File, In_File, File_Name.all, ""); while not End_Of_File (Header_File) loop Get_Line (Header_File, String_Buf, Header_Line_Len); Strip_Trailing_Spaces; Line_Count := Line_Count + 1; exit when String_Buf (1 .. 2) /= "--"; if Header_Line_Len > Max_Body_Line_Length then Error ("line" & Line_Count'Img & " in spec's comment header is too long"); Close (Header_File); raise Fatal_Error; end if; Spec_String_Start := Index (Source => String_Buf (1 .. Header_Line_Len), Pattern => "S p e c"); if Spec_String_Start /= 0 then Overwrite (Source => String_Buf (1 .. Header_Line_Len), Position => Spec_String_Start, New_Item => "B o d y"); end if; Put_Line (Body_File, String_Buf (1 .. Header_Line_Len)); end loop; Close (Header_File); when From_File => Open (Header_File, In_File, Header_File_Name.all, ""); while not End_Of_File (Header_File) loop Get_Line (Header_File, String_Buf, Header_Line_Len); Strip_Trailing_Spaces; Line_Count := Line_Count + 1; Idx := ASIS_Index_Non_Blank (String_Buf); if Idx /= 0 and then (Header_Line_Len - Idx = 0 or else String_Buf (Idx .. Idx + 1) /= "--") then Error ("line" & Line_Count'Img & " in comment header file is not a comment line"); Close (Header_File); raise Fatal_Error; elsif Header_Line_Len > Max_Body_Line_Length then Error ("line" & Line_Count'Img & " in comment header file is too long"); Close (Header_File); raise Fatal_Error; end if; Put_Line (Body_File, String_Buf (1 .. Header_Line_Len)); end loop; Close (Header_File); end case; Success := True; exception when others => Emergency_Clean_Up; raise; end Generate_CU_Header; ------------------------- -- Generate_Entry_Body -- ------------------------- procedure Generate_Entry_Body (Node : Link) is Change_Line : Boolean; begin Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put (Body_File, "entry " & Node.Spec_Name.all); Generate_Profile (Node, Change_Line); if Change_Line then New_Line (Body_File); Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); else Put (Body_File, " "); end if; Put (Body_File, "when Standard.True"); -- now we have to decide how to output "is" if Change_Line or else Natural (Col (Body_File)) + 3 > Max_Body_Line_Length then New_Line (Body_File); Set_Col (Body_File, Positive_Count (1 + (Level) * Indent_Level)); else Put (Body_File, ' '); end if; Put_Line (Body_File, "is"); Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "begin"); Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); Put_Line (Body_File, "-- Generated stub: replace with real body!"); Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); Put_Line (Body_File, "pragma Compile_Time_Warning (Standard.True, """ & To_Wide_String (To_String (Node.Spec_Name.all)) & " unimplemented"");"); Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); if No_Exception_In_Stubs then Put_Line (Body_File, "null;"); else Put (Body_File, "raise Program_Error"); if Opt.Ada_Version >= Ada_2005 then Put (Body_File, " with ""Unimplemented entry " & To_Wide_String (To_String (Node.Spec_Name.all)) & '"'); end if; Put_Line (Body_File, ";"); end if; Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "end " & Node.Spec_Name.all & ";"); New_Line (Body_File); end Generate_Entry_Body; ------------------------------------ -- Generate_Full_Type_Declaration -- ------------------------------------ procedure Generate_Full_Type_Declaration (Node : Link) is Discr_Part : constant Asis.Element := Discriminant_Part (Node.Spec); Is_Tagged : constant Boolean := Flat_Element_Kind (Node.Spec) = A_Tagged_Incomplete_Type_Declaration; begin Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put (Body_File, "type " & Node.Spec_Name.all & " "); if Flat_Element_Kind (Discr_Part) = A_Known_Discriminant_Part then -- we do not split components of a discriminant part to fit -- Max_Body_Line_Length constraint (if needed) - it does not make any -- sense, because a user will for sure change this sample completion -- for an incomplete type declaration Put (Body_File, ASIS_Trim (Element_Image (Discr_Part)) & " "); end if; Put (Body_File, "is "); if Is_Tagged then Put (Body_File, "tagged "); end if; Put_Line (Body_File, "null record;"); New_Line (Body_File); end Generate_Full_Type_Declaration; ---------------------------- -- Generate_Function_Body -- ---------------------------- procedure Generate_Function_Body (Node : Link) is No_Raise_Statement : Boolean := False; Change_Line : Boolean; begin Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); if Is_Overriding_Declaration (Node.Spec) then Put (Body_File, "overriding "); elsif Is_Not_Overriding_Declaration (Node.Spec) then Put (Body_File, "not overriding "); end if; Put (Body_File, "function " & Node.Spec_Name.all); Generate_Profile (Node, Change_Line); if Change_Line then Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "is"); else Put_Line (Body_File, " is"); end if; if No_Exception_In_Stubs and then Allows_Var_Declaration (Result_Profile (Node.Spec)) then No_Raise_Statement := True; Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); Put (Body_File, "Result : "); Put (Body_File, ASIS_Trim (Element_Image (Result_Profile (Node.Spec)))); Put_Line (Body_File, ";"); end if; Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "begin"); Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); Put_Line (Body_File, "-- Generated stub: replace with real body!"); Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); Put_Line (Body_File, "pragma Compile_Time_Warning (Standard.True, """ & Image_For_String (To_Wide_String (To_String (Node.Spec_Name.all))) & " unimplemented"");"); Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); if No_Raise_Statement then Put_Line (Body_File, "return Result;"); else -- We now use a return of a raise expression, to avoid a kludgey -- recursive call to itself. This is Ada 2012, so the checks for -- >= Ada_2005 are not actually necessary. Put (Body_File, "return raise Program_Error"); if Opt.Ada_Version >= Ada_2005 then Put (Body_File, " with ""Unimplemented function " & To_Wide_String (To_String (Image_For_String (Node.Spec_Name.all))) & '"'); end if; Put_Line (Body_File, ";"); end if; Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "end " & Node.Spec_Name.all & ";"); New_Line (Body_File); end Generate_Function_Body; --------------------------- -- Generate_Package_Body -- --------------------------- procedure Generate_Package_Body (Node : Link) is begin Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "package body " & Node.Spec_Name.all & " is"); New_Line (Body_File); if Node = Body_Structure'Access and then Node.Down = null then -- this is a special case: an argument unit is a library [generic] -- package which requires a body but which does not contain any -- local declaration which itself requires a completion: Put_Line (Body_File, "end " & Node.Spec_Name.all & ";"); end if; end Generate_Package_Body; ----------------------------- -- Generate_Procedure_Body -- ----------------------------- procedure Generate_Procedure_Body (Node : Link) is Change_Line : Boolean; begin Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); if Is_Overriding_Declaration (Node.Spec) then Put (Body_File, "overriding "); elsif Is_Not_Overriding_Declaration (Node.Spec) then Put (Body_File, "not overriding "); end if; Put (Body_File, "procedure " & Node.Spec_Name.all); Generate_Profile (Node, Change_Line); if Change_Line then Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "is"); else Put_Line (Body_File, " is"); end if; Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "begin"); Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); Put_Line (Body_File, "-- Generated stub: replace with real body!"); Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); Put_Line (Body_File, "pragma Compile_Time_Warning (Standard.True, """ & To_Wide_String (To_String (Node.Spec_Name.all)) & " unimplemented"");"); Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); if No_Exception_In_Stubs then Put_Line (Body_File, "null;"); else Put (Body_File, "raise Program_Error"); if Opt.Ada_Version >= Ada_2005 then Put (Body_File, " with ""Unimplemented procedure " & To_Wide_String (To_String (Node.Spec_Name.all)) & '"'); end if; Put_Line (Body_File, ";"); end if; Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "end " & Node.Spec_Name.all & ";"); New_Line (Body_File); end Generate_Procedure_Body; ---------------------- -- Generate_Profile -- ---------------------- procedure Generate_Profile (Node : Link; Change_Line : out Boolean) is Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Node.Spec); Parameters : constant Asis.Element_List := Parameter_Profile (Node.Spec); Spec_Span : Span; Family_Def : Asis.Element; Construct_Len : Positive; begin Change_Line := False; -- first, generating an entry_index_specification for an entry_body, -- if needed: if Arg_Kind = An_Entry_Declaration then Family_Def := Entry_Family_Definition (Node.Spec); if not Is_Nil (Family_Def) then Spec_Span := Element_Span (Family_Def); -- checking how entry_index_specification should be printed -- "+ 12" below means " (for I in )" if (Spec_Span.First_Line /= Spec_Span.Last_Line) or else (Character_Position (Col (Body_File)) + 12 + Spec_Span.Last_Column - Spec_Span.First_Column + 1) > Max_Body_Line_Length then Change_Line := True; end if; if Change_Line then New_Line (Body_File); if Indent_Level > 0 then Set_Col ( Body_File, Positive_Count (1 + (Level + 1) * Indent_Level) - 2); end if; end if; Put (Body_File, " (for I in "); Put (Body_File, ASIS_Trim (Element_Image (Family_Def))); Put (Body_File, ")"); end if; end if; -- Now we have to decide, how to print parameter [and result] profile if Change_Line = False then if Arg_Kind = A_Generic_Procedure_Declaration or else Arg_Kind = A_Generic_Function_Declaration then -- Here we cannot use Span-based approach, so we use the -- rough parameter-number-based estimation: if Parameters'Length >= 2 then Change_Line := True; end if; else Spec_Span := Element_Span (Node.Spec); if Spec_Span.First_Line /= Spec_Span.Last_Line then -- First, rough check: if an argument spec occupies more than -- one line, we print parameters specs on separate lines: Change_Line := True; else -- We check if a construct plus additions needed for the body -- plus indentation level in the body fits maximum line length -- defined for the body. We assume that the argument spec is -- reasonably formatted Construct_Len := Spec_Span.Last_Column - Spec_Span.First_Column + 1; if Arg_Kind = An_Entry_Declaration and then not Is_Nil (Family_Def) then Construct_Len := Construct_Len + 9; -- "+ 9" stands for "for I in " else Construct_Len := Construct_Len + 3; -- "+ 3" stands for " is" end if; if Level * Indent_Level + Construct_Len > Max_Body_Line_Length then Change_Line := True; end if; end if; end if; end if; if not Is_Nil (Parameters) then if Change_Line then New_Line (Body_File); if Indent_Level > 0 then Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level - 1)); end if; Put (Body_File, "("); else Put (Body_File, " ("); end if; for I in Parameters'Range loop Put (Body_File, ASIS_Trim (Element_Image (Parameters (I)))); if I /= Parameters'Last then if Change_Line then Put_Line (Body_File, ";"); Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); else Put (Body_File, "; "); end if; end if; end loop; Put (Body_File, ")"); end if; if Arg_Kind = A_Function_Declaration or else Arg_Kind = A_Generic_Function_Declaration then -- we have to output " return : if Change_Line then New_Line (Body_File); Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); Put (Body_File, "return "); else Put (Body_File, " return "); end if; if Definition_Kind (Result_Profile (Node.Spec)) /= An_Access_Definition and then Is_Not_Null_Return (Node.Spec) then Put (Body_File, "not null "); end if; Put (Body_File, ASIS_Trim (Element_Image (Result_Profile (Node.Spec)))); end if; if Col (Body_File) + 3 > Ada.Wide_Text_IO.Count (Max_Body_Line_Length) then Change_Line := True; end if; end Generate_Profile; ----------------------------- -- Generate_Protected_Body -- ----------------------------- procedure Generate_Protected_Body (Node : Link) is begin Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "protected body " & Node.Spec_Name.all & " is"); New_Line (Body_File); if Node.Down = null then -- protected definition with no protected operation is somewhat -- strange, but legal case Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "end " & Node.Spec_Name.all & ";"); New_Line (Body_File); end if; end Generate_Protected_Body; ----------------------------- -- Generate_Separate_Stubs -- ----------------------------- procedure Generate_Separate_Stubs (Body_Unit : Asis.Compilation_Unit) is CU_Kind : constant Unit_Kinds := Unit_Kind (Body_Unit); Unit : Asis.Element; function Get_Subunit_Name (Def_Name : Asis.Element) return String; -- Creates the name for the file where the subunit should be located -- using the template created from the argument body name. function Get_Subunit_Name (Def_Name : Asis.Element) return String is Def_Name_Image : String := (To_String (Defining_Name_Image (Def_Name))); begin case Subunit_Name_Casing is when Lowercase => Def_Name_Image := To_Lower (Def_Name_Image); when Uppercase => Def_Name_Image := To_Upper (Def_Name_Image); when Mixedcase => Def_Name_Image := Capitalize (Def_Name_Image); end case; return Subunit_Name_Temlate (First_Idx .. Insert_Idx) & Def_Name_Image & Subunit_Name_Temlate (Insert_Idx + 1 .. Last_Idx); end Get_Subunit_Name; begin if CU_Kind not in A_Procedure_Body | A_Function_Body | A_Package_Body | A_Procedure_Body_Subunit | A_Function_Body_Subunit | A_Package_Body_Subunit | A_Task_Body_Subunit | A_Protected_Body_Subunit then Error ("argument unit cannot have subunits (" & Capitalize (CU_Kind'Img) & ")"); return; end if; Unit := Unit_Declaration (Body_Unit); declare Dcls : constant Asis.Element_List := (if Declaration_Kind (Unit) = A_Protected_Body_Declaration then Protected_Operation_Items (Unit) else Body_Declarative_Items (Unit)); Body_El : Asis.Element; Stub_Dcl : Asis.Element; Def_Name : Asis.Element; Success : Boolean; My_Control : Traverse_Control := Continue; My_State : Body_State; begin for J in Dcls'Range loop if Declaration_Kind (Dcls (J)) in A_Body_Stub then Body_El := Corresponding_Subunit (Dcls (J)); Def_Name := First_Name (Dcls (J)); if not Is_Nil (Body_El) then goto Continue; else Body_Name := new String'(Get_Subunit_Name (Def_Name)); end if; if GNAT.OS_Lib.Is_Regular_File (Body_Name.all) then if not Quiet_Mode then Put_Line (Current_Error, "separate body is not created for stub for " & Defining_Name_Image (Def_Name)); Put_Line (Current_Error, " file " & To_Wide_String (Body_Name.all) & "already exists"); end if; Free (Body_Name); goto Continue; end if; begin Create (Body_File, Out_File, Body_Name.all, Body_Form.all); exception when others => Error ("cannot create file " & Body_Name.all & " for subunit"); goto Continue; end; Stub_Dcl := Corresponding_Declaration (Dcls (J)); if Is_Nil (Stub_Dcl) then -- Body stub acts as a spec Stub_Dcl := Dcls (J); end if; Body_Structure.Spec_Name := new Program_Text'(Unit_Full_Name (Body_Unit)); -- We need this because Generate_CU_Header takes the -- compilation unit name from Body_Structure Generate_CU_Header (Success, For_Subunit => True, Subunit_Name => Def_Name); Put_Line (Body_File, "pragma Ada_2012;"); Put_Line (Body_File, "separate (" & Body_Structure.Spec_Name.all & ')'); Free (Body_Structure.Spec_Name); My_State := Initial_State; Create_Body_Structure ( Element => Stub_Dcl, Control => My_Control, State => My_State); Generate_Body_Structure; Free_Body_Structure; Close (Body_File); Free (Body_Name); if not Quiet_Mode then Put_Line (Current_Error, "separate body is created for stub for " & Defining_Name_Image (Def_Name)); end if; end if; <> end loop; end; end Generate_Separate_Stubs; ------------------------ -- Generate_Task_Body -- ------------------------ procedure Generate_Task_Body (Node : Link) is begin Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "task body " & Node.Spec_Name.all & " is"); Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "begin"); Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); Put_Line (Body_File, "-- Generated stub: replace with real body!"); Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); Put_Line (Body_File, "pragma Compile_Time_Warning (Standard.True, """ & To_Wide_String (To_String (Node.Spec_Name.all)) & " unimplemented"");"); Set_Col (Body_File, Positive_Count (1 + (Level + 1) * Indent_Level)); if No_Exception_In_Stubs then Put_Line (Body_File, "null;"); else Put (Body_File, "raise Program_Error"); if Opt.Ada_Version >= Ada_2005 then Put (Body_File, " with ""Unimplemented task " & To_Wide_String (To_String (Node.Spec_Name.all)) & '"'); end if; Put_Line (Body_File, ";"); end if; Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "end " & Node.Spec_Name.all & ";"); New_Line (Body_File); end Generate_Task_Body; -------------------------- -- Generate_Unit_Header -- -------------------------- procedure Generate_Unit_Header (Node : Link) is Header_Length : constant Natural := Node.Spec_Name'Length + 6; begin if not No_Local_Comment_Headers then Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, Header_Length * '-'); Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put (Body_File, "-- "); Put (Body_File, Node.Spec_Name.all); Put_Line (Body_File, " --"); Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, Header_Length * '-'); New_Line (Body_File); end if; end Generate_Unit_Header; ------------------- -- Get_Tree_Name -- ------------------- function Get_Tree_Name return String is Dot_Index : Natural := Short_File_Name'Last; begin for J in reverse Short_File_Name'Range loop if Short_File_Name (J) = '.' then Dot_Index := J - 1; exit; end if; end loop; return Short_File_Name (Short_File_Name'First .. Dot_Index) & ".adt"; end Get_Tree_Name; ----------- -- Go_Up -- ----------- procedure Go_Up (Element : Asis.Element; Control : in out Traverse_Control; State : in out Body_State) is pragma Unreferenced (Control); Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Element); begin if not (Arg_Kind = A_Package_Declaration or else Arg_Kind = A_Generic_Package_Declaration or else Arg_Kind = A_Single_Protected_Declaration or else Arg_Kind = A_Protected_Type_Declaration) then return; end if; if State.New_List_Needed then -- no local body is needed for a given construct State.New_List_Needed := False; else -- we have to reset the current list: if State.Current_List /= null then State.Current_List := State.Current_List.Up; while State.Current_List.Prev /= null loop State.Current_List := State.Current_List.Prev; end loop; end if; end if; end Go_Up; ----------------------- -- Image_For_String -- ----------------------- function Image_For_String (S : Program_Text) return Program_Text is begin if S (S'First) = '"' and then S (S'Last) = '"' then return '"' & S & '"'; else return S; end if; end Image_For_String; ---------------- -- Initialize -- ---------------- procedure Initialize is begin ASIS_UL.Environment.Scan_Parameters (Gnatstub_Prj); Gnatstub.Projects.Set_Tree_Creator (Gnatstub_Prj); Check_Parameters; Prepare_Context; Initialized := True; exception when others => Initialized := False; raise; end Initialize; ---------- -- Name -- ---------- function Name (El : Asis.Element) return Program_Text is Def_Name : constant Asis.Element := Names (El) (1); begin return Defining_Name_Image (Def_Name); end Name; -------------------------- -- Print_Gnatstub_Usage -- -------------------------- procedure Print_Gnatstub_Usage is begin Ada.Text_IO.Set_Error (Ada.Text_IO.Standard_Output); Brief_Help; New_Line; New_Line; Put_Line ("Report bugs to report@adacore.com"); end Print_Gnatstub_Usage; ------------------- -- Requires_Body -- ------------------- function Requires_Body (El : 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 => Result := Is_Nil (Corresponding_Type_Declaration (El)); 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. Result := not (not Is_Nil (Corresponding_Body (El)) or else Asis.Extensions.Is_Completed (El)); 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; end Gnatstub.Sampler;