------------------------------------------------------------------------------ -- -- -- GNATSTUB COMPONENTS -- -- -- -- G N A T S T U B . S A M P L E R -- -- -- -- B o d y -- -- -- -- $Revision: 1.23 $ -- -- -- Copyright (c) 1997-2002, Free Software Foundation, Inc. -- -- -- -- Gnatstub 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. Gnatstub is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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, 59 Temple Place Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- Gnatstub is distributed as a part of the ASIS implementation for GNAT -- -- (ASIS-for-GNAT). -- -- -- -- 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 Ada Core Technologies Inc -- -- (http://www.gnat.com). -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; with Ada.Exceptions; use Ada.Exceptions; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Command_Line; use Ada.Command_Line; with Ada.Strings; use Ada.Strings; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Unchecked_Deallocation; with GNAT.OS_Lib; use GNAT.OS_Lib; with Gnatstub.Options; use Gnatstub.Options; with Asis; use Asis; with Asis.Exceptions; use Asis.Exceptions; with Asis.Errors; use Asis.Errors; 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.Implementation; use Asis.Implementation; with Asis.Text; use Asis.Text; with Asis.Iterator; use Asis.Iterator; with Asis.Extensions.Flat_Kinds; use Asis.Extensions.Flat_Kinds; with A4G.GNAT_Int; use A4G.GNAT_Int; package body Gnatstub.Sampler is Parameter_Error : exception; Level : Integer := 0; -- nesting level of a spec being processed Body_File : File_Type; Tree_File : File_Type; Spec_File : File_Type; Form : String := ""; ----------------------- -- Local subprograms -- ----------------------- procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr); procedure Make_Unit_Name (CU_Name : in out String); -- converts the file name (without extension) into a unit name -- by replacing '-' by '.' procedure Scan_Gnatstub_Arg (Argv : String); -- Scan gnatstub arguments. Argv is a single argument to be processed. -- If an argument is illegal, generates the diagnostic message and -- raises Parameter_Error 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 Create_Tree; -- Creates a tree file or checks if the tree file already exists, -- depending on options procedure Unknown_Option (Argv : String); -- Output the giagnosis of the form "gnatstub : unknown option " -- and raises Parameter_Error type Element_Node; type Link is access all Element_Node; type Element_Node is record Spec : Asis.Element := Nil_Element; Spec_Name : String_Access; -- not used for incomplete type declarations Up : Link; Down : Link; Prev : Link; Next : Link; end record; -- an element of a dynamic structure representing a "skeleton" of the body\ -- to be generated Body_Structure : aliased Element_Node; -- 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. ------------------------------------------------- -- 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; procedure Create_Element_Node (Element : in 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 : in 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 String; -- 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); -- Generates in Body_File the comment header for the sample body. Sets -- Success to True if the comment header is successfully generated procedure Generate_Unit_Header (Node : Link); -- Generates the comment header for a local program unit body 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 Gernerate_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_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; ---------------------- -- Bodyless_Package -- ---------------------- function Bodyless_Package (Node : Link) return Boolean is Result : Boolean := False; Arg_Kind : 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 Put_Line ("Usage: gnatstub [opts] filename [directory]"); Put_Line (""); Put_Line (" filename source file"); Put (" directory directory to place a sample body"); Put_Line (" (default is the current directory)"); Put_Line (""); Put_Line ("gnatstub options:"); Put_Line (""); Put_Line (" -f replace an existing body file (if any) with " & "a body sample"); Put_Line (" -hs put in body sample the comment header " & "from the spec"); Put_Line (" -hg put in body sample a sample comment header"); Put_Line (" -Idir source search dir, has the same meaning as for " & "gcc and gnatmake"); Put_Line (" -I- do not look for the sources in the default " & "directory"); Put_Line (" -in (n in 1 .. 9) number of spaces used for identation " & "in a sample body"); Put_Line (" -k do not remove the tree file"); Put_Line (" -ln (n in 60 .. 999) maximum line length " & "in a sample body"); Put_Line (" -q quiet mode - do not confirm creating a body"); Put_Line (" -r reuse the tree file (if any) instead of " & "creating it"); Put_Line (" (-r also implies -k)"); Put_Line (" -t overwrite the existing tree file"); Put_Line (" -v verbose mode - output the version information"); end Brief_Help; ---------------------- -- Check_Parameters -- ---------------------- procedure Check_Parameters is Ind : Integer; I_Len : Natural; Next_Dir_Start : Natural := 2; Next_Dir_End : Natural := 2; -- "2 is because of the leading ' ' " begin -- Check that the argument file follows the GNAT file name conventions: File_Name_Len := File_Name'Length; File_Name_First := File_Name'First; File_Name_Last := File_Name'Last; if not (File_Name_Len >= 5 and then File_Name (File_Name_Last - 3 .. File_Name_Last) = ".ads") then Put_Line ("gnatstub: " & File_Name.all & " is not a name of a spec file"); raise Parameter_Error; end if; -- checking if the file to process really exists: if not Is_Regular_File (File_Name.all) then Put_Line ("gnatstub: cannot find " & File_Name.all); raise Parameter_Error; end if; -- if destination is set, check if the destination directory exists: if Destination_Dir /= null then if not Is_Directory (Destination_Dir.all) then Put_Line ("gnatstub: " & Destination_Dir.all & " does not exist"); raise Parameter_Error; end if; end if; -- and now, we have to compute some names before continuing checking: Ind := File_Name_First; for I in reverse File_Name_First .. File_Name_Last loop if File_Name (I) = Directory_Separator then Ind := I + 1; exit; end if; end loop; Short_File_Name := new String'(File_Name (Ind .. File_Name_Last)); 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 Destination_Dir = null 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'; -- checking if a body already exists: if Is_Regular_File (Body_Name.all) then if Overwrite_Body then Open (Body_File, Out_File, Body_Name.all, Form); Delete (Body_File); else Put_Line ("gnatstub: the body for " & File_Name.all & " already exists"); Put_Line (" use -f to overwrite it"); raise Parameter_Error; end if; end if; -- now, checking the situation with the tree file: Tree_Name := new String'(Short_File_Name.all); Tree_Name (Tree_Name'Last) := 't'; Tree_Name (Tree_Name'Last - 1) := 'd'; Tree_Name (Tree_Name'Last - 2) := 'a'; if Is_Regular_File (Tree_Name.all) then Tree_Exists := True; if not (Reuse_Tree or else Overwrite_Tree) then Put_Line ("gnatstub: " & Tree_Name.all & " already exists"); Put_Line (" use -r or -t to reuse or to overwrite it"); raise Parameter_Error; end if; else if Reuse_Tree then Put_Line ("gnatstub: cannot find " & 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; -- now, converting '-I' options from a string into argument list if Dir_Count = 0 then Arg_List := new Argument_List (1 .. 0); else Arg_List := new Argument_List (1 .. Dir_Count); I_Len := I_Options'Length; for I in 1 .. Dir_Count loop while (Next_Dir_End <= I_Len and then I_Options (Next_Dir_End) /= ' ') loop Next_Dir_End := Next_Dir_End + 1; end loop; Next_Dir_End := Next_Dir_End - 1; Arg_List (I) := new String'(I_Options (Next_Dir_Start .. Next_Dir_End)); Next_Dir_Start := Next_Dir_End + 2; Next_Dir_End := Next_Dir_Start; end loop; end if; -- Cleaning up - freeing what we will not need any more Free (Destination_Dir); Free (I_Options); Free (I_Options_Tmp); 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, Form); Delete (Tree_File); -- Deleting the ALI file which was created along with the tree file -- We use the modifyed Tree_Name for this, because we do not need -- Tree_Name any more Tree_Name (Tree_Name'Last - 2 .. Tree_Name'Last) := "ali"; Open (Tree_File, In_File, Tree_Name.all, Form); Delete (Tree_File); end if; end Clean_Up; ------------------------- -- Create_Element_Node -- ------------------------- procedure Create_Element_Node (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Body_State) is Arg_Kind : 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 String'(Name (El)); if State.New_List_Needed then -- here we have to let 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; 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 = An_Incomplete_Type_Declaration then -- no need for alphabetical ordering, inserting in the -- very beginning: New_Node.Next := State.Current_List; State.Current_List.Prev := New_Node; State.Current_List := New_Node; else Next_Node := State.Current_List; -- finding the right place in the current list loop if Flat_Element_Kind (Next_Node.Spec) = An_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 (New_Node.Spec_Name.all) < To_Lower (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; -- 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; 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 String'(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 My_Context : Asis.Context; CU : Asis.Compilation_Unit; CU_Kind : Unit_Kinds; CU_Name_Len : Positive := Short_File_Name_Len - 4; -- "- 4" stands for ".ads" CU_Name : String (1 .. CU_Name_Len) := Short_File_Name.all (Short_File_Name_First .. Short_File_Name_Last - 4); My_Control : Traverse_Control := Continue; My_State : Body_State; Header_Created : Boolean; 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. procedure Emergency_Clean_Up is begin if Is_Open (My_Context) then Close (My_Context); end if; Dissociate (My_Context); 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; begin Asis.Implementation.Initialize; Associate (My_Context, "My_Context", "-C1 " & To_Wide_String (Tree_Name.all)); Open (My_Context); Make_Unit_Name (CU_Name); CU := Library_Unit_Declaration (To_Wide_String (CU_Name), My_Context); if Is_Nil (CU) then -- this may be the case if the file name for which gnatstub was -- krunched. This is the case for the GNAT RTL components. -- In this case we have to iterate through the context declare C_Units : Asis.Compilation_Unit_List := Asis.Compilation_Units.Compilation_Units (My_Context); begin -- to be 100% honest, we should go through C_Units list and -- to compare the result of Asis.Compilation_Units.Text_Name -- applied to a unit with File_Name. But here we use the -- fact, that in every tree a unit for which the tree is -- created is always processed first when ASIS opens a -- Context, and here in gnatstub we have C1 context. So -- the needed unit is the second in the list (just after Standard) if C_Units'Length > 1 then CU := C_Units (2); end if; end; end if; CU_Kind := Unit_Kind (CU); if Is_Nil (CU) then Put ("file " & Gnatstub.Options.File_Name.all); Put_Line (" does not contain a unit to create a body for"); return; elsif not (CU_Kind = A_Procedure or else CU_Kind = A_Function or else CU_Kind = A_Generic_Procedure or else CU_Kind = A_Generic_Function or else ((CU_Kind = A_Package or else CU_Kind = A_Generic_Package) and then Asis.Compilation_Units.Is_Body_Required (CU))) then if not Quiet_Mode then Put ("Compilation unit " & CU_Name); Put_Line (" does not require a body"); Put_Line (" Unit Kind: " & Unit_Kinds'Image (CU_Kind)); end if; return; else -- and here we have to do the job: Create (Body_File, Out_File, Body_Name.all, Form); 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 Generate_Body_Structure; Close (Body_File); if not Quiet_Mode then Put ("body is created for "); Put_Line (Gnatstub.Options.File_Name.all); end if; else Put ("gnatstub: failed to write the comment header"); Put_Line (" for the body for " & Gnatstub.Options.File_Name.all); end if; end if; Close (My_Context); Dissociate (My_Context); 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; if Asis.Implementation.Status = Asis.Errors.Use_Error and then Reuse_Tree and then Tree_Exists then Put_Line ("gnatstub: the tree you try to reuse may be obsolete"); Put_Line ("gnatstub: either recreate the tree file or do not use " & "-r option"); else Put ("Unexpected bug in "); Put_Gnatstub_Version; New_Line; Put (Exception_Name (Ex)); Put_Line (" raised"); Put ("gnatstub: ASIS Diagnosis is " & To_String (Asis.Implementation.Diagnosis)); New_Line; Put ("gnatstub: Status Value is "); Put_Line (Asis.Errors.Error_Kinds'Image (Asis.Implementation.Status)); New_Line; Put_Line ("Please report to report@gnat.com"); end if; Emergency_Clean_Up; when others => Emergency_Clean_Up; raise; end Create_Sample; ----------------- -- Create_Tree -- ----------------- procedure Create_Tree is Success : Boolean := False; begin if Tree_Exists and then Reuse_Tree then return; end if; Compile (File_Name, Arg_List.all, Success); if not Success then Put_Line ("gnatstub: cannot create the tree file for " & File_Name.all); raise Parameter_Error; else Tree_Exists := True; end if; end Create_Tree; ----------------------------- -- 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 : 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 /= An_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_Generic_Function_Declaration => Generate_Function_Body (Node); when A_Procedure_Declaration | A_Generic_Procedure_Declaration => Generate_Procedure_Body (Node); when An_Entry_Declaration => Gernerate_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 => Generate_Full_Type_Declaration (Node); when others => Put_Line ("gnatstub: unexpected element in the body structure"); raise Program_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 & ";"); New_Line (Body_File); end Print_Node_List; begin Print_Node (Body_Structure'Access); exception when Ex : others => Raise_Exception (Exception_Identity (Ex), "Generate_Body_Structure failed"); end Generate_Body_Structure; ------------------------ -- Generate_CU_Header -- ------------------------ procedure Generate_CU_Header (Success : out Boolean) is -- This local declarations are used to generate a sample comment -- header Unit_Name_Len : Positive := 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 : String := "B o d y"; Body_String_Len : Positive := Body_String'Length; -- This local declarations are used to copy a comment header from the -- argument spec Spec_File : File_Type; String_Buf : String (1 .. Max_Body_Line_Length + 1); Spec_Line_Len : Natural; Spec_String_Start : Natural; begin Success := False; if Header = Stand_Header then -- first, checking how (and if) we can fit the maximum line length: if Unit_Name_Len + 6 > Max_Body_Line_Length then Put_Line ("gnatstub: argument unit name is too long " & "to generate a comment header for the body"); Put_Line ("gnatstub: try to increase the maximum body " & "line length"); raise Parameter_Error; elsif (2 * Unit_Name_Len -1) + 6 > Max_Body_Line_Length then Name_With_Spaces := False; else Unit_Name_Len := 2 * Unit_Name_Len -1; 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; else Put (Body_File, To_Upper (Body_Structure.Spec_Name.all)); end if; Put_Line (Body_File, Right_Unit_Name_Spaces * ' ' & "--"); 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); elsif Header = From_Spec then Open (Spec_File, In_File, File_Name.all, ""); while not End_Of_File (Spec_File) loop Get_Line (Spec_File, String_Buf, Spec_Line_Len); exit when String_Buf (1 .. 2) /= "--"; if Spec_Line_Len > Max_Body_Line_Length then Put_Line ("gnatstub: too long line in spec's comment header"); Put_Line ("gnatstub: try to increase " & "the maximum body line length"); Close (Spec_File); raise Parameter_Error; end if; Spec_String_Start := Index (Source => String_Buf (1 .. Spec_Line_Len), Pattern => "S p e c"); if Spec_String_Start /= 0 then Overwrite (Source => String_Buf (1 .. Spec_Line_Len), Position => Spec_String_Start, New_Item => "B o d y"); end if; Put_Line (Body_File, String_Buf (1 .. Spec_Line_Len)); end loop; Close (Spec_File); end if; Success := True; exception when Parameter_Error => -- We use Parameter_Error as a means to jump out of the sequence of -- statements which creates a header. It is not a real exception -- situation for a whole program. -- Here we have a body file opened. There is no need to keep this -- broken body: Delete (Body_File); when Ex : others => Raise_Exception (Exception_Identity (Ex), "Generate_CU_Header failed"); end Generate_CU_Header; -------------------------- -- Gernerate_Entry_Body -- -------------------------- procedure Gernerate_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 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, "null;"); Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); Put_Line (Body_File, "end " & Node.Spec_Name.all & ";"); New_Line (Body_File); end Gernerate_Entry_Body; ------------------------------------ -- Generate_Full_Type_Declaration -- ------------------------------------ procedure Generate_Full_Type_Declaration (Node : Link) is Discr_Part : Asis.Element := Discriminant_Part (Node.Spec); 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, Trim (To_String (Element_Image (Discr_Part)), Both) & " "); end if; Put_Line (Body_File, "is null record;"); New_Line (Body_File); end Generate_Full_Type_Declaration; ---------------------------- -- Generate_Function_Body -- ---------------------------- procedure Generate_Function_Body (Node : Link) is Change_Line : Boolean; Parameters : Asis.Element_List := Parameter_Profile (Node.Spec); First_Formal : Boolean := True; function Formals_To_Actuals (Formal_Names : Asis.Element_List) return String; -- this function returns a string of names of formal parameters -- separated with a comma, this list may be used as actuals in a -- dummy call to this function in the return statement which should -- be generated in the function body function Formals_To_Actuals (Formal_Names : Asis.Element_List) return String is begin if First_Formal then First_Formal := False; return To_String (Defining_Name_Image (Formal_Names (Formal_Names'First))) & Formals_To_Actuals (Formal_Names (Formal_Names'First + 1 .. Formal_Names'Last)); elsif Formal_Names'Length = 0 then return ""; else return ", " & To_String (Defining_Name_Image (Formal_Names (Formal_Names'First))) & Formals_To_Actuals (Formal_Names (Formal_Names'First + 1 .. Formal_Names'Last)); end if; end Formals_To_Actuals; begin Set_Col (Body_File, Positive_Count (1 + Level * Indent_Level)); 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; 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)); -- generating a dummy recursive call to itself: Put (Body_File, "return " & Node.Spec_Name.all); if Parameters'Length = 0 then Put_Line (Body_File, ";"); else Put (Body_File, " ("); for I in Parameters'Range loop Put (Body_File, Formals_To_Actuals (Names (Parameters (I)))); end loop; 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)); 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, "null;"); 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 : Flat_Element_Kinds := Flat_Element_Kind (Node.Spec); Spec_Span : Span; Parameters : Asis.Element_List := Parameter_Profile (Node.Spec); 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, Trim (To_String (Element_Image (Family_Def)), Both)); 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 then -- 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, Trim (To_String (Element_Image (Parameters (I))), Both)); 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; Put (Body_File, Trim (To_String (Element_Image (Result_Profile (Node.Spec))), Both)); end if; if Col (Body_File) + 3 > Ada.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_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, "null;"); 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 : Natural := Node.Spec_Name'Length + 6; begin 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 Generate_Unit_Header; ----------- -- Go_Up -- ----------- procedure Go_Up (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Body_State) is pragma Unreferenced (Control); Arg_Kind : 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; ---------------- -- Initialize -- ---------------- procedure Initialize is Next_Arg : Positive := 1; begin -- First, scanning the command line parameters: while Next_Arg <= Argument_Count loop Scan_Gnatstub_Arg (Argument (Next_Arg)); Next_Arg := Next_Arg + 1; end loop; if Verbose_Mode then Put_Gnatstub_Version; New_Line; Put_Line ("Copyright 1997-2000, Free Software Foundation, Inc."); New_Line; end if; if Argument_Count = 0 or else File_Name = null then Brief_Help; -- Is_Initialized remains False here! else -- then, checking, that parameters are valid and that they -- corresponds to the situation in the file system Check_Parameters; Create_Tree; Initialized := True; end if; exception when Parameter_Error => Initialized := False; -- noting else to do! when others => Initialized := False; raise; end Initialize; -------------------- -- Make_Unit_Name -- -------------------- procedure Make_Unit_Name (CU_Name : in out String) is begin for I in CU_Name'Range loop if CU_Name (I) = '-' then CU_Name (I) := '.'; end if; end loop; end Make_Unit_Name; ---------- -- Name -- ---------- function Name (El : Asis.Element) return String is Def_Name : Asis.Element := Names (El) (1); Def_Name_String : String := To_String (Defining_Name_Image (Def_Name)); begin return Def_Name_String; end Name; -------------------------- -- Put_Gnatstub_Version -- -------------------------- procedure Put_Gnatstub_Version is begin Put ("GNATSTUB (built with "); Put (To_String (Asis.Implementation.ASIS_Implementor_Version)); Put (")"); end Put_Gnatstub_Version; ------------------- -- Requires_Body -- ------------------- function Requires_Body (El : Element) return Boolean is Arg_Kind : 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 => 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 implemements the temporary solution -- ??? for subprograms completed by pragmas Import. -- ??? it should be revised when Asis.ExtensionsIs_Completed -- ??? dets 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; ----------------------- -- Scan_Gnatstub_Arg -- ----------------------- procedure Scan_Gnatstub_Arg (Argv : String) is First : Integer := Argv'First; Len : Natural := Argv'Length; Switch_Parameter : Natural; function Get_Switch_Parameter (Val : String) return Natural; -- computes a natural parameter for switch from its string -- representation. Raises Parameter_Error if Val can not be considered -- as a string image of a natural number. This function supposes that -- Val is not an empty string. function Get_Switch_Parameter (Val : String) return Natural is Result : Natural := 0; begin for I in Val'Range loop if Val (I) not in '0' .. '9' then Put_Line ("gnatstub: wrong switch integer parameter " & Val); raise Parameter_Error; else Result := Result * 10 + Character'Pos (Val (I)) - Character'Pos ('0'); end if; end loop; return Result; end Get_Switch_Parameter; begin if Len = 0 then return; end if; if Argv (First) = '-' then if Len >= 2 then case Argv (First + 1) is when 'f' => if Argv = "-f" then Overwrite_Body := True; else Unknown_Option (Argv); end if; when 'h' => if Argv = "-hs" then Header := From_Spec; elsif Argv = "-hg" then Header := Stand_Header; else Unknown_Option (Argv); end if; when 'i' => if Len = 2 then Put_Line ("gnatstub: missed value for -i parameter"); raise Parameter_Error; end if; Switch_Parameter := Get_Switch_Parameter (Argv (First + 2 .. Argv'Last)); Indent_Level := Switch_Parameter; when 'k' => if Argv = "-k" then Delete_Tree := False; else Unknown_Option (Argv); end if; when 'l' => if Len = 2 then Put_Line ("gnatstub: missed value for -l parameter"); raise Parameter_Error; end if; Switch_Parameter := Get_Switch_Parameter (Argv (First + 2 .. Argv'Last)); if Switch_Parameter = 0 then Put ("gnatstub: body line length can not be 0 ("); Put (Argv); Put_Line (")"); raise Parameter_Error; else Max_Body_Line_Length := Switch_Parameter; end if; when 'q' => if Argv = "-q" then Quiet_Mode := True; else Unknown_Option (Argv); end if; when 'r' => if Argv = "-r" then Reuse_Tree := True; else Unknown_Option (Argv); end if; when 't' => if Argv = "-t" then Overwrite_Tree := True; else Unknown_Option (Argv); end if; when 'v' => if Argv = "-v" then Verbose_Mode := True; else Unknown_Option (Argv); end if; when 'I' => Free (I_Options_Tmp); I_Options_Tmp := new String'(I_Options.all & " " & Argv); Free (I_Options); I_Options := new String'(I_Options_Tmp.all); Dir_Count := Dir_Count + 1; when others => Unknown_Option (Argv); end case; else Unknown_Option (Argv); end if; else -- ether a file name or a destination if File_Name = null then File_Name := new String'(Argv); elsif Destination_Dir = null then Destination_Dir := new String'(Argv); else Put ("gnatstub: only one file name and at most one "); Put_Line ("destination directory are allowed"); raise Parameter_Error; end if; end if; end Scan_Gnatstub_Arg; -------------------- -- Unknown_Option -- -------------------- procedure Unknown_Option (Argv : String) is begin Put_Line ("gnatstub: unknown option " & Argv); raise Parameter_Error; end Unknown_Option; end Gnatstub.Sampler;