libadalang_tools_24.0.0_d864b5a8/src/utils-command_lines.adb

------------------------------------------------------------------------------
--                                                                          --
--                             Libadalang Tools                             --
--                                                                          --
--                    Copyright (C) 2021-2022, AdaCore                      --
--                                                                          --
-- Libadalang Tools  is free software; you can redistribute it and/or modi- --
-- fy  it  under  terms of the  GNU General Public License  as published by --
-- the Free Software Foundation;  either version 3, or (at your option) any --
-- later version. This software  is distributed in the hope that it will be --
-- useful but  WITHOUT  ANY  WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY  or  FITNESS  FOR A PARTICULAR PURPOSE.                  --
--                                                                          --
-- As a special  exception  under  Section 7  of  GPL  version 3,  you are  --
-- granted additional  permissions described in the  GCC  Runtime  Library  --
-- Exception, version 3.1, as published by the Free Software Foundation.    --
--                                                                          --
-- You should have received a copy of the GNU General Public License and a  --
-- copy of the GCC Runtime Library Exception along with this program;  see  --
-- the files COPYING3 and COPYING.RUNTIME respectively.  If not, see        --
-- <http://www.gnu.org/licenses/>.                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line;
with Ada.Environment_Variables;
with Ada.Exceptions;
with Ada.Strings;             use Ada.Strings;
with Ada.Strings.Fixed;       use Ada.Strings.Fixed;
use Ada;
with Ada.Unchecked_Deallocation;

with GNAT.Command_Line;
--  We don't use most of the facilities of GNAT.Command_Line.
--  We use it mainly for the wildcard-expansion facility.

with Utils.Tool_Names;
with Utils.Strings; use Utils.Strings;
with Utils.String_Utilities;

package body Utils.Command_Lines is
   use Ada.Text_IO;

   ----------
   -- Copy --
   ----------

   function Copy (String_Refs : String_Ref_Vector)
                  return String_Ref_Vector is
   begin
      return Result : String_Ref_Vector do
         Result.Set_Length (String_Refs.Length);
         for J in Positive'First .. String_Refs.Last_Index loop
            if String_Refs (J) /= null then
               Result (J) := new String'(String_Refs (J).all);
            else
               Result (J) := null;
            end if;
         end loop;
      end return;
   end Copy;

   -------------
   -- Destroy --
   -------------

   procedure Destroy (Vector : in out String_Ref_Vector) is
   begin
      for Item of Vector loop
         if Item /= null then
            Free (Item);
         end if;
      end loop;

      Free (Vector);
   end Destroy;

   ----------
   -- Copy --
   ----------

   function Copy
     (Switch : Dynamically_Typed_Switch)
      return Dynamically_Typed_Switch is
   begin
      return Result : Dynamically_Typed_Switch := Switch do
         if Result.Text /= null then
            Result.Text := new String'(Result.Text.all);
         end if;
         case Result.Kind is
            when String_Switch =>
               if Result.String_Val /= null then
                  Result.String_Val := new String'(Result.String_Val.all);
               end if;
            when String_Seq_Switch =>
               Result.Seq_Val := Copy (Result.Seq_Val);
            when others =>
               null;
         end case;
      end return;
   end Copy;

   -------------
   -- Destroy --
   -------------

   procedure Destroy (Object : in out Dynamically_Typed_Switch) is
   begin
      if Object.Text /= null then
         Free (Object.Text);
      end if;
      case Object.Kind is
         when String_Switch =>
            if Object.String_Val /= null then
               Free (Object.String_Val);
            end if;
         when String_Seq_Switch =>
            Destroy (Object.Seq_Val);
         when others =>
            null;
      end case;
   end Destroy;

   ----------
   -- Copy --
   ----------

   function Copy
     (Switches : Dynamically_Typed_Switches)
      return Dynamically_Typed_Switches is
   begin
      return Result : Dynamically_Typed_Switches (Switches'Range) do
         for J in Result'First .. Result'Last loop
            Result (J) := Copy (Switches (J));
         end loop;
      end return;
   end Copy;

   ----------
   -- Copy --
   ----------

   procedure Destroy
     (Switches : in out Dynamically_Typed_Switches) is
   begin
      for J in Switches'First .. Switches'Last loop
         Destroy (Switches (J));
      end loop;
   end Destroy;

   procedure Free is new Ada.Unchecked_Deallocation (String, String_Ref);

   procedure Free is new Ada.Unchecked_Deallocation
     (Dynamically_Typed_Switches, Dynamically_Typed_Switches_Access);

   procedure Raise_Cmd_Error (Message : String) is
   begin
      raise Command_Line_Error with Message;
   end Raise_Cmd_Error;

   procedure Cmd_Error (Message : String) is
   begin
      Put (Standard_Error, Utils.Tool_Names.Tool_Name & ": ");
      Put_Line (Standard_Error, Message);
      raise Command_Line_Error with Message;
   end Cmd_Error;

   procedure Cmd_Error_No_Help (Message : String) is
   begin
      Put (Standard_Error, Utils.Tool_Names.Tool_Name & ": ");
      Put_Line (Standard_Error, Message);
      raise Command_Line_Error_No_Help with Message;
   end Cmd_Error_No_Help;

   procedure Cmd_Error_No_Tool_Name (Message : String) is
   begin
      Put_Line (Standard_Error, Message);
      raise Command_Line_Error_No_Tool_Name with Message;
   end Cmd_Error_No_Tool_Name;

   procedure Append_Text_Args_From_Command_Line
     (Tool_Package_Name : String; Args : in out String_Access_Vector)
   is
      use Ada.Command_Line;
      Cur : Positive := 1;
   begin
      while Cur <= Argument_Count loop
         --  We skip "-x ada", which is passed in by gprbuild. It is necessary
         --  to do that here, rather than during the command-line parsing,
         --  because gnatmetric uses the -x switch for something else.

         if Argument (Cur) = "-x"
           and then Cur < Argument_Count
           and then Argument (Cur + 1) = "ada"
         then
            Cur := Cur + 2;

         else
            Append (Args, new String'(Argument (Cur)));
            Cur := Cur + 1;
         end if;
      end loop;

      --  If environment variables of the form below exist, then take them to
      --  be arguments. This feature is for testing, so is not documented, and
      --  is not particularly friendly. It would be friendlier to have just one
      --  environment variable, with space-separated arguments, but that's
      --  harder to parse (consider quoting and whatnot).  We can add more of
      --  these if needed. Example: PRETTY_PRINTER_EXTRA_ARG_1.

      for N in 1 .. 8 loop
         declare
            use Environment_Variables, String_Utilities;
            Env_Var_Name : constant String :=
              To_Upper (Tool_Package_Name) & "_EXTRA_ARG_" & Image (N);
         begin
            if Exists (Env_Var_Name) then
               Append (Args, new String'(Value (Env_Var_Name)));
            end if;
         end;
      end loop;
   end Append_Text_Args_From_Command_Line;

   function Text_Args_From_Command_Line
     (Tool_Package_Name : String) return Argument_List_Access
   is
      Result : String_Access_Vector;
   begin
      Append_Text_Args_From_Command_Line (Tool_Package_Name, Result);
      return To_Argument_List_Access (Result);
   end Text_Args_From_Command_Line;

   generic
      type Switches is (<>);
   function Generic_Switch_Text (Switch : Switches) return String_Ref;

   generic
      type Switches is (<>);
   function Generic_Negated_Switch_Text (Switch : Switches) return String_Ref;

   function Generic_Switch_Text (Switch : Switches) return String_Ref is
   begin
      return +("--" & Dashes (To_Lower (Switches'Image (Switch))));
   end Generic_Switch_Text;

   function Generic_Negated_Switch_Text
     (Switch : Switches) return String_Ref
   is
   begin
      return +("--no-" & Dashes (To_Lower (Switches'Image (Switch))));
   end Generic_Negated_Switch_Text;

   function Error_Detected
     (Cmd : Command_Line) return Boolean is
     (Cmd.Error_Detected);

   --  Efficiency: Command_Line_Rec contains entries for all the short-hand
   --  switches, but those are never used.

   package body Flag_Switches is
      pragma Assert (Descriptor.Allowed_Switches = null);
      --  Assert that we're not adding switches after Freeze_Descriptor

      function Arg (Cmd : Command_Line; Switch : Switches) return Boolean is
      begin
         return Cmd.Sw (To_All (Switch)).Boolean_Val;
      end Arg;

      procedure Set_Arg
        (Cmd : in out Command_Line; Switch : Switches; Val : Boolean := True)
      is
      begin
         Cmd.Sw (To_All (Switch)).Boolean_Val := Val;
      end Set_Arg;

      function Explicit (Cmd : Command_Line; Switch : Switches) return Boolean
      is
        (Cmd.Sw (To_All (Switch)).Explicit);

      package body Set_Shorthands is
         pragma Assert (Descriptor.Allowed_Switches = null);
      begin
         for J in Shorthands'Range loop
            if Shorthands (J) /= null then
               pragma Assert (Shorthands (J) (1) = '-');
               Append
                 (Descriptor.Allowed_Switches_Vector,
                  Switch_Descriptor'
                    (Kind   => True_Switch,
                     Text   => Shorthands (J),
                     Alias  => To_All (J),
                     others => <>));
            end if;
         end loop;
      end Set_Shorthands;

      Base_Switch : constant All_Switches :=
        Last_Index (Descriptor.Allowed_Switches_Vector) + 1;

      function To_All
        (Switch : Switches) return All_Switches is
        (Base_Switch + Switches'Pos (Switch));

      function From_All
        (Switch : All_Switches) return Switches is
        (Switches'Val (Switch - Base_Switch));

      function Valid
        (Switch : All_Switches) return Boolean is
        (Switch in To_All (Switches'First) .. To_All (Switches'Last));

      function Switch_Text is new Generic_Switch_Text (Switches);

   begin
      for Switch in Switches loop
         Append
           (Descriptor.Allowed_Switches_Vector,
            Switch_Descriptor'
              (Kind   => True_Switch,
               Text   => Switch_Text (Switch),
               Alias  => To_All (Switch),
               others => <>));
      end loop;
   end Flag_Switches;

   package body Boolean_Switches is
      pragma Assert (Descriptor.Allowed_Switches = null);

      function Arg (Cmd : Command_Line; Switch : Switches) return Boolean is
      begin
         return Cmd.Sw (To_All (Switch)).Boolean_Val;
      end Arg;

      procedure Set_Arg
        (Cmd : in out Command_Line; Switch : Switches; Val : Boolean := True)
      is
      begin
         Cmd.Sw (To_All (Switch)).Boolean_Val := Val;
      end Set_Arg;

      function Explicit
        (Cmd : Command_Line; Switch : Switches) return Boolean is
      begin
         return Cmd.Sw (To_All (Switch)).Explicit;
      end Explicit;

      package body Set_Defaults is
         pragma Assert (Descriptor.Allowed_Switches = null);
      begin
         for J in Defaults'Range loop
            Descriptor.Allowed_Switches_Vector (To_All (J)).Default_Bool :=
              Defaults (J);
         end loop;
      end Set_Defaults;

      package body Set_Shorthands is
         pragma Assert (Descriptor.Allowed_Switches = null);
         After_Dashes : Natural := 0;
      begin
         for J in Shorthands'Range loop
            if Shorthands (J) /= null then
               if Shorthands (J) (1 .. 2) = "--" then
                  After_Dashes := 3;
               elsif Shorthands (J) (1 .. 1) = "-" then
                  After_Dashes := 2;
               else
                  pragma Assert (False);
               end if;

               Append
                 (Descriptor.Allowed_Switches_Vector,
                  Switch_Descriptor'
                    (Kind   => True_Switch,
                     Text   => Shorthands (J),
                     Alias  => To_All (J),
                     others => <>));

               Append
                 (Descriptor.Allowed_Switches_Vector,
                  Switch_Descriptor'
                    (Kind   => False_Switch,
                     Text   => new String'
                       ("--no-" &
                        Shorthands (J) (After_Dashes .. Shorthands (J)'Last)),
                       --  So if the shorthand is "--foo-bar" or "-foo-bar",
                       --  this is "--no-foo-bar".
                     Alias  => To_All (J),
                     others => <>));
            end if;
         end loop;
      end Set_Shorthands;

      Base_Switch : constant All_Switches :=
        Last_Index (Descriptor.Allowed_Switches_Vector) + 1;

      function To_All
        (Switch : Switches) return All_Switches is
        (Base_Switch + Switches'Pos (Switch));

      function From_All
        (Switch : All_Switches) return Switches is
        (Switches'Val (Switch - Base_Switch));

      function Valid
        (Switch : All_Switches) return Boolean is
        (Switch in To_All (Switches'First) .. To_All (Switches'Last));

      function Switch_Text is new Generic_Switch_Text (Switches);
      function Negated_Switch_Text is new Generic_Negated_Switch_Text
        (Switches);

   begin
      for Switch in Switches loop
         Append
           (Descriptor.Allowed_Switches_Vector,
            Switch_Descriptor'
              (Kind   => True_Switch,
               Text   => Switch_Text (Switch),
               Alias  => To_All (Switch),
               others => <>));
      end loop;

      for Switch in Switches loop
         Append
           (Descriptor.Allowed_Switches_Vector,
            Switch_Descriptor'
              (Kind   => False_Switch,
               Text   => Negated_Switch_Text (Switch),
               Alias  => To_All (Switch),
               others => <>));
      end loop;
   end Boolean_Switches;

   package body Enum_Switches is
      pragma Assert (Descriptor.Allowed_Switches = null);

      function Arg (Cmd : Command_Line) return Switches is
      begin
         return Result : Switches := Default do
            --  Default is Switches'First, which will be overwritten below if
            --  any of the switches were explicitly specified.

            for Switch in Switches loop
               if Cmd.Sw (To_All (Switch)).Position >
                 Cmd.Sw (To_All (Result)).Position
               then
                  Result := Switch;
               end if;
            end loop;
         end return;
      end Arg;

      procedure Set_Arg (Cmd : in out Command_Line; Switch : Switches) is
         Current_Setting : constant Switches := Arg (Cmd);
      begin
         --  Set the Position to one more than the position of the current
         --  switch setting. This will cause Arg (Cmd) to return Switch.

         Cmd.Sw (To_All (Switch)).Position :=
           Cmd.Sw (To_All (Current_Setting)).Position + 1;
      end Set_Arg;

      package body Set_Shorthands is
         pragma Assert (Descriptor.Allowed_Switches = null);
      begin
         for J in Shorthands'Range loop
            if Shorthands (J) /= null then
               pragma Assert (Shorthands (J) (1) = '-');
               Append
                 (Descriptor.Allowed_Switches_Vector,
                  Switch_Descriptor'
                    (Kind   => Enum_Switch,
                     Text   => Shorthands (J),
                     Alias  => To_All (J),
                     others => <>));
            end if;
         end loop;
      end Set_Shorthands;

      Base_Switch : constant All_Switches :=
        Last_Index (Descriptor.Allowed_Switches_Vector) + 1;

      function To_All
        (Switch : Switches) return All_Switches is
        (Base_Switch + Switches'Pos (Switch));

      function From_All
        (Switch : All_Switches) return Switches is
        (Switches'Val (Switch - Base_Switch));

      function Valid
        (Switch : All_Switches) return Boolean is
        (Switch in To_All (Switches'First) .. To_All (Switches'Last));

      function Switch_Text is new Generic_Switch_Text (Switches);

   begin
      for Switch in Switches loop
         Append
           (Descriptor.Allowed_Switches_Vector,
            Switch_Descriptor'
              (Kind   => Enum_Switch,
               Text   => Switch_Text (Switch),
               Alias  => To_All (Switch),
               others => <>));
      end loop;
   end Enum_Switches;

   package body String_Switches is
      pragma Assert (Descriptor.Allowed_Switches = null);

      function Arg (Cmd : Command_Line; Switch : Switches) return String_Ref is
      begin
         return Cmd.Sw (To_All (Switch)).String_Val;
      end Arg;

      procedure Set_Arg
        (Cmd : in out Command_Line; Switch : Switches; Val : String) is
      begin
         Cmd.Sw (To_All (Switch)).String_Val := new String'(Val);
      end Set_Arg;

      Set_Shorthands_Instantiated : Boolean := False;

      package body Set_Syntax is
         pragma Assert (Descriptor.Allowed_Switches = null);
         pragma Assert (not Set_Shorthands_Instantiated);
      begin
         for J in Syntax'Range loop
            Descriptor.Allowed_Switches_Vector (To_All (J)).Syntax :=
              Syntax (J);
         end loop;
      end Set_Syntax;

      package body Set_Defaults is
         pragma Assert (Descriptor.Allowed_Switches = null);
      begin
         for J in Defaults'Range loop
            Descriptor.Allowed_Switches_Vector (To_All (J)).Default :=
              Defaults (J);
         end loop;
      end Set_Defaults;

      package body Set_Shorthands is
         pragma Assert (Descriptor.Allowed_Switches = null);
      begin
         Set_Shorthands_Instantiated := True;

         for J in Shorthands'Range loop
            if Shorthands (J) /= null then
               pragma Assert (Shorthands (J) (1) = '-');
               Append
                 (Descriptor.Allowed_Switches_Vector,
                  Switch_Descriptor'
                    (Kind   => String_Switch,
                     Text   => Shorthands (J),
                     Alias  => To_All (J),
                     others => <>));
            end if;
         end loop;
      end Set_Shorthands;

      Base_Switch : constant All_Switches :=
        Last_Index (Descriptor.Allowed_Switches_Vector) + 1;

      function To_All
        (Switch : Switches) return All_Switches is
        (Base_Switch + Switches'Pos (Switch));

      function From_All
        (Switch : All_Switches) return Switches is
        (Switches'Val (Switch - Base_Switch));

      function Valid
        (Switch : All_Switches) return Boolean is
        (Switch in To_All (Switches'First) .. To_All (Switches'Last));

      function Switch_Text is new Generic_Switch_Text (Switches);

   begin
      for Switch in Switches loop
         Append
           (Descriptor.Allowed_Switches_Vector,
            Switch_Descriptor'
              (Kind   => String_Switch,
               Text   => Switch_Text (Switch),
               Alias  => To_All (Switch),
               others => <>));
      end loop;
   end String_Switches;

   package body String_Seq_Switches is
      pragma Assert (Descriptor.Allowed_Switches = null);

      function Arg
        (Cmd    : Command_Line;
         Switch : Switches) return String_Ref_Array
      is
      begin
         return To_Array (Cmd.Sw (To_All (Switch)).Seq_Val);
      end Arg;

      procedure Set_Arg
        (Cmd : in out Command_Line; Switch : Switches; Val : String_Ref_Array)
      is
      begin
         Clear (Cmd.Sw (To_All (Switch)).Seq_Val);
         Append (Cmd.Sw (To_All (Switch)).Seq_Val, Val);
      end Set_Arg;

      function Arg_Length
        (Cmd    : Command_Line;
         Switch : Switches) return Natural
      is
      begin
         return Last_Index (Cmd.Sw (To_All (Switch)).Seq_Val);
      end Arg_Length;

      Set_Shorthands_Instantiated : Boolean := False;

      package body Set_Syntax is
         pragma Assert (Descriptor.Allowed_Switches = null);
         pragma Assert (not Set_Shorthands_Instantiated);
      begin
         for J in Syntax'Range loop
            Descriptor.Allowed_Switches_Vector (To_All (J)).Syntax :=
              Syntax (J);
         end loop;
      end Set_Syntax;

      package body Set_Shorthands is
         pragma Assert (Descriptor.Allowed_Switches = null);
      begin
         Set_Shorthands_Instantiated := True;

         for J in Shorthands'Range loop
            if Shorthands (J) /= null then
               pragma Assert (Shorthands (J) (1) = '-');
               Append
                 (Descriptor.Allowed_Switches_Vector,
                  Switch_Descriptor'
                    (Kind   => String_Seq_Switch,
                     Text   => Shorthands (J),
                     Alias  => To_All (J),
                     others => <>));
            end if;
         end loop;
      end Set_Shorthands;

      Base_Switch : constant All_Switches :=
        Last_Index (Descriptor.Allowed_Switches_Vector) + 1;

      function To_All
        (Switch : Switches) return All_Switches is
        (Base_Switch + Switches'Pos (Switch));

      function From_All
        (Switch : All_Switches) return Switches is
        (Switches'Val (Switch - Base_Switch));

      function Valid
        (Switch : All_Switches) return Boolean is
        (Switch in To_All (Switches'First) .. To_All (Switches'Last));

      function Switch_Text is new Generic_Switch_Text (Switches);

   begin
      for Switch in Switches loop
         Append
           (Descriptor.Allowed_Switches_Vector,
            Switch_Descriptor'
              (Kind   => String_Seq_Switch,
               Text   => Switch_Text (Switch),
               Alias  => To_All (Switch),
               others => <>));
      end loop;
   end String_Seq_Switches;

   package body Other_Switches is
      pragma Assert (Descriptor.Allowed_Switches = null);

      function Arg (Cmd : Command_Line; Switch : Switches) return Arg_Type is
      begin
         return Value (Cmd.Sw (To_All (Switch)).String_Val.all);
         --  If the ".all" blows up because of a null pointer, that's because
         --  the client forgot to instantiate Set_Defaults to set defaults.
      end Arg;

      procedure Set_Arg
        (Cmd : in out Command_Line; Switch : Switches; Val : Arg_Type) is
         S : constant String := Image (Val);
      begin
         if Cmd.Sw (To_All (Switch)).String_Val = null
           or else Cmd.Sw (To_All (Switch)).String_Val.all /= S
         then
            Free (Cmd.Sw (To_All (Switch)).String_Val);
            Cmd.Sw (To_All (Switch)).String_Val := new String'(S);
         end if;
      end Set_Arg;

      function Explicit (Cmd : Command_Line; Switch : Switches) return Boolean
      is
        (Cmd.Sw (To_All (Switch)).Explicit);

      Set_Shorthands_Instantiated : Boolean := False;

      package body Set_Syntax is
         pragma Assert (Descriptor.Allowed_Switches = null);
         pragma Assert (not Set_Shorthands_Instantiated);
      begin
         for J in Syntax'Range loop
            Descriptor.Allowed_Switches_Vector (To_All (J)).Syntax :=
              Syntax (J);
         end loop;
      end Set_Syntax;

      package body Set_Defaults is
         pragma Assert (Descriptor.Allowed_Switches = null);
      begin
         for J in Defaults'Range loop
            Descriptor.Allowed_Switches_Vector (To_All (J)).Default :=
              +Image (Defaults (J));
         end loop;
      end Set_Defaults;

      package body Set_Shorthands is
         pragma Assert (Descriptor.Allowed_Switches = null);
      begin
         Set_Shorthands_Instantiated := True;

         for J in Shorthands'Range loop
            if Shorthands (J) /= null then
               pragma Assert (Shorthands (J) (1) = '-');
               Append
                 (Descriptor.Allowed_Switches_Vector,
                  Switch_Descriptor'
                    (Kind   => String_Switch,
                     Text   => Shorthands (J),
                     Alias  => To_All (J),
                     others => <>));
            end if;
         end loop;
      end Set_Shorthands;

      Base_Switch : constant All_Switches :=
        Last_Index (Descriptor.Allowed_Switches_Vector) + 1;

      function To_All
        (Switch : Switches) return All_Switches is
        (Base_Switch + Switches'Pos (Switch));

      function From_All
        (Switch : All_Switches) return Switches is
        (Switches'Val (Switch - Base_Switch));

      function Valid
        (Switch : All_Switches) return Boolean is
        (Switch in To_All (Switches'First) .. To_All (Switches'Last));

      function Switch_Text is new Generic_Switch_Text (Switches);

      procedure Validate (Text : String) is
      begin
         --  Value will raise Constraint_Error if Text is malformed. We don't
         --  want to just call it and throw away the result, because that might
         --  get optimized away. We also need to check that Value returns a
         --  value in Arg_Type; for example:
         --     Natural'Value
         --  can return a value outside Natural.

         if Value (Text) not in Arg_Type then
            raise Constraint_Error;
         end if;

      exception
         when Constraint_Error =>
            Raise_Cmd_Error ("Malformed argument: " & Text);
      end Validate;

   begin
      for Switch in Switches loop
         Append
           (Descriptor.Allowed_Switches_Vector,
            Switch_Descriptor'
              (Kind      => String_Switch,
               Text      => Switch_Text (Switch),
               Alias     => To_All (Switch),
               Validator => Validate_Access,
               others    => <>));
      end loop;
   end Other_Switches;

   package body Disable_Switches is
   begin
      pragma Assert (Descriptor.Allowed_Switches = null);
      --  Do this before Freeze_Descriptor

      for Switch of Disable loop
         Descriptor.Allowed_Switches_Vector (Switch).Enabled := False;
      end loop;
   end Disable_Switches;

   package body Freeze_Descriptor is
--      pragma Assert (Descriptor.Allowed_Switches = null);
      --  Don't call this twice. Commented out because of kludgery
      --  in Metrics.Command_Lines. We should move the freezing
      --  of common switches into Common. ????

      procedure Do_It (Descriptor : in out Command_Line_Descriptor);
      --  Do most of the work in a procedure so the debugger works.

      procedure Do_It (Descriptor : in out Command_Line_Descriptor) is
         OK : Boolean := True;
      begin
         --  Validate that the allowed switches make sense. We can't have two
         --  switches with the same name. We don't want to have one switch a
         --  prefix of another if one of them is a String_Switch, and the
         --  syntax is not '='. For example, if we allowed "--outputparm" and
         --  "--output-dirparm", then we can't tell whether the latter is
         --  "--output-dir" with parameter "parm", or "--output" with parameter
         --  "-dirparm".
         --
         --  However, there is are cases where we have to allow this sort of
         --  thing for compatibility reasons: gnatstub has a string switch
         --  -gnaty, which is a prefix of -gnatyo and -gnatyM. Hence the
         --  special case for -gnaty below. In this case, Text_To_Switch will
         --  return the longest one (e.g. -gnatyM123 is -gnatyM with an
         --  argument of 123).

         for Switch1 in Descriptor.Allowed_Switches'Range loop
            pragma Assert
              (Descriptor.Allowed_Switches (Switch1).Kind /= No_Such);

            for Switch2 in Descriptor.Allowed_Switches'Range loop
               if Switch1 /= Switch2
                 and then Enabled (Descriptor, Switch1)
                 and then Enabled (Descriptor, Switch2)
               then
                  declare
                     Desc1 :
                       Switch_Descriptor renames
                         Descriptor.Allowed_Switches (Switch1);
                     Desc2 :
                       Switch_Descriptor renames
                         Descriptor.Allowed_Switches (Switch2);
                  begin
                     if Desc1.Kind = Desc2.Kind
                       and then Desc1.Text.all = Desc2.Text.all
                     then
                        OK := False;
                        Put_Line
                          (Standard_Error, "duplicate " & Desc1.Text.all);
                     end if;

                     if Desc1.Kind in String_Switch | String_Seq_Switch
                       and then Syntax (Descriptor, Switch1) /= '='
                       and then Has_Prefix (Desc2.Text.all, Desc1.Text.all)
                       and then Desc1.Text.all /= "-gnaty"
                     then
                        OK := False;
                        Put_Line (Standard_Error, Desc1.Text.all &
                                    " is prefix of " & Desc2.Text.all);
                     end if;
                  end;
               end if;
            end loop;
         end loop;

         pragma Assert (OK);
      end Do_It;

   begin
      if Descriptor.Allowed_Switches = null then -- ???Replaces above assertion
         --  Switch over to using Allowed_Switches from Allowed_Switches_Vector

         Descriptor.Allowed_Switches :=
           new Switch_Descriptor_Array'
           (To_Array (Descriptor.Allowed_Switches_Vector));
         Free (Descriptor.Allowed_Switches_Vector);
         Do_It (Descriptor);
      end if;
   end Freeze_Descriptor;

   function Copy_Descriptor
     (Descriptor : Command_Line_Descriptor) return Command_Line_Descriptor is
   begin
      pragma Assert (Descriptor.Allowed_Switches /= null);
      pragma Assert (Is_Empty (Descriptor.Allowed_Switches_Vector));
      --  Assert that Freeze_Descriptor has been called

      return Result : Command_Line_Descriptor do
         Append
           (Result.Allowed_Switches_Vector,
            Descriptor.Allowed_Switches.all);
      end return;
   end Copy_Descriptor;

   ------------
   -- Adjust --
   ------------

   procedure Adjust (Object : in out Command_Line) is
   begin
      Object.File_Names := Copy (Object.File_Names);
      if Object.Sw /= null then
         Object.Sw := new Dynamically_Typed_Switches'(Copy (Object.Sw.all));
      end if;
   end Adjust;

   --------------
   -- Finalize --
   --------------

   procedure Finalize (Object : in out Command_Line) is
   begin
      Destroy (Object.File_Names);

      if Object.Sw /= null then
         Destroy (Object.Sw.all);
         Free (Object.Sw);
      end if;
   end Finalize;

   function Text_To_Switch
     (Descriptor : Command_Line_Descriptor;
      Text       : String) return All_Switches;
   function Text_To_Switch
     (Descriptor : Command_Line_Descriptor;
      Text       : String) return All_Switches
   is
      DT : constant String := Dashes (Text);
      Result : All_Switches := All_Switches'Last;
      --  This is used in case of a String_Switch or String_Seq_Switch that
      --  does not have '=' syntax. We want to choose the longest one.
      --  All_Switches'Last indicates this hasn't been set.
   begin
      for Switch in Descriptor.Allowed_Switches'Range loop
         if Enabled (Descriptor, Switch) then
            declare
               Desc :
                 Switch_Descriptor renames
                 Descriptor.Allowed_Switches (Switch);
            begin
               if DT = Desc.Text.all then
                  if not
                    (Desc.Kind in String_Switch | String_Seq_Switch
                     and then Syntax (Descriptor, Switch) = '!')
                  then
                     return Switch;
                  end if;

               elsif Has_Prefix (DT, Prefix => Desc.Text.all)
                 and then Desc.Kind in String_Switch | String_Seq_Switch
               then
                  case Syntax (Descriptor, Switch) is
                     when '=' =>
                        pragma Assert (DT'Length > Desc.Text'Length);
                        --  Otherwise it would have been equal, above

                        if DT (Desc.Text'Length + 1) = '=' then
                           return Switch;
                        end if;

                     when ':' | '!' | '?' =>
                        if Result = All_Switches'Last
                          or else Desc.Text'Length >
                            Descriptor.Allowed_Switches (Result).Text'Length
                        then
                           Result := Switch;
                        end if;
                  end case;
               end if;
            end;
         end if;
      end loop;

      if Result = All_Switches'Last then
         Raise_Cmd_Error ("invalid switch : " & Text);
      else
         return Result;
      end if;
   end Text_To_Switch;

   procedure Parse_Helper
     (Text_Args          :        Argument_List_Access;
      Cmd                : in out Command_Line;
      Phase              :        Parse_Phase;
      Callback           :        Parse_Callback;
      Collect_File_Names :        Boolean;
      Ignore_Errors      :        Boolean);
   --  This does the actual parsing work, after Parse has initialized things.

   procedure Parse_Helper
     (Text_Args          :        Argument_List_Access;
      Cmd                : in out Command_Line;
      Phase              :        Parse_Phase;
      Callback           :        Parse_Callback;
      Collect_File_Names :        Boolean;
      Ignore_Errors      :        Boolean)
   is
      Cur : Positive := 1;
      --  Points to current element of Text_Args

      procedure Bump;
      --  Move to next element of Text_Args

      procedure Bump is
      begin
         Cur                  := Cur + 1;
         Cmd.Current_Position := Cmd.Current_Position + 1;
      end Bump;

      procedure Parse_One_Switch;
      --  Parse one element, plus the next one in case that's the parameter of
      --  the current switch (as in "--switch arg").

      procedure Parse_One_Switch is
         Text : String renames Text_Args (Cur).all;
         pragma Assert (Text'First = 1);
         Descriptor : Command_Line_Descriptor renames Cmd.Descriptor.all;
         Switch : constant All_Switches := Text_To_Switch (Descriptor, Text);
         Allowed :
           String renames
           Descriptor.Allowed_Switches (Switch).Text.all;
         pragma Assert (Allowed'First = 1);
         Alias : constant All_Switches :=
           Descriptor.Allowed_Switches (Switch).Alias;
         pragma Assert (Descriptor.Allowed_Switches (Alias).Enabled);
         Dyn : Dynamically_Typed_Switch renames Cmd.Sw (Alias);
      begin
         Dyn.Text :=
           new String'(Descriptor.Allowed_Switches (Switch).Text.all);
         Dyn.Explicit := True;

         case Descriptor.Allowed_Switches (Switch).Kind is
            when No_Such =>
               raise Program_Error;

            when True_Switch =>
               Dyn.Boolean_Val := True;

            when False_Switch =>
               Dyn.Boolean_Val := False;

            when Enum_Switch =>
               Dyn.Position := Cmd.Current_Position + 1;

            when String_Switch | String_Seq_Switch =>
               --  Note that we allow the switch arg to be empty here, as in
               --  "output-dir=".
               declare
                  First : Positive;
               begin
                  --  The case of:
                  --
                  --     command --switch arg
                  --
                  --  or:
                  --
                  --     command --switch
                  --     (where the syntax is '?' and the arg is defaulted).

                  if Text = Allowed then
                     if Syntax (Descriptor, Switch) = '?' then
                        goto Use_Default;
                     end if;

                     Bump;
                     First := 1;

                     if Cur > Text_Args'Last then
                        Raise_Cmd_Error
                          ("missing switch parameter for: " & Text);
                     end if;

                  --  The case of:
                  --
                  --     command --switch=arg
                  --
                  --  or:
                  --
                  --     command --switcharg
                  --
                  --  Split out the "arg" part.

                  else
                     pragma Assert
                       (Has_Prefix
                          (Replace_String (Text, "_", "-"),
                           Prefix => Replace_String (Allowed, "_", "-")));

                     if Text (Allowed'Length + 1) = '=' then
                        First := Allowed'Length + 2;
                     else
                        First := Allowed'Length + 1;
                     end if;
                  end if;

                  declare
                     Arg :
                       String renames
                       Text_Args (Cur) (First .. Text_Args (Cur)'Last);
                     S : constant String (1 .. Arg'Length) := Arg;
                  --  Slide it to start at 1
                  begin
                     case Descriptor.Allowed_Switches (Switch).Kind is
                        when String_Switch =>
                           Descriptor.Allowed_Switches
                             (Descriptor.Allowed_Switches (Switch).Alias)
                               .Validator (S);
                           --  Call the Validator. This will call
                           --  Raise_Cmd_Error if the switch parameter
                           --  is malformed; Raise_Cmd_Error raises.

                           if Dyn.String_Val = null
                             or else Dyn.String_Val.all /= S
                           then
                              Free (Dyn.String_Val);
                              Dyn.String_Val := new String'(S);
                           end if;
                        when String_Seq_Switch =>
                           --  If the switch appears on the command line, we
                           --  don't want to duplicate it, so we skip the
                           --  Append in the Cmd_Line_2 phase. Currently, that
                           --  works for Debug, because order doesn't
                           --  matter. It works for Files, which comes from the
                           --  command line OR the project file. It works for
                           --  External_Variable, because those aren't allowed
                           --  in a project file. If there are any
                           --  String_Seq_Switches that should come from both,
                           --  and the command-line ones should come later,
                           --  then this needs to be adjusted.

                           case Phase is
                              when Cmd_Line_1 | Project_File =>
                                 Append (Dyn.Seq_Val, new String'(S));
                              when Cmd_Line_2 =>
                                 null;
                           end case;
                        when others =>
                           raise Program_Error;
                     end case;
                  end;

                  <<Use_Default>>
               end;
         end case;

         if Callback /= null then
            Callback (Phase, Dyn);
         end if;
      end Parse_One_Switch;

   begin
      while Cur <= Text_Args'Last loop
         if Text_Args (Cur) (1) = '-' then -- Is it a switch?
            begin
               Parse_One_Switch;
            exception
               when X : Command_Line_Error =>
                  Cmd.Error_Detected := True;
                  --  This works, event though we're about to raise, because
                  --  Cmd is a pointer.

                  if not Ignore_Errors then
                     Put_Line (Standard_Error, Utils.Tool_Names.Tool_Name &
                                  ": " & Exceptions.Exception_Message (X));
                     raise;
                  end if;
            end;

         elsif Collect_File_Names then
            declare
               --  We expand wildcards here. This is necessary on Windows, and
               --  harmless elsewhere. But we don't want to expand wildcards
               --  unless the argument actually contains wildcard characters,
               --  because we might be in the wrong directory (sources are
               --  interpreted w.r.t. project file directory), or the argument
               --  might not refer to file(s) (e.g. "-U main" where the file
               --  is main.adb).

               Has_Wildcards : constant Boolean :=
                 (for some C of Text_Args (Cur).all => C in '*' | '?' | '[');

               use GNAT.Command_Line;
               It : Expansion_Iterator;
            begin
               if Has_Wildcards then
                  Start_Expansion (It, Text_Args (Cur).all);
                  loop
                     declare
                        X : constant String := Expansion (It);
                     begin
                        exit when X = "";
                        Append (Cmd.File_Names, new String'(X));
                     end;
                  end loop;

               --  No wildcards:

               else
                  Append (Cmd.File_Names, String_Ref (Text_Args (Cur)));
               end if;
            end;
         end if;

         Bump;
      end loop;
   end Parse_Helper;

   procedure Parse
     (Text_Args          :        Argument_List_Access;
      Cmd                : in out Command_Line;
      Phase              :        Parse_Phase;
      Callback           :        Parse_Callback;
      Collect_File_Names :        Boolean;
      Ignore_Errors      :        Boolean := False)
   is
      Descriptor : Command_Line_Descriptor renames Cmd.Descriptor.all;
   begin
      pragma Assert (Descriptor.Allowed_Switches /= null);
      --  Assert that Freeze_Descriptor has been called

      --  First time Parse is called for this particular Cmd object. Fill
      --  in the default values for all allowed switches.

      if Cmd.Sw = null then
         Cmd.Sw :=
           new Dynamically_Typed_Switches (Descriptor.Allowed_Switches'Range);

         for Switch in Descriptor.Allowed_Switches'Range loop
            --  Skip shorthands and negated switches

            if Descriptor.Allowed_Switches (Switch).Alias = Switch then
               case Descriptor.Allowed_Switches (Switch).Kind is
                  when No_Such | False_Switch =>
                     raise Program_Error;

                  when True_Switch =>
                     Cmd.Sw (Switch) :=
                       (True_Switch,
                        Switch,
                        Text        => null,
                        Explicit => False,
                        Boolean_Val =>
                          Descriptor.Allowed_Switches (Switch).Default_Bool);

                  when Enum_Switch =>
                     Cmd.Sw (Switch) :=
                       (Enum_Switch, Switch,
                        Text => null,
                        Explicit => False,
                        Position => 0);

                  when String_Switch =>
                     Cmd.Sw (Switch) :=
                       (String_Switch,
                        Switch,
                        Text       => null,
                        Explicit => False,
                        String_Val =>
                          (if Descriptor.Allowed_Switches
                               (Switch).Default = null
                           then null
                           else new String'(Descriptor.Allowed_Switches
                              (Switch).Default.all)));

                  when String_Seq_Switch =>
                     Cmd.Sw (Switch) :=
                       (String_Seq_Switch,
                        Switch,
                        Text    => null,
                        Explicit => False,
                        Seq_Val => String_Ref_Vectors.Empty_Vector);
               end case;
            end if;
         end loop;
      end if;

      --  Finally, parse the Text_Args into Cmd

      Parse_Helper
        (Text_Args,
         Cmd,
         Phase,
         Callback,
         Collect_File_Names,
         Ignore_Errors);
   end Parse;

   function File_Name_Is_Less_Than (Left, Right : String_Ref) return Boolean;
   --  Assuming that L and R are file names compares them as follows:
   --
   --  * if L and/or R contains a directory separator, compares
   --    lexicographicaly parts that follow the rightmost directory separator.
   --    If these parts are equal, compares L and R lexicographicaly
   --
   --  * otherwise compares L and R lexicographicaly
   --
   --  Comparisons are case-sensitive.

   package Sorting is new String_Ref_Vectors.Generic_Sorting
     (File_Name_Is_Less_Than);

   ----------------------------
   -- File_Name_Is_Less_Than --
   ----------------------------

   function File_Name_Is_Less_Than (Left, Right : String_Ref) return Boolean is
      L : String renames Left.all;
      R : String renames Right.all;

      L_Last : constant Natural := L'Last;
      R_Last : constant Natural := R'Last;

      L_Dir_Separator : Natural :=
        Index (L, [1 => Directory_Separator], Backward);

      R_Dir_Separator : Natural :=
        Index (R, [1 => Directory_Separator], Backward);

   begin
      if L_Dir_Separator = 0 and then R_Dir_Separator = 0 then
         return L < R;
      end if;

      if L_Dir_Separator = 0 then
         L_Dir_Separator := L'First;
      end if;

      if R_Dir_Separator = 0 then
         R_Dir_Separator := R'First;
      end if;

      if L (L_Dir_Separator .. L_Last) = R (R_Dir_Separator .. R_Last) then
         return L < R;
      else
         return L (L_Dir_Separator .. L_Last) < R (R_Dir_Separator .. R_Last);
      end if;
   end File_Name_Is_Less_Than;

   procedure Sort_File_Names (Cmd : in out Command_Line) is
   begin
      Sorting.Sort (Cmd.File_Names);
   end Sort_File_Names;

   procedure Clear_File_Names (Cmd : in out Command_Line) is
   begin
      Clear (Cmd.File_Names);
   end Clear_File_Names;

   procedure Append_File_Name (Cmd : in out Command_Line; Name : String) is
      Slide : constant String (1 .. Name'Length) := Name;
   begin
      Append (Cmd.File_Names, new String'(Slide));
   end Append_File_Name;

   function File_Names (Cmd : Command_Line) return String_Ref_Array is
   begin
      return To_Array (Cmd.File_Names);
   end File_Names;

   function Num_File_Names (Cmd : Command_Line) return Natural is
   begin
      return Last_Index (Cmd.File_Names);
   end Num_File_Names;

   procedure Iter_File_Names
     (Cmd    : in out Command_Line;
      Action :    not null access procedure (File_Name : in out String_Ref))
   is
   begin
      for File_Name of Cmd.File_Names loop
         Action (File_Name);
      end loop;
   end Iter_File_Names;

   function Switch_Text
     (Descriptor : Command_Line_Descriptor;
      Switch     : All_Switches) return String_Ref
   is
   begin
      return Descriptor.Allowed_Switches (Switch).Text;
   end Switch_Text;

   procedure Dump_Cmd (Cmd : Command_Line; Verbose : Boolean := False) is
      Descriptor : Command_Line_Descriptor renames Cmd.Descriptor.all;
      Sw : Dynamically_Typed_Switches renames Cmd.Sw.all;
   begin
      if Is_Empty (Cmd.File_Names) then
         Put_Line ("No file names");
      else
         Put ("file names:");

         for Name of Cmd.File_Names loop
            Put (" " & Name.all);
         end loop;

         Put_Line ("");
      end if;

      for Switch in Sw'Range loop
         --  Skip shorthands and negated switches

         if Descriptor.Allowed_Switches (Switch).Alias = Switch then
            --  If not Verbose, skip defaulted switches

            if not Verbose then
               case Sw (Switch).Kind is
                  when No_Such | False_Switch =>
                     raise Program_Error;
                  when True_Switch =>
                     if Sw (Switch).Boolean_Val =
                       Descriptor.Allowed_Switches (Switch).Default_Bool
                     then
                        goto Continue;
                     end if;
                  when Enum_Switch =>
                     null; -- Too much trouble to determine default here
                  when String_Switch =>
                     if Sw (Switch).String_Val = null then
                        --  This means that
                        --     Descriptor.Allowed_Switches (Switch).Default
                        --  is null as well: we can continue
                        goto Continue;
                     end if;
                     if Descriptor.Allowed_Switches (Switch).Default /= null
                       and then
                         Sw (Switch).String_Val.all =
                         Descriptor.Allowed_Switches (Switch).Default.all
                     then
                        goto Continue;
                     end if;
                  when String_Seq_Switch =>
                     if Last_Index (Sw (Switch).Seq_Val) = 0 then
                        goto Continue;
                     end if;
               end case;
            end if;

            Put
              (Descriptor.Allowed_Switches (Switch).Text.all &
               ": " &
               Sw (Switch).Kind'Img &
               " := ");

            case Sw (Switch).Kind is
               when No_Such | False_Switch =>
                  raise Program_Error;
               when True_Switch =>
                  Put (if Sw (Switch).Boolean_Val then "True" else "False");
               when Enum_Switch =>
                  Put ("at" & Sw (Switch).Position'Img);
               when String_Switch =>
                  if Sw (Switch).String_Val = null then
                     Put ("null");
                  else
                     Put ("""" & Sw (Switch).String_Val.all & """");
                  end if;
               when String_Seq_Switch =>
                  Put ("(");
                  declare
                     First_Time : Boolean := True;
                  begin
                     for S of To_Array (Sw (Switch).Seq_Val) loop
                        if First_Time then
                           First_Time := False;
                        else
                           Put (", ");
                        end if;
                        Put ("""" & S.all & """");
                     end loop;
                  end;
                  Put (")");
            end case;

            Put_Line ("");
         end if;
         <<Continue>>
      end loop;
   end Dump_Cmd;

   procedure Dump_Descriptor (Descriptor : Command_Line_Descriptor) is
      pragma Assert (Descriptor.Allowed_Switches /= null);
      pragma Assert (Is_Empty (Descriptor.Allowed_Switches_Vector));
      --  Assert that Freeze_Descriptor has been called
   begin
      for J in Descriptor.Allowed_Switches'Range loop
         declare
            X : Switch_Descriptor renames Descriptor.Allowed_Switches (J);
            S : constant String :=
              (if X.Kind in String_Switch | String_Seq_Switch then
                 Syntax (Descriptor, J)'Img
               else
                  "");
         begin
            Put_Line
              (J'Img &
                 " " & X.Kind'Img &
                 S &
                 " " & X.Text.all &
                 (if X.Alias = J then "" else X.Alias'Img) &
                 " " & (if X.Enabled then "" else " DISABLED"));
         end;
      end loop;
   end Dump_Descriptor;

end Utils.Command_Lines;