------------------------------------------------------------------------------
-- --
-- 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 <Argv>"
-- 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 <type_mark>:
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;
syntax highlighted by Code2HTML, v. 0.9.1