gcc/ada/g-comlin.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                    G N A T . C O M M A N D _ L I N E                     --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1999-2011, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- In particular,  you can freely  distribute your programs  built with the --
  23 -- GNAT Pro compiler, including any required library run-time units,  using --
  24 -- any licensing terms  of your choosing.  See the AdaCore Software License --
  25 -- for full details.                                                        --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Characters.Handling;    use Ada.Characters.Handling;
  33 with Ada.Strings.Unbounded;
  34 with Ada.Text_IO;                use Ada.Text_IO;
  35 with Ada.Unchecked_Deallocation;
  36
  37 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  38 with GNAT.OS_Lib;               use GNAT.OS_Lib;
  39
  40 package body GNAT.Command_Line is
  41
  42    package CL renames Ada.Command_Line;
  43
  44    type Switch_Parameter_Type is
  45      (Parameter_None,
  46       Parameter_With_Optional_Space,  --  ':' in getopt
  47       Parameter_With_Space_Or_Equal,  --  '=' in getopt
  48       Parameter_No_Space,             --  '!' in getopt
  49       Parameter_Optional);            --  '?' in getopt
  50
  51    procedure Set_Parameter
  52      (Variable : out Parameter_Type;
  53       Arg_Num  : Positive;
  54       First    : Positive;
  55       Last     : Positive;
  56       Extra    : Character := ASCII.NUL);
  57    pragma Inline (Set_Parameter);
  58    --  Set the parameter that will be returned by Parameter below
  59    --  Parameters need to be defined ???
  60
  61    function Goto_Next_Argument_In_Section (Parser : Opt_Parser) return Boolean;
  62    --  Go to the next argument on the command line. If we are at the end of
  63    --  the current section, we want to make sure there is no other identical
  64    --  section on the command line (there might be multiple instances of
  65    --  -largs). Returns True iff there is another argument.
  66
  67    function Get_File_Names_Case_Sensitive return Integer;
  68    pragma Import (C, Get_File_Names_Case_Sensitive,
  69                   "__gnat_get_file_names_case_sensitive");
  70
  71    File_Names_Case_Sensitive : constant Boolean :=
  72                                  Get_File_Names_Case_Sensitive /= 0;
  73
  74    procedure Canonical_Case_File_Name (S : in out String);
  75    --  Given a file name, converts it to canonical case form. For systems where
  76    --  file names are case sensitive, this procedure has no effect. If file
  77    --  names are not case sensitive (i.e. for example if you have the file
  78    --  "xyz.adb", you can refer to it as XYZ.adb or XyZ.AdB), then this call
  79    --  converts the given string to canonical all lower case form, so that two
  80    --  file names compare equal if they refer to the same file.
  81
  82    procedure Internal_Initialize_Option_Scan
  83      (Parser                   : Opt_Parser;
  84       Switch_Char              : Character;
  85       Stop_At_First_Non_Switch : Boolean;
  86       Section_Delimiters       : String);
  87    --  Initialize Parser, which must have been allocated already
  88
  89    function Argument (Parser : Opt_Parser; Index : Integer) return String;
  90    --  Return the index-th command line argument
  91
  92    procedure Find_Longest_Matching_Switch
  93      (Switches          : String;
  94       Arg               : String;
  95       Index_In_Switches : out Integer;
  96       Switch_Length     : out Integer;
  97       Param             : out Switch_Parameter_Type);
  98    --  Return the Longest switch from Switches that at least partially
  99    --  partially Arg. Index_In_Switches is set to 0 if none matches.
 100    --  What are other parameters??? in particular Param is not always set???
 101
 102    procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 103      (Argument_List, Argument_List_Access);
 104
 105    procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 106      (Command_Line_Configuration_Record, Command_Line_Configuration);
 107
 108    procedure Remove (Line : in out Argument_List_Access; Index : Integer);
 109    --  Remove a specific element from Line
 110
 111    procedure Add
 112      (Line   : in out Argument_List_Access;
 113       Str    : String_Access;
 114       Before : Boolean := False);
 115    --  Add a new element to Line. If Before is True, the item is inserted at
 116    --  the beginning, else it is appended.
 117
 118    procedure Add
 119      (Config : in out Command_Line_Configuration;
 120       Switch : Switch_Definition);
 121    procedure Add
 122      (Def   : in out Alias_Definitions_List;
 123       Alias : Alias_Definition);
 124    --  Add a new element to Def
 125
 126    procedure Initialize_Switch_Def
 127      (Def         : out Switch_Definition;
 128       Switch      : String := "";
 129       Long_Switch : String := "";
 130       Help        : String := "";
 131       Section     : String := "");
 132    --  Initialize [Def] with the contents of the other parameters.
 133    --  This also checks consistency of the switch parameters, and will raise
 134    --  Invalid_Switch if they do not match.
 135
 136    procedure Decompose_Switch
 137      (Switch         : String;
 138       Parameter_Type : out Switch_Parameter_Type;
 139       Switch_Last    : out Integer);
 140    --  Given a switch definition ("name:" for instance), extracts the type of
 141    --  parameter that is expected, and the name of the switch
 142
 143    function Can_Have_Parameter (S : String) return Boolean;
 144    --  True if S can have a parameter
 145
 146    function Require_Parameter (S : String) return Boolean;
 147    --  True if S requires a parameter
 148
 149    function Actual_Switch (S : String) return String;
 150    --  Remove any possible trailing '!', ':', '?' and '='
 151
 152    generic
 153       with procedure Callback
 154         (Simple_Switch : String;
 155          Separator     : String;
 156          Parameter     : String;
 157          Index         : Integer);  --  Index in Config.Switches, or -1
 158    procedure For_Each_Simple_Switch
 159      (Config    : Command_Line_Configuration;
 160       Section   : String;
 161       Switch    : String;
 162       Parameter : String  := "";
 163       Unalias   : Boolean := True);
 164    --  Breaks Switch into as simple switches as possible (expanding aliases and
 165    --  ungrouping common prefixes when possible), and call Callback for each of
 166    --  these.
 167
 168    procedure Sort_Sections
 169      (Line     : GNAT.OS_Lib.Argument_List_Access;
 170       Sections : GNAT.OS_Lib.Argument_List_Access;
 171       Params   : GNAT.OS_Lib.Argument_List_Access);
 172    --  Reorder the command line switches so that the switches belonging to a
 173    --  section are grouped together.
 174
 175    procedure Group_Switches
 176      (Cmd      : Command_Line;
 177       Result   : Argument_List_Access;
 178       Sections : Argument_List_Access;
 179       Params   : Argument_List_Access);
 180    --  Group switches with common prefixes whenever possible. Once they have
 181    --  been grouped, we also check items for possible aliasing.
 182
 183    procedure Alias_Switches
 184      (Cmd    : Command_Line;
 185       Result : Argument_List_Access;
 186       Params : Argument_List_Access);
 187    --  When possible, replace one or more switches by an alias, i.e. a shorter
 188    --  version.
 189
 190    function Looking_At
 191      (Type_Str  : String;
 192       Index     : Natural;
 193       Substring : String) return Boolean;
 194    --  Return True if the characters starting at Index in Type_Str are
 195    --  equivalent to Substring.
 196
 197    generic
 198       with function Callback (S : String; Index : Integer) return Boolean;
 199    procedure Foreach_Switch
 200      (Config   : Command_Line_Configuration;
 201       Section  : String);
 202    --  Iterate over all switches defined in Config, for a specific section.
 203    --  Index is set to the index in Config.Switches. Stop iterating when
 204    --  Callback returns False.
 205
 206    --------------
 207    -- Argument --
 208    --------------
 209
 210    function Argument (Parser : Opt_Parser; Index : Integer) return String is
 211    begin
 212       if Parser.Arguments /= null then
 213          return Parser.Arguments (Index + Parser.Arguments'First - 1).all;
 214       else
 215          return CL.Argument (Index);
 216       end if;
 217    end Argument;
 218
 219    ------------------------------
 220    -- Canonical_Case_File_Name --
 221    ------------------------------
 222
 223    procedure Canonical_Case_File_Name (S : in out String) is
 224    begin
 225       if not File_Names_Case_Sensitive then
 226          for J in S'Range loop
 227             if S (J) in 'A' .. 'Z' then
 228                S (J) := Character'Val
 229                           (Character'Pos (S (J)) +
 230                             (Character'Pos ('a') - Character'Pos ('A')));
 231             end if;
 232          end loop;
 233       end if;
 234    end Canonical_Case_File_Name;
 235
 236    ---------------
 237    -- Expansion --
 238    ---------------
 239
 240    function Expansion (Iterator : Expansion_Iterator) return String is
 241       type Pointer is access all Expansion_Iterator;
 242
 243       It   : constant Pointer := Iterator'Unrestricted_Access;
 244       S    : String (1 .. 1024);
 245       Last : Natural;
 246
 247       Current : Depth := It.Current_Depth;
 248       NL      : Positive;
 249
 250    begin
 251       --  It is assumed that a directory is opened at the current level.
 252       --  Otherwise GNAT.Directory_Operations.Directory_Error will be raised
 253       --  at the first call to Read.
 254
 255       loop
 256          Read (It.Levels (Current).Dir, S, Last);
 257
 258          --  If we have exhausted the directory, close it and go back one level
 259
 260          if Last = 0 then
 261             Close (It.Levels (Current).Dir);
 262
 263             --  If we are at level 1, we are finished; return an empty string
 264
 265             if Current = 1 then
 266                return String'(1 .. 0 => ' ');
 267
 268             --  Otherwise continue with the directory at the previous level
 269
 270             else
 271                Current := Current - 1;
 272                It.Current_Depth := Current;
 273             end if;
 274
 275          --  If this is a directory, that is neither "." or "..", attempt to
 276          --  go to the next level.
 277
 278          elsif Is_Directory
 279                  (It.Dir_Name (1 .. It.Levels (Current).Name_Last) &
 280                     S (1 .. Last))
 281              and then S (1 .. Last) /= "."
 282              and then S (1 .. Last) /= ".."
 283          then
 284             --  We can go to the next level only if we have not reached the
 285             --  maximum depth,
 286
 287             if Current < It.Maximum_Depth then
 288                NL := It.Levels (Current).Name_Last;
 289
 290                --  And if relative path of this new directory is not too long
 291
 292                if NL + Last + 1 < Max_Path_Length then
 293                   Current := Current + 1;
 294                   It.Current_Depth := Current;
 295                   It.Dir_Name (NL + 1 .. NL + Last) := S (1 .. Last);
 296                   NL := NL + Last + 1;
 297                   It.Dir_Name (NL) := Directory_Separator;
 298                   It.Levels (Current).Name_Last := NL;
 299                   Canonical_Case_File_Name (It.Dir_Name (1 .. NL));
 300
 301                   --  Open the new directory, and read from it
 302
 303                   GNAT.Directory_Operations.Open
 304                     (It.Levels (Current).Dir, It.Dir_Name (1 .. NL));
 305                end if;
 306             end if;
 307          end if;
 308
 309          --  Check the relative path against the pattern
 310
 311          --  Note that we try to match also against directory names, since
 312          --  clients of this function may expect to retrieve directories.
 313
 314          declare
 315             Name : String :=
 316                      It.Dir_Name (It.Start .. It.Levels (Current).Name_Last)
 317                        & S (1 .. Last);
 318
 319          begin
 320             Canonical_Case_File_Name (Name);
 321
 322             --  If it matches return the relative path
 323
 324             if GNAT.Regexp.Match (Name, Iterator.Regexp) then
 325                return Name;
 326             end if;
 327          end;
 328       end loop;
 329    end Expansion;
 330
 331    ---------------------
 332    -- Current_Section --
 333    ---------------------
 334
 335    function Current_Section
 336      (Parser : Opt_Parser := Command_Line_Parser) return String
 337    is
 338    begin
 339       if Parser.Current_Section = 1 then
 340          return "";
 341       end if;
 342
 343       for Index in reverse 1 .. Integer'Min (Parser.Current_Argument - 1,
 344                                              Parser.Section'Last)
 345       loop
 346          if Parser.Section (Index) = 0 then
 347             return Argument (Parser, Index);
 348          end if;
 349       end loop;
 350
 351       return "";
 352    end Current_Section;
 353
 354    -----------------
 355    -- Full_Switch --
 356    -----------------
 357
 358    function Full_Switch
 359      (Parser : Opt_Parser := Command_Line_Parser) return String
 360    is
 361    begin
 362       if Parser.The_Switch.Extra = ASCII.NUL then
 363          return Argument (Parser, Parser.The_Switch.Arg_Num)
 364            (Parser.The_Switch.First .. Parser.The_Switch.Last);
 365       else
 366          return Parser.The_Switch.Extra
 367            & Argument (Parser, Parser.The_Switch.Arg_Num)
 368            (Parser.The_Switch.First .. Parser.The_Switch.Last);
 369       end if;
 370    end Full_Switch;
 371
 372    ------------------
 373    -- Get_Argument --
 374    ------------------
 375
 376    function Get_Argument
 377      (Do_Expansion : Boolean    := False;
 378       Parser       : Opt_Parser := Command_Line_Parser) return String
 379    is
 380    begin
 381       if Parser.In_Expansion then
 382          declare
 383             S : constant String := Expansion (Parser.Expansion_It);
 384          begin
 385             if S'Length /= 0 then
 386                return S;
 387             else
 388                Parser.In_Expansion := False;
 389             end if;
 390          end;
 391       end if;
 392
 393       if Parser.Current_Argument > Parser.Arg_Count then
 394
 395          --  If this is the first time this function is called
 396
 397          if Parser.Current_Index = 1 then
 398             Parser.Current_Argument := 1;
 399             while Parser.Current_Argument <= Parser.Arg_Count
 400               and then Parser.Section (Parser.Current_Argument) /=
 401                                                       Parser.Current_Section
 402             loop
 403                Parser.Current_Argument := Parser.Current_Argument + 1;
 404             end loop;
 405
 406          else
 407             return String'(1 .. 0 => ' ');
 408          end if;
 409
 410       elsif Parser.Section (Parser.Current_Argument) = 0 then
 411          while Parser.Current_Argument <= Parser.Arg_Count
 412            and then Parser.Section (Parser.Current_Argument) /=
 413                                                       Parser.Current_Section
 414          loop
 415             Parser.Current_Argument := Parser.Current_Argument + 1;
 416          end loop;
 417       end if;
 418
 419       Parser.Current_Index := Integer'Last;
 420
 421       while Parser.Current_Argument <= Parser.Arg_Count
 422         and then Parser.Is_Switch (Parser.Current_Argument)
 423       loop
 424          Parser.Current_Argument := Parser.Current_Argument + 1;
 425       end loop;
 426
 427       if Parser.Current_Argument > Parser.Arg_Count then
 428          return String'(1 .. 0 => ' ');
 429       elsif Parser.Section (Parser.Current_Argument) = 0 then
 430          return Get_Argument (Do_Expansion);
 431       end if;
 432
 433       Parser.Current_Argument := Parser.Current_Argument + 1;
 434
 435       --  Could it be a file name with wild cards to expand?
 436
 437       if Do_Expansion then
 438          declare
 439             Arg   : constant String :=
 440                       Argument (Parser, Parser.Current_Argument - 1);
 441             Index : Positive;
 442
 443          begin
 444             Index := Arg'First;
 445             while Index <= Arg'Last loop
 446                if Arg (Index) = '*'
 447                  or else Arg (Index) = '?'
 448                  or else Arg (Index) = '['
 449                then
 450                   Parser.In_Expansion := True;
 451                   Start_Expansion (Parser.Expansion_It, Arg);
 452                   return Get_Argument (Do_Expansion);
 453                end if;
 454
 455                Index := Index + 1;
 456             end loop;
 457          end;
 458       end if;
 459
 460       return Argument (Parser, Parser.Current_Argument - 1);
 461    end Get_Argument;
 462
 463    ----------------------
 464    -- Decompose_Switch --
 465    ----------------------
 466
 467    procedure Decompose_Switch
 468      (Switch         : String;
 469       Parameter_Type : out Switch_Parameter_Type;
 470       Switch_Last    : out Integer)
 471    is
 472    begin
 473       if Switch = "" then
 474          Parameter_Type := Parameter_None;
 475          Switch_Last := Switch'Last;
 476          return;
 477       end if;
 478
 479       case Switch (Switch'Last) is
 480          when ':'    =>
 481             Parameter_Type := Parameter_With_Optional_Space;
 482             Switch_Last    := Switch'Last - 1;
 483          when '='    =>
 484             Parameter_Type := Parameter_With_Space_Or_Equal;
 485             Switch_Last    := Switch'Last - 1;
 486          when '!'    =>
 487             Parameter_Type := Parameter_No_Space;
 488             Switch_Last    := Switch'Last - 1;
 489          when '?'    =>
 490             Parameter_Type := Parameter_Optional;
 491             Switch_Last    := Switch'Last - 1;
 492          when others =>
 493             Parameter_Type := Parameter_None;
 494             Switch_Last    := Switch'Last;
 495       end case;
 496    end Decompose_Switch;
 497
 498    ----------------------------------
 499    -- Find_Longest_Matching_Switch --
 500    ----------------------------------
 501
 502    procedure Find_Longest_Matching_Switch
 503      (Switches          : String;
 504       Arg               : String;
 505       Index_In_Switches : out Integer;
 506       Switch_Length     : out Integer;
 507       Param             : out Switch_Parameter_Type)
 508    is
 509       Index  : Natural;
 510       Length : Natural := 1;
 511       Last   : Natural;
 512       P      : Switch_Parameter_Type;
 513
 514    begin
 515       Index_In_Switches := 0;
 516       Switch_Length     := 0;
 517
 518       --  Remove all leading spaces first to make sure that Index points
 519       --  at the start of the first switch.
 520
 521       Index := Switches'First;
 522       while Index <= Switches'Last and then Switches (Index) = ' ' loop
 523          Index := Index + 1;
 524       end loop;
 525
 526       while Index <= Switches'Last loop
 527
 528          --  Search the length of the parameter at this position in Switches
 529
 530          Length := Index;
 531          while Length <= Switches'Last
 532            and then Switches (Length) /= ' '
 533          loop
 534             Length := Length + 1;
 535          end loop;
 536
 537          --  Length now marks the separator after the current switch. Last will
 538          --  mark the last character of the name of the switch.
 539
 540          if Length = Index + 1 then
 541             P := Parameter_None;
 542             Last := Index;
 543          else
 544             Decompose_Switch (Switches (Index .. Length - 1), P, Last);
 545          end if;
 546
 547          --  If it is the one we searched, it may be a candidate
 548
 549          if Arg'First + Last - Index <= Arg'Last
 550            and then Switches (Index .. Last) =
 551                       Arg (Arg'First .. Arg'First + Last - Index)
 552            and then Last - Index + 1 > Switch_Length
 553          then
 554             Param             := P;
 555             Index_In_Switches := Index;
 556             Switch_Length     := Last - Index + 1;
 557          end if;
 558
 559          --  Look for the next switch in Switches
 560
 561          while Index <= Switches'Last
 562            and then Switches (Index) /= ' '
 563          loop
 564             Index := Index + 1;
 565          end loop;
 566
 567          Index := Index + 1;
 568       end loop;
 569    end Find_Longest_Matching_Switch;
 570
 571    ------------
 572    -- Getopt --
 573    ------------
 574
 575    function Getopt
 576      (Switches    : String;
 577       Concatenate : Boolean := True;
 578       Parser      : Opt_Parser := Command_Line_Parser) return Character
 579    is
 580       Dummy : Boolean;
 581       pragma Unreferenced (Dummy);
 582
 583    begin
 584       <<Restart>>
 585
 586       --  If we have finished parsing the current command line item (there
 587       --  might be multiple switches in a single item), then go to the next
 588       --  element.
 589
 590       if Parser.Current_Argument > Parser.Arg_Count
 591         or else (Parser.Current_Index >
 592                    Argument (Parser, Parser.Current_Argument)'Last
 593                  and then not Goto_Next_Argument_In_Section (Parser))
 594       then
 595          return ASCII.NUL;
 596       end if;
 597
 598       --  By default, the switch will not have a parameter
 599
 600       Parser.The_Parameter :=
 601         (Integer'Last, Integer'Last, Integer'Last - 1, ASCII.NUL);
 602       Parser.The_Separator := ASCII.NUL;
 603
 604       declare
 605          Arg            : constant String :=
 606                             Argument (Parser, Parser.Current_Argument);
 607          Index_Switches : Natural := 0;
 608          Max_Length     : Natural := 0;
 609          End_Index      : Natural;
 610          Param          : Switch_Parameter_Type;
 611       begin
 612          --  If we are on a new item, test if this might be a switch
 613
 614          if Parser.Current_Index = Arg'First then
 615             if Arg (Arg'First) /= Parser.Switch_Character then
 616
 617                --  If it isn't a switch, return it immediately. We also know it
 618                --  isn't the parameter to a previous switch, since that has
 619                --  already been handled.
 620
 621                if Switches (Switches'First) = '*' then
 622                   Set_Parameter
 623                     (Parser.The_Switch,
 624                      Arg_Num => Parser.Current_Argument,
 625                      First   => Arg'First,
 626                      Last    => Arg'Last);
 627                   Parser.Is_Switch (Parser.Current_Argument) := True;
 628                   Dummy := Goto_Next_Argument_In_Section (Parser);
 629                   return '*';
 630                end if;
 631
 632                if Parser.Stop_At_First then
 633                   Parser.Current_Argument := Positive'Last;
 634                   return ASCII.NUL;
 635
 636                elsif not Goto_Next_Argument_In_Section (Parser) then
 637                   return ASCII.NUL;
 638
 639                else
 640                   --  Recurse to get the next switch on the command line
 641
 642                   goto Restart;
 643                end if;
 644             end if;
 645
 646             --  We are on the first character of a new command line argument,
 647             --  which starts with Switch_Character. Further analysis is needed.
 648
 649             Parser.Current_Index := Parser.Current_Index + 1;
 650             Parser.Is_Switch (Parser.Current_Argument) := True;
 651          end if;
 652
 653          Find_Longest_Matching_Switch
 654            (Switches          => Switches,
 655             Arg               => Arg (Parser.Current_Index .. Arg'Last),
 656             Index_In_Switches => Index_Switches,
 657             Switch_Length     => Max_Length,
 658             Param             => Param);
 659
 660          --  If switch is not accepted, it is either invalid or is returned
 661          --  in the context of '*'.
 662
 663          if Index_Switches = 0 then
 664
 665             --  Depending on the value of Concatenate, the full switch is
 666             --  a single character or the rest of the argument.
 667
 668             End_Index :=
 669               (if Concatenate then Parser.Current_Index else Arg'Last);
 670
 671             if Switches (Switches'First) = '*' then
 672
 673                --  Always prepend the switch character, so that users know that
 674                --  this comes from a switch on the command line. This is
 675                --  especially important when Concatenate is False, since
 676                --  otherwise the current argument first character is lost.
 677
 678                if Parser.Section (Parser.Current_Argument) = 0 then
 679
 680                   --  A section transition should not be returned to the user
 681
 682                   Dummy := Goto_Next_Argument_In_Section (Parser);
 683                   goto Restart;
 684
 685                else
 686                   Set_Parameter
 687                     (Parser.The_Switch,
 688                      Arg_Num => Parser.Current_Argument,
 689                      First   => Parser.Current_Index,
 690                      Last    => Arg'Last,
 691                      Extra   => Parser.Switch_Character);
 692                   Parser.Is_Switch (Parser.Current_Argument) := True;
 693                   Dummy := Goto_Next_Argument_In_Section (Parser);
 694                   return '*';
 695                end if;
 696             end if;
 697
 698             Set_Parameter
 699               (Parser.The_Switch,
 700                Arg_Num => Parser.Current_Argument,
 701                First   => Parser.Current_Index,
 702                Last    => End_Index);
 703             Parser.Current_Index := End_Index + 1;
 704
 705             raise Invalid_Switch;
 706          end if;
 707
 708          End_Index := Parser.Current_Index + Max_Length - 1;
 709          Set_Parameter
 710            (Parser.The_Switch,
 711             Arg_Num => Parser.Current_Argument,
 712             First   => Parser.Current_Index,
 713             Last    => End_Index);
 714
 715          case Param is
 716             when Parameter_With_Optional_Space =>
 717                if End_Index < Arg'Last then
 718                   Set_Parameter
 719                     (Parser.The_Parameter,
 720                      Arg_Num => Parser.Current_Argument,
 721                      First   => End_Index + 1,
 722                      Last    => Arg'Last);
 723                   Dummy := Goto_Next_Argument_In_Section (Parser);
 724
 725                elsif Parser.Current_Argument < Parser.Arg_Count
 726                  and then Parser.Section (Parser.Current_Argument + 1) /= 0
 727                then
 728                   Parser.Current_Argument := Parser.Current_Argument + 1;
 729                   Parser.The_Separator := ' ';
 730                   Set_Parameter
 731                     (Parser.The_Parameter,
 732                      Arg_Num => Parser.Current_Argument,
 733                      First => Argument (Parser, Parser.Current_Argument)'First,
 734                      Last  => Argument (Parser, Parser.Current_Argument)'Last);
 735                   Parser.Is_Switch (Parser.Current_Argument) := True;
 736                   Dummy := Goto_Next_Argument_In_Section (Parser);
 737
 738                else
 739                   Parser.Current_Index := End_Index + 1;
 740                   raise Invalid_Parameter;
 741                end if;
 742
 743             when Parameter_With_Space_Or_Equal =>
 744
 745                --  If the switch is of the form <switch>=xxx
 746
 747                if End_Index < Arg'Last then
 748                   if Arg (End_Index + 1) = '='
 749                     and then End_Index + 1 < Arg'Last
 750                   then
 751                      Parser.The_Separator := '=';
 752                      Set_Parameter
 753                        (Parser.The_Parameter,
 754                         Arg_Num => Parser.Current_Argument,
 755                         First   => End_Index + 2,
 756                         Last    => Arg'Last);
 757                      Dummy := Goto_Next_Argument_In_Section (Parser);
 758
 759                   else
 760                      Parser.Current_Index := End_Index + 1;
 761                      raise Invalid_Parameter;
 762                   end if;
 763
 764                --  If the switch is of the form <switch> xxx
 765
 766                elsif Parser.Current_Argument < Parser.Arg_Count
 767                  and then Parser.Section (Parser.Current_Argument + 1) /= 0
 768                then
 769                   Parser.Current_Argument := Parser.Current_Argument + 1;
 770                   Parser.The_Separator := ' ';
 771                   Set_Parameter
 772                     (Parser.The_Parameter,
 773                      Arg_Num => Parser.Current_Argument,
 774                      First => Argument (Parser, Parser.Current_Argument)'First,
 775                      Last  => Argument (Parser, Parser.Current_Argument)'Last);
 776                   Parser.Is_Switch (Parser.Current_Argument) := True;
 777                   Dummy := Goto_Next_Argument_In_Section (Parser);
 778
 779                else
 780                   Parser.Current_Index := End_Index + 1;
 781                   raise Invalid_Parameter;
 782                end if;
 783
 784             when Parameter_No_Space =>
 785                if End_Index < Arg'Last then
 786                   Set_Parameter
 787                     (Parser.The_Parameter,
 788                      Arg_Num => Parser.Current_Argument,
 789                      First   => End_Index + 1,
 790                      Last    => Arg'Last);
 791                   Dummy := Goto_Next_Argument_In_Section (Parser);
 792
 793                else
 794                   Parser.Current_Index := End_Index + 1;
 795                   raise Invalid_Parameter;
 796                end if;
 797
 798             when Parameter_Optional =>
 799                if End_Index < Arg'Last then
 800                   Set_Parameter
 801                     (Parser.The_Parameter,
 802                      Arg_Num => Parser.Current_Argument,
 803                      First   => End_Index + 1,
 804                      Last    => Arg'Last);
 805                end if;
 806
 807                Dummy := Goto_Next_Argument_In_Section (Parser);
 808
 809             when Parameter_None =>
 810                if Concatenate or else End_Index = Arg'Last then
 811                   Parser.Current_Index := End_Index + 1;
 812
 813                else
 814                   --  If Concatenate is False and the full argument is not
 815                   --  recognized as a switch, this is an invalid switch.
 816
 817                   if Switches (Switches'First) = '*' then
 818                      Set_Parameter
 819                        (Parser.The_Switch,
 820                         Arg_Num => Parser.Current_Argument,
 821                         First   => Arg'First,
 822                         Last    => Arg'Last);
 823                      Parser.Is_Switch (Parser.Current_Argument) := True;
 824                      Dummy := Goto_Next_Argument_In_Section (Parser);
 825                      return '*';
 826                   end if;
 827
 828                   Set_Parameter
 829                     (Parser.The_Switch,
 830                      Arg_Num => Parser.Current_Argument,
 831                      First   => Parser.Current_Index,
 832                      Last    => Arg'Last);
 833                   Parser.Current_Index := Arg'Last + 1;
 834                   raise Invalid_Switch;
 835                end if;
 836          end case;
 837
 838          return Switches (Index_Switches);
 839       end;
 840    end Getopt;
 841
 842    -----------------------------------
 843    -- Goto_Next_Argument_In_Section --
 844    -----------------------------------
 845
 846    function Goto_Next_Argument_In_Section
 847      (Parser : Opt_Parser) return Boolean
 848    is
 849    begin
 850       Parser.Current_Argument := Parser.Current_Argument + 1;
 851
 852       if Parser.Current_Argument > Parser.Arg_Count
 853         or else Parser.Section (Parser.Current_Argument) = 0
 854       then
 855          loop
 856             Parser.Current_Argument := Parser.Current_Argument + 1;
 857
 858             if Parser.Current_Argument > Parser.Arg_Count then
 859                Parser.Current_Index := 1;
 860                return False;
 861             end if;
 862
 863             exit when Parser.Section (Parser.Current_Argument) =
 864                                                   Parser.Current_Section;
 865          end loop;
 866       end if;
 867
 868       Parser.Current_Index :=
 869         Argument (Parser, Parser.Current_Argument)'First;
 870
 871       return True;
 872    end Goto_Next_Argument_In_Section;
 873
 874    ------------------
 875    -- Goto_Section --
 876    ------------------
 877
 878    procedure Goto_Section
 879      (Name   : String := "";
 880       Parser : Opt_Parser := Command_Line_Parser)
 881    is
 882       Index : Integer;
 883
 884    begin
 885       Parser.In_Expansion := False;
 886
 887       if Name = "" then
 888          Parser.Current_Argument := 1;
 889          Parser.Current_Index    := 1;
 890          Parser.Current_Section  := 1;
 891          return;
 892       end if;
 893
 894       Index := 1;
 895       while Index <= Parser.Arg_Count loop
 896          if Parser.Section (Index) = 0
 897            and then Argument (Parser, Index) = Parser.Switch_Character & Name
 898          then
 899             Parser.Current_Argument := Index + 1;
 900             Parser.Current_Index    := 1;
 901
 902             if Parser.Current_Argument <= Parser.Arg_Count then
 903                Parser.Current_Section :=
 904                  Parser.Section (Parser.Current_Argument);
 905             end if;
 906
 907             --  Exit from loop if we have the start of another section
 908
 909             if Index = Parser.Section'Last
 910                or else Parser.Section (Index + 1) /= 0
 911             then
 912                return;
 913             end if;
 914          end if;
 915
 916          Index := Index + 1;
 917       end loop;
 918
 919       Parser.Current_Argument := Positive'Last;
 920       Parser.Current_Index := 2;   --  so that Get_Argument returns nothing
 921    end Goto_Section;
 922
 923    ----------------------------
 924    -- Initialize_Option_Scan --
 925    ----------------------------
 926
 927    procedure Initialize_Option_Scan
 928      (Switch_Char              : Character := '-';
 929       Stop_At_First_Non_Switch : Boolean   := False;
 930       Section_Delimiters       : String    := "")
 931    is
 932    begin
 933       Internal_Initialize_Option_Scan
 934         (Parser                   => Command_Line_Parser,
 935          Switch_Char              => Switch_Char,
 936          Stop_At_First_Non_Switch => Stop_At_First_Non_Switch,
 937          Section_Delimiters       => Section_Delimiters);
 938    end Initialize_Option_Scan;
 939
 940    ----------------------------
 941    -- Initialize_Option_Scan --
 942    ----------------------------
 943
 944    procedure Initialize_Option_Scan
 945      (Parser                   : out Opt_Parser;
 946       Command_Line             : GNAT.OS_Lib.Argument_List_Access;
 947       Switch_Char              : Character := '-';
 948       Stop_At_First_Non_Switch : Boolean := False;
 949       Section_Delimiters       : String := "")
 950    is
 951    begin
 952       Free (Parser);
 953
 954       if Command_Line = null then
 955          Parser := new Opt_Parser_Data (CL.Argument_Count);
 956          Internal_Initialize_Option_Scan
 957            (Parser                   => Parser,
 958             Switch_Char              => Switch_Char,
 959             Stop_At_First_Non_Switch => Stop_At_First_Non_Switch,
 960             Section_Delimiters       => Section_Delimiters);
 961       else
 962          Parser := new Opt_Parser_Data (Command_Line'Length);
 963          Parser.Arguments := Command_Line;
 964          Internal_Initialize_Option_Scan
 965            (Parser                   => Parser,
 966             Switch_Char              => Switch_Char,
 967             Stop_At_First_Non_Switch => Stop_At_First_Non_Switch,
 968             Section_Delimiters       => Section_Delimiters);
 969       end if;
 970    end Initialize_Option_Scan;
 971
 972    -------------------------------------
 973    -- Internal_Initialize_Option_Scan --
 974    -------------------------------------
 975
 976    procedure Internal_Initialize_Option_Scan
 977      (Parser                   : Opt_Parser;
 978       Switch_Char              : Character;
 979       Stop_At_First_Non_Switch : Boolean;
 980       Section_Delimiters       : String)
 981    is
 982       Section_Num     : Section_Number;
 983       Section_Index   : Integer;
 984       Last            : Integer;
 985       Delimiter_Found : Boolean;
 986
 987       Discard : Boolean;
 988       pragma Warnings (Off, Discard);
 989
 990    begin
 991       Parser.Current_Argument := 0;
 992       Parser.Current_Index    := 0;
 993       Parser.In_Expansion     := False;
 994       Parser.Switch_Character := Switch_Char;
 995       Parser.Stop_At_First    := Stop_At_First_Non_Switch;
 996       Parser.Section          := (others => 1);
 997
 998       --  If we are using sections, we have to preprocess the command line to
 999       --  delimit them. A section can be repeated, so we just give each item
1000       --  on the command line a section number
1001
1002       Section_Num   := 1;
1003       Section_Index := Section_Delimiters'First;
1004       while Section_Index <= Section_Delimiters'Last loop
1005          Last := Section_Index;
1006          while Last <= Section_Delimiters'Last
1007            and then Section_Delimiters (Last) /= ' '
1008          loop
1009             Last := Last + 1;
1010          end loop;
1011
1012          Delimiter_Found := False;
1013          Section_Num := Section_Num + 1;
1014
1015          for Index in 1 .. Parser.Arg_Count loop
1016             if Argument (Parser, Index)(1) = Parser.Switch_Character
1017               and then
1018                 Argument (Parser, Index) = Parser.Switch_Character &
1019                                              Section_Delimiters
1020                                                (Section_Index .. Last - 1)
1021             then
1022                Parser.Section (Index) := 0;
1023                Delimiter_Found := True;
1024
1025             elsif Parser.Section (Index) = 0 then
1026
1027                --  A previous section delimiter
1028
1029                Delimiter_Found := False;
1030
1031             elsif Delimiter_Found then
1032                Parser.Section (Index) := Section_Num;
1033             end if;
1034          end loop;
1035
1036          Section_Index := Last + 1;
1037          while Section_Index <= Section_Delimiters'Last
1038            and then Section_Delimiters (Section_Index) = ' '
1039          loop
1040             Section_Index := Section_Index + 1;
1041          end loop;
1042       end loop;
1043
1044       Discard := Goto_Next_Argument_In_Section (Parser);
1045    end Internal_Initialize_Option_Scan;
1046
1047    ---------------
1048    -- Parameter --
1049    ---------------
1050
1051    function Parameter
1052      (Parser : Opt_Parser := Command_Line_Parser) return String
1053    is
1054    begin
1055       if Parser.The_Parameter.First > Parser.The_Parameter.Last then
1056          return String'(1 .. 0 => ' ');
1057       else
1058          return Argument (Parser, Parser.The_Parameter.Arg_Num)
1059            (Parser.The_Parameter.First .. Parser.The_Parameter.Last);
1060       end if;
1061    end Parameter;
1062
1063    ---------------
1064    -- Separator --
1065    ---------------
1066
1067    function Separator
1068      (Parser : Opt_Parser := Command_Line_Parser) return Character
1069    is
1070    begin
1071       return Parser.The_Separator;
1072    end Separator;
1073
1074    -------------------
1075    -- Set_Parameter --
1076    -------------------
1077
1078    procedure Set_Parameter
1079      (Variable : out Parameter_Type;
1080       Arg_Num  : Positive;
1081       First    : Positive;
1082       Last     : Positive;
1083       Extra    : Character := ASCII.NUL)
1084    is
1085    begin
1086       Variable.Arg_Num := Arg_Num;
1087       Variable.First   := First;
1088       Variable.Last    := Last;
1089       Variable.Extra   := Extra;
1090    end Set_Parameter;
1091
1092    ---------------------
1093    -- Start_Expansion --
1094    ---------------------
1095
1096    procedure Start_Expansion
1097      (Iterator     : out Expansion_Iterator;
1098       Pattern      : String;
1099       Directory    : String := "";
1100       Basic_Regexp : Boolean := True)
1101    is
1102       Directory_Separator : Character;
1103       pragma Import (C, Directory_Separator, "__gnat_dir_separator");
1104
1105       First : Positive := Pattern'First;
1106       Pat   : String := Pattern;
1107
1108    begin
1109       Canonical_Case_File_Name (Pat);
1110       Iterator.Current_Depth := 1;
1111
1112       --  If Directory is unspecified, use the current directory ("./" or ".\")
1113
1114       if Directory = "" then
1115          Iterator.Dir_Name (1 .. 2) := "." & Directory_Separator;
1116          Iterator.Start := 3;
1117
1118       else
1119          Iterator.Dir_Name (1 .. Directory'Length) := Directory;
1120          Iterator.Start := Directory'Length + 1;
1121          Canonical_Case_File_Name (Iterator.Dir_Name (1 .. Directory'Length));
1122
1123          --  Make sure that the last character is a directory separator
1124
1125          if Directory (Directory'Last) /= Directory_Separator then
1126             Iterator.Dir_Name (Iterator.Start) := Directory_Separator;
1127             Iterator.Start := Iterator.Start + 1;
1128          end if;
1129       end if;
1130
1131       Iterator.Levels (1).Name_Last := Iterator.Start - 1;
1132
1133       --  Open the initial Directory, at depth 1
1134
1135       GNAT.Directory_Operations.Open
1136         (Iterator.Levels (1).Dir, Iterator.Dir_Name (1 .. Iterator.Start - 1));
1137
1138       --  If in the current directory and the pattern starts with "./" or ".\",
1139       --  drop the "./" or ".\" from the pattern.
1140
1141       if Directory = "" and then Pat'Length > 2
1142         and then Pat (Pat'First) = '.'
1143         and then Pat (Pat'First + 1) = Directory_Separator
1144       then
1145          First := Pat'First + 2;
1146       end if;
1147
1148       Iterator.Regexp :=
1149         GNAT.Regexp.Compile (Pat (First .. Pat'Last), Basic_Regexp, True);
1150
1151       Iterator.Maximum_Depth := 1;
1152
1153       --  Maximum_Depth is equal to 1 plus the number of directory separators
1154       --  in the pattern.
1155
1156       for Index in First .. Pat'Last loop
1157          if Pat (Index) = Directory_Separator then
1158             Iterator.Maximum_Depth := Iterator.Maximum_Depth + 1;
1159             exit when Iterator.Maximum_Depth = Max_Depth;
1160          end if;
1161       end loop;
1162    end Start_Expansion;
1163
1164    ----------
1165    -- Free --
1166    ----------
1167
1168    procedure Free (Parser : in out Opt_Parser) is
1169       procedure Unchecked_Free is new
1170         Ada.Unchecked_Deallocation (Opt_Parser_Data, Opt_Parser);
1171    begin
1172       if Parser /= null
1173         and then Parser /= Command_Line_Parser
1174       then
1175          Free (Parser.Arguments);
1176          Unchecked_Free (Parser);
1177       end if;
1178    end Free;
1179
1180    ------------------
1181    -- Define_Alias --
1182    ------------------
1183
1184    procedure Define_Alias
1185      (Config   : in out Command_Line_Configuration;
1186       Switch   : String;
1187       Expanded : String;
1188       Section  : String := "")
1189    is
1190       Def    : Alias_Definition;
1191    begin
1192       if Config = null then
1193          Config := new Command_Line_Configuration_Record;
1194       end if;
1195
1196       Def.Alias     := new String'(Switch);
1197       Def.Expansion := new String'(Expanded);
1198       Def.Section   := new String'(Section);
1199       Add (Config.Aliases, Def);
1200    end Define_Alias;
1201
1202    -------------------
1203    -- Define_Prefix --
1204    -------------------
1205
1206    procedure Define_Prefix
1207      (Config : in out Command_Line_Configuration;
1208       Prefix : String)
1209    is
1210    begin
1211       if Config = null then
1212          Config := new Command_Line_Configuration_Record;
1213       end if;
1214
1215       Add (Config.Prefixes, new String'(Prefix));
1216    end Define_Prefix;
1217
1218    ---------
1219    -- Add --
1220    ---------
1221
1222    procedure Add
1223      (Config : in out Command_Line_Configuration;
1224       Switch : Switch_Definition)
1225    is
1226       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
1227         (Switch_Definitions, Switch_Definitions_List);
1228
1229       Tmp : Switch_Definitions_List;
1230
1231    begin
1232       if Config = null then
1233          Config := new Command_Line_Configuration_Record;
1234       end if;
1235
1236       Tmp := Config.Switches;
1237
1238       if Tmp = null then
1239          Config.Switches := new Switch_Definitions (1 .. 1);
1240       else
1241          Config.Switches := new Switch_Definitions (1 .. Tmp'Length + 1);
1242          Config.Switches (1 .. Tmp'Length) := Tmp.all;
1243          Unchecked_Free (Tmp);
1244       end if;
1245
1246       if Switch.Switch /= null and then Switch.Switch.all = "*" then
1247          Config.Star_Switch := True;
1248       end if;
1249
1250       Config.Switches (Config.Switches'Last) := Switch;
1251    end Add;
1252
1253    ---------
1254    -- Add --
1255    ---------
1256
1257    procedure Add (Def : in out Alias_Definitions_List;
1258                   Alias : Alias_Definition)
1259    is
1260       procedure Unchecked_Free is new
1261         Ada.Unchecked_Deallocation
1262           (Alias_Definitions, Alias_Definitions_List);
1263
1264       Tmp : Alias_Definitions_List := Def;
1265
1266    begin
1267       if Tmp = null then
1268          Def := new Alias_Definitions (1 .. 1);
1269       else
1270          Def := new Alias_Definitions (1 .. Tmp'Length + 1);
1271          Def (1 .. Tmp'Length) := Tmp.all;
1272          Unchecked_Free (Tmp);
1273       end if;
1274
1275       Def (Def'Last) := Alias;
1276    end Add;
1277
1278    ---------------------------
1279    -- Initialize_Switch_Def --
1280    ---------------------------
1281
1282    procedure Initialize_Switch_Def
1283      (Def : out Switch_Definition;
1284       Switch      : String := "";
1285       Long_Switch : String := "";
1286       Help        : String := "";
1287       Section     : String := "")
1288    is
1289       P1, P2       : Switch_Parameter_Type := Parameter_None;
1290       Last1, Last2 : Integer;
1291
1292    begin
1293       if Switch /= "" then
1294          Def.Switch := new String'(Switch);
1295          Decompose_Switch (Switch, P1, Last1);
1296       end if;
1297
1298       if Long_Switch /= "" then
1299          Def.Long_Switch := new String'(Long_Switch);
1300          Decompose_Switch (Long_Switch, P2, Last2);
1301       end if;
1302
1303       if Switch /= "" and then Long_Switch /= "" then
1304          if (P1 = Parameter_None and then P2 /= P1)
1305            or else (P2 = Parameter_None and then P1 /= P2)
1306            or else (P1 = Parameter_Optional and then P2 /= P1)
1307            or else (P2 = Parameter_Optional and then P2 /= P1)
1308          then
1309             raise Invalid_Switch
1310               with "Inconsistent parameter types for "
1311                 & Switch & " and " & Long_Switch;
1312          end if;
1313       end if;
1314
1315       if Section /= "" then
1316          Def.Section := new String'(Section);
1317       end if;
1318
1319       if Help /= "" then
1320          Def.Help := new String'(Help);
1321       end if;
1322    end Initialize_Switch_Def;
1323
1324    -------------------
1325    -- Define_Switch --
1326    -------------------
1327
1328    procedure Define_Switch
1329      (Config      : in out Command_Line_Configuration;
1330       Switch      : String := "";
1331       Long_Switch : String := "";
1332       Help        : String := "";
1333       Section     : String := "")
1334    is
1335       Def : Switch_Definition;
1336    begin
1337       if Switch /= "" or else Long_Switch /= "" then
1338          Initialize_Switch_Def (Def, Switch, Long_Switch, Help, Section);
1339          Add (Config, Def);
1340       end if;
1341    end Define_Switch;
1342
1343    -------------------
1344    -- Define_Switch --
1345    -------------------
1346
1347    procedure Define_Switch
1348      (Config      : in out Command_Line_Configuration;
1349       Output      : access Boolean;
1350       Switch      : String := "";
1351       Long_Switch : String := "";
1352       Help        : String := "";
1353       Section     : String := "";
1354       Value       : Boolean := True)
1355    is
1356       Def : Switch_Definition (Switch_Boolean);
1357    begin
1358       if Switch /= "" or else Long_Switch /= "" then
1359          Initialize_Switch_Def (Def, Switch, Long_Switch, Help, Section);
1360          Def.Boolean_Output := Output.all'Unchecked_Access;
1361          Def.Boolean_Value  := Value;
1362          Add (Config, Def);
1363       end if;
1364    end Define_Switch;
1365
1366    -------------------
1367    -- Define_Switch --
1368    -------------------
1369
1370    procedure Define_Switch
1371      (Config      : in out Command_Line_Configuration;
1372       Output      : access Integer;
1373       Switch      : String := "";
1374       Long_Switch : String := "";
1375       Help        : String := "";
1376       Section     : String := "";
1377       Initial     : Integer := 0;
1378       Default     : Integer := 1)
1379    is
1380       Def : Switch_Definition (Switch_Integer);
1381    begin
1382       if Switch /= "" or else Long_Switch /= "" then
1383          Initialize_Switch_Def (Def, Switch, Long_Switch, Help, Section);
1384          Def.Integer_Output  := Output.all'Unchecked_Access;
1385          Def.Integer_Default := Default;
1386          Def.Integer_Initial := Initial;
1387          Add (Config, Def);
1388       end if;
1389    end Define_Switch;
1390
1391    -------------------
1392    -- Define_Switch --
1393    -------------------
1394
1395    procedure Define_Switch
1396      (Config      : in out Command_Line_Configuration;
1397       Output      : access GNAT.Strings.String_Access;
1398       Switch      : String := "";
1399       Long_Switch : String := "";
1400       Help        : String := "";
1401       Section     : String := "")
1402    is
1403       Def : Switch_Definition (Switch_String);
1404    begin
1405       if Switch /= "" or else Long_Switch /= "" then
1406          Initialize_Switch_Def (Def, Switch, Long_Switch, Help, Section);
1407          Def.String_Output  := Output.all'Unchecked_Access;
1408          Add (Config, Def);
1409       end if;
1410    end Define_Switch;
1411
1412    --------------------
1413    -- Define_Section --
1414    --------------------
1415
1416    procedure Define_Section
1417      (Config : in out Command_Line_Configuration;
1418       Section : String)
1419    is
1420    begin
1421       if Config = null then
1422          Config := new Command_Line_Configuration_Record;
1423       end if;
1424
1425       Add (Config.Sections, new String'(Section));
1426    end Define_Section;
1427
1428    --------------------
1429    -- Foreach_Switch --
1430    --------------------
1431
1432    procedure Foreach_Switch
1433      (Config   : Command_Line_Configuration;
1434       Section  : String)
1435    is
1436    begin
1437       if Config /= null and then Config.Switches /= null then
1438          for J in Config.Switches'Range loop
1439             if (Section = "" and then Config.Switches (J).Section = null)
1440               or else
1441                 (Config.Switches (J).Section /= null
1442                   and then Config.Switches (J).Section.all = Section)
1443             then
1444                exit when Config.Switches (J).Switch /= null
1445                  and then not Callback (Config.Switches (J).Switch.all, J);
1446
1447                exit when Config.Switches (J).Long_Switch /= null
1448                  and then
1449                    not Callback (Config.Switches (J).Long_Switch.all, J);
1450             end if;
1451          end loop;
1452       end if;
1453    end Foreach_Switch;
1454
1455    ------------------
1456    -- Get_Switches --
1457    ------------------
1458
1459    function Get_Switches
1460      (Config      : Command_Line_Configuration;
1461       Switch_Char : Character := '-';
1462       Section     : String := "") return String
1463    is
1464       Ret : Ada.Strings.Unbounded.Unbounded_String;
1465       use Ada.Strings.Unbounded;
1466
1467       function Add_Switch (S : String; Index : Integer) return Boolean;
1468       --  Add a switch to Ret
1469
1470       ----------------
1471       -- Add_Switch --
1472       ----------------
1473
1474       function Add_Switch (S : String; Index : Integer) return Boolean is
1475          pragma Unreferenced (Index);
1476       begin
1477          if S = "*" then
1478             Ret := "*" & Ret;  --  Always first
1479          elsif S (S'First) = Switch_Char then
1480             Append (Ret, " " & S (S'First + 1 .. S'Last));
1481          else
1482             Append (Ret, " " & S);
1483          end if;
1484
1485          return True;
1486       end Add_Switch;
1487
1488       Tmp : Boolean;
1489       pragma Unreferenced (Tmp);
1490
1491       procedure Foreach is new Foreach_Switch (Add_Switch);
1492
1493    --  Start of processing for Get_Switches
1494
1495    begin
1496       if Config = null then
1497          return "";
1498       end if;
1499
1500       Foreach (Config, Section => Section);
1501
1502       --  Adding relevant aliases
1503
1504       if Config.Aliases /= null then
1505          for A in Config.Aliases'Range loop
1506             if Config.Aliases (A).Section.all = Section then
1507                Tmp := Add_Switch (Config.Aliases (A).Alias.all, -1);
1508             end if;
1509          end loop;
1510       end if;
1511
1512       return To_String (Ret);
1513    end Get_Switches;
1514
1515    ------------------------
1516    -- Section_Delimiters --
1517    ------------------------
1518
1519    function Section_Delimiters
1520      (Config : Command_Line_Configuration) return String
1521    is
1522       use Ada.Strings.Unbounded;
1523       Result : Unbounded_String;
1524
1525    begin
1526       if Config /= null and then Config.Sections /= null then
1527          for S in Config.Sections'Range loop
1528             Append (Result, " " & Config.Sections (S).all);
1529          end loop;
1530       end if;
1531
1532       return To_String (Result);
1533    end Section_Delimiters;
1534
1535    -----------------------
1536    -- Set_Configuration --
1537    -----------------------
1538
1539    procedure Set_Configuration
1540      (Cmd    : in out Command_Line;
1541       Config : Command_Line_Configuration)
1542    is
1543    begin
1544       Cmd.Config := Config;
1545    end Set_Configuration;
1546
1547    -----------------------
1548    -- Get_Configuration --
1549    -----------------------
1550
1551    function Get_Configuration
1552      (Cmd : Command_Line) return Command_Line_Configuration
1553    is
1554    begin
1555       return Cmd.Config;
1556    end Get_Configuration;
1557
1558    ----------------------
1559    -- Set_Command_Line --
1560    ----------------------
1561
1562    procedure Set_Command_Line
1563      (Cmd                : in out Command_Line;
1564       Switches           : String;
1565       Getopt_Description : String := "";
1566       Switch_Char        : Character := '-')
1567    is
1568       Tmp     : Argument_List_Access;
1569       Parser  : Opt_Parser;
1570       S       : Character;
1571       Section : String_Access := null;
1572
1573       function Real_Full_Switch
1574         (S      : Character;
1575          Parser : Opt_Parser) return String;
1576       --  Ensure that the returned switch value contains the
1577       --  Switch_Char prefix if needed.
1578
1579       ----------------------
1580       -- Real_Full_Switch --
1581       ----------------------
1582
1583       function Real_Full_Switch
1584         (S      : Character;
1585          Parser : Opt_Parser) return String
1586       is
1587       begin
1588          if S = '*' then
1589             return Full_Switch (Parser);
1590          else
1591             return Switch_Char & Full_Switch (Parser);
1592          end if;
1593       end Real_Full_Switch;
1594
1595    --  Start of processing for Set_Command_Line
1596
1597    begin
1598       Free (Cmd.Expanded);
1599       Free (Cmd.Params);
1600
1601       if Switches /= "" then
1602          Tmp := Argument_String_To_List (Switches);
1603          Initialize_Option_Scan (Parser, Tmp, Switch_Char);
1604
1605          loop
1606             begin
1607                if Cmd.Config /= null then
1608
1609                   --  Do not use Getopt_Description in this case. Otherwise,
1610                   --  if we have defined a prefix -gnaty, and two switches
1611                   --  -gnatya and -gnatyL!, we would have a different behavior
1612                   --  depending on the order of switches:
1613
1614                   --      -gnatyL1a   =>  -gnatyL with argument "1a"
1615                   --      -gnatyaL1   =>  -gnatya and -gnatyL with argument "1"
1616
1617                   --  This is because the call to Getopt below knows nothing
1618                   --  about prefixes, and in the first case finds a valid
1619                   --  switch with arguments, so returns it without analyzing
1620                   --  the argument. In the second case, the switch matches "*",
1621                   --  and is then decomposed below.
1622
1623                   S := Getopt (Switches    => "*",
1624                                Concatenate => False,
1625                                Parser      => Parser);
1626
1627                else
1628                   S := Getopt (Switches    => "* " & Getopt_Description,
1629                                Concatenate => False,
1630                                Parser      => Parser);
1631                end if;
1632
1633                exit when S = ASCII.NUL;
1634
1635                declare
1636                   Sw         : constant String := Real_Full_Switch (S, Parser);
1637                   Is_Section : Boolean         := False;
1638
1639                begin
1640                   if Cmd.Config /= null
1641                     and then Cmd.Config.Sections /= null
1642                   then
1643                      Section_Search :
1644                      for S in Cmd.Config.Sections'Range loop
1645                         if Sw = Cmd.Config.Sections (S).all then
1646                            Section := Cmd.Config.Sections (S);
1647                            Is_Section := True;
1648
1649                            exit Section_Search;
1650                         end if;
1651                      end loop Section_Search;
1652                   end if;
1653
1654                   if not Is_Section then
1655                      if Section = null then
1656                         Add_Switch (Cmd, Sw, Parameter (Parser));
1657                      else
1658                         Add_Switch
1659                           (Cmd, Sw, Parameter (Parser),
1660                            Section => Section.all);
1661                      end if;
1662                   end if;
1663                end;
1664
1665             exception
1666                when Invalid_Parameter =>
1667
1668                   --  Add it with no parameter, if that's the way the user
1669                   --  wants it.
1670
1671                   --  Specify the separator in all cases, as the switch might
1672                   --  need to be unaliased, and the alias might contain
1673                   --  switches with parameters.
1674
1675                   if Section = null then
1676                      Add_Switch
1677                        (Cmd, Switch_Char & Full_Switch (Parser));
1678                   else
1679                      Add_Switch
1680                        (Cmd, Switch_Char & Full_Switch (Parser),
1681                         Section   => Section.all);
1682                   end if;
1683             end;
1684          end loop;
1685
1686          Free (Parser);
1687       end if;
1688    end Set_Command_Line;
1689
1690    ----------------
1691    -- Looking_At --
1692    ----------------
1693
1694    function Looking_At
1695      (Type_Str  : String;
1696       Index     : Natural;
1697       Substring : String) return Boolean
1698    is
1699    begin
1700       return Index + Substring'Length - 1 <= Type_Str'Last
1701         and then Type_Str (Index .. Index + Substring'Length - 1) = Substring;
1702    end Looking_At;
1703
1704    ------------------------
1705    -- Can_Have_Parameter --
1706    ------------------------
1707
1708    function Can_Have_Parameter (S : String) return Boolean is
1709    begin
1710       if S'Length <= 1 then
1711          return False;
1712       end if;
1713
1714       case S (S'Last) is
1715          when '!' | ':' | '?' | '=' =>
1716             return True;
1717          when others =>
1718             return False;
1719       end case;
1720    end Can_Have_Parameter;
1721
1722    -----------------------
1723    -- Require_Parameter --
1724    -----------------------
1725
1726    function Require_Parameter (S : String) return Boolean is
1727    begin
1728       if S'Length <= 1 then
1729          return False;
1730       end if;
1731
1732       case S (S'Last) is
1733          when '!' | ':' | '=' =>
1734             return True;
1735          when others =>
1736             return False;
1737       end case;
1738    end Require_Parameter;
1739
1740    -------------------
1741    -- Actual_Switch --
1742    -------------------
1743
1744    function Actual_Switch (S : String) return String is
1745    begin
1746       if S'Length <= 1 then
1747          return S;
1748       end if;
1749
1750       case S (S'Last) is
1751          when '!' | ':' | '?' | '=' =>
1752             return S (S'First .. S'Last - 1);
1753          when others =>
1754             return S;
1755       end case;
1756    end Actual_Switch;
1757
1758    ----------------------------
1759    -- For_Each_Simple_Switch --
1760    ----------------------------
1761
1762    procedure For_Each_Simple_Switch
1763      (Config    : Command_Line_Configuration;
1764       Section   : String;
1765       Switch    : String;
1766       Parameter : String := "";
1767       Unalias   : Boolean := True)
1768    is
1769       function Group_Analysis
1770         (Prefix : String;
1771          Group  : String) return Boolean;
1772       --  Perform the analysis of a group of switches
1773
1774       Found_In_Config : Boolean := False;
1775       function Is_In_Config
1776         (Config_Switch : String; Index : Integer) return Boolean;
1777       --  If Switch is the same as Config_Switch, run the callback and sets
1778       --  Found_In_Config to True.
1779
1780       function Starts_With
1781         (Config_Switch : String; Index : Integer) return Boolean;
1782       --  if Switch starts with Config_Switch, sets Found_In_Config to True.
1783       --  The return value is for the Foreach_Switch iterator.
1784
1785       --------------------
1786       -- Group_Analysis --
1787       --------------------
1788
1789       function Group_Analysis
1790         (Prefix : String;
1791          Group  : String) return Boolean
1792       is
1793          Idx   : Natural;
1794          Found : Boolean;
1795
1796          function Analyze_Simple_Switch
1797            (Switch : String; Index : Integer) return Boolean;
1798          --  "Switches" is one of the switch definitions passed to the
1799          --  configuration, not one of the switches found on the command line.
1800
1801          ---------------------------
1802          -- Analyze_Simple_Switch --
1803          ---------------------------
1804
1805          function Analyze_Simple_Switch
1806            (Switch : String; Index : Integer) return Boolean
1807          is
1808             pragma Unreferenced (Index);
1809
1810             Full : constant String := Prefix & Group (Idx .. Group'Last);
1811
1812             Sw : constant String := Actual_Switch (Switch);
1813             --  Switches definition minus argument definition
1814
1815             Last  : Natural;
1816             Param : Natural;
1817
1818          begin
1819             --  Verify that sw starts with Prefix
1820
1821             if Looking_At (Sw, Sw'First, Prefix)
1822
1823               --  Verify that the group starts with sw
1824
1825               and then Looking_At (Full, Full'First, Sw)
1826             then
1827                Last  := Idx + Sw'Length - Prefix'Length - 1;
1828                Param := Last + 1;
1829
1830                if Can_Have_Parameter (Switch) then
1831
1832                   --  Include potential parameter to the recursive call. Only
1833                   --  numbers are allowed.
1834
1835                   while Last < Group'Last
1836                     and then Group (Last + 1) in '0' .. '9'
1837                   loop
1838                      Last := Last + 1;
1839                   end loop;
1840                end if;
1841
1842                if not Require_Parameter (Switch) or else Last >= Param then
1843                   if Idx = Group'First
1844                     and then Last = Group'Last
1845                     and then Last < Param
1846                   then
1847                      --  The group only concerns a single switch. Do not
1848                      --  perform recursive call.
1849
1850                      --  Note that we still perform a recursive call if
1851                      --  a parameter is detected in the switch, as this
1852                      --  is a way to correctly identify such a parameter
1853                      --  in aliases.
1854
1855                      return False;
1856                   end if;
1857
1858                   Found := True;
1859
1860                   --  Recursive call, using the detected parameter if any
1861
1862                   if Last >= Param then
1863                      For_Each_Simple_Switch
1864                        (Config,
1865                         Section,
1866                         Prefix & Group (Idx .. Param - 1),
1867                         Group (Param .. Last));
1868
1869                   else
1870                      For_Each_Simple_Switch
1871                        (Config, Section, Prefix & Group (Idx .. Last), "");
1872                   end if;
1873
1874                   Idx := Last + 1;
1875                   return False;
1876                end if;
1877             end if;
1878
1879             return True;
1880          end Analyze_Simple_Switch;
1881
1882          procedure Foreach is new Foreach_Switch (Analyze_Simple_Switch);
1883
1884       --  Start of processing for Group_Analysis
1885
1886       begin
1887          Idx := Group'First;
1888          while Idx <= Group'Last loop
1889             Found := False;
1890             Foreach (Config, Section);
1891
1892             if not Found then
1893                For_Each_Simple_Switch
1894                  (Config, Section, Prefix & Group (Idx), "");
1895                Idx := Idx + 1;
1896             end if;
1897          end loop;
1898
1899          return True;
1900       end Group_Analysis;
1901
1902       ------------------
1903       -- Is_In_Config --
1904       ------------------
1905
1906       function Is_In_Config
1907         (Config_Switch : String; Index : Integer) return Boolean
1908       is
1909          Last : Natural;
1910          P    : Switch_Parameter_Type;
1911
1912       begin
1913          Decompose_Switch (Config_Switch, P, Last);
1914
1915          if Config_Switch (Config_Switch'First .. Last) = Switch then
1916             case P is
1917                when Parameter_None =>
1918                   if Parameter = "" then
1919                      Callback (Switch, "", "", Index => Index);
1920                      Found_In_Config := True;
1921                      return False;
1922                   end if;
1923
1924                when Parameter_With_Optional_Space =>
1925                   Callback (Switch, " ", Parameter, Index => Index);
1926                   Found_In_Config := True;
1927                   return False;
1928
1929                when Parameter_With_Space_Or_Equal =>
1930                   Callback (Switch, "=", Parameter, Index => Index);
1931                   Found_In_Config := True;
1932                   return False;
1933
1934                when Parameter_No_Space =>
1935                   Callback (Switch, "", Parameter, Index);
1936                   Found_In_Config := True;
1937                   return False;
1938
1939                when Parameter_Optional =>
1940                   Callback (Switch, "", Parameter, Index);
1941                   Found_In_Config := True;
1942                   return False;
1943             end case;
1944          end if;
1945
1946          return True;
1947       end Is_In_Config;
1948
1949       -----------------
1950       -- Starts_With --
1951       -----------------
1952
1953       function Starts_With
1954         (Config_Switch : String; Index : Integer) return Boolean
1955       is
1956          Last  : Natural;
1957          Param : Natural;
1958          P     : Switch_Parameter_Type;
1959
1960       begin
1961          --  This function is called when we believe the parameter was
1962          --  specified as part of the switch, instead of separately. Thus we
1963          --  look in the config to find all possible switches.
1964
1965          Decompose_Switch (Config_Switch, P, Last);
1966
1967          if Looking_At
1968               (Switch, Switch'First,
1969                Config_Switch (Config_Switch'First .. Last))
1970          then
1971             --  Set first char of Param, and last char of Switch
1972
1973             Param := Switch'First + Last;
1974             Last  := Switch'First + Last - Config_Switch'First;
1975
1976             case P is
1977
1978                --  None is already handled in Is_In_Config
1979
1980                when Parameter_None =>
1981                   null;
1982
1983                when Parameter_With_Space_Or_Equal =>
1984                   if Param <= Switch'Last
1985                     and then
1986                       (Switch (Param) = ' ' or else Switch (Param) = '=')
1987                   then
1988                      Callback (Switch (Switch'First .. Last),
1989                                "=", Switch (Param + 1 .. Switch'Last), Index);
1990                      Found_In_Config := True;
1991                      return False;
1992                   end if;
1993
1994                when Parameter_With_Optional_Space =>
1995                   if Param <= Switch'Last and then Switch (Param) = ' '  then
1996                      Param := Param + 1;
1997                   end if;
1998
1999                   Callback (Switch (Switch'First .. Last),
2000                             " ", Switch (Param .. Switch'Last), Index);
2001                   Found_In_Config := True;
2002                   return False;
2003
2004                when Parameter_No_Space | Parameter_Optional =>
2005                   Callback (Switch (Switch'First .. Last),
2006                             "", Switch (Param .. Switch'Last), Index);
2007                   Found_In_Config := True;
2008                   return False;
2009             end case;
2010          end if;
2011          return True;
2012       end Starts_With;
2013
2014       procedure Foreach_In_Config is new Foreach_Switch (Is_In_Config);
2015       procedure Foreach_Starts_With is new Foreach_Switch (Starts_With);
2016
2017    --  Start of processing for For_Each_Simple_Switch
2018
2019    begin
2020       --  First determine if the switch corresponds to one belonging to the
2021       --  configuration. If so, run callback and exit.
2022
2023       --  ??? Is this necessary. On simple tests, we seem to have the same
2024       --  results with or without this call.
2025
2026       Foreach_In_Config (Config, Section);
2027
2028       if Found_In_Config then
2029          return;
2030       end if;
2031
2032       --  If adding a switch that can in fact be expanded through aliases,
2033       --  add separately each of its expansions.
2034
2035       --  This takes care of expansions like "-T" -> "-gnatwrs", where the
2036       --  alias and its expansion do not have the same prefix. Given the order
2037       --  in which we do things here, the expansion of the alias will itself
2038       --  be checked for a common prefix and split into simple switches.
2039
2040       if Unalias
2041         and then Config /= null
2042         and then Config.Aliases /= null
2043       then
2044          for A in Config.Aliases'Range loop
2045             if Config.Aliases (A).Section.all = Section
2046               and then Config.Aliases (A).Alias.all = Switch
2047               and then Parameter = ""
2048             then
2049                For_Each_Simple_Switch
2050                  (Config, Section, Config.Aliases (A).Expansion.all, "");
2051                return;
2052             end if;
2053          end loop;
2054       end if;
2055
2056       --  If adding a switch grouping several switches, add each of the simple
2057       --  switches instead.
2058
2059       if Config /= null and then Config.Prefixes /= null then
2060          for P in Config.Prefixes'Range loop
2061             if Switch'Length > Config.Prefixes (P)'Length + 1
2062               and then
2063                 Looking_At (Switch, Switch'First, Config.Prefixes (P).all)
2064             then
2065                --  Alias expansion will be done recursively
2066
2067                if Config.Switches = null then
2068                   for S in Switch'First + Config.Prefixes (P)'Length
2069                             .. Switch'Last
2070                   loop
2071                      For_Each_Simple_Switch
2072                        (Config, Section,
2073                         Config.Prefixes (P).all & Switch (S), "");
2074                   end loop;
2075
2076                   return;
2077
2078                elsif Group_Analysis
2079                  (Config.Prefixes (P).all,
2080                   Switch
2081                     (Switch'First + Config.Prefixes (P)'Length .. Switch'Last))
2082                then
2083                   --  Recursive calls already done on each switch of the group:
2084                   --  Return without executing Callback.
2085
2086                   return;
2087                end if;
2088             end if;
2089          end loop;
2090       end if;
2091
2092       --  Test if added switch is a known switch with parameter attached
2093       --  instead of being specified separately
2094
2095       if Parameter = ""
2096         and then Config /= null
2097         and then Config.Switches /= null
2098       then
2099          Found_In_Config := False;
2100          Foreach_Starts_With (Config, Section);
2101
2102          if Found_In_Config then
2103             return;
2104          end if;
2105       end if;
2106
2107       --  The switch is invalid in the config, but we still want to report it.
2108       --  The config could, for instance, include "*" to specify it accepts
2109       --  all switches.
2110
2111       Callback (Switch, " ", Parameter, Index => -1);
2112    end For_Each_Simple_Switch;
2113
2114    ----------------
2115    -- Add_Switch --
2116    ----------------
2117
2118    procedure Add_Switch
2119      (Cmd        : in out Command_Line;
2120       Switch     : String;
2121       Parameter  : String    := "";
2122       Separator  : Character := ASCII.NUL;
2123       Section    : String    := "";
2124       Add_Before : Boolean   := False)
2125    is
2126       Success : Boolean;
2127       pragma Unreferenced (Success);
2128    begin
2129       Add_Switch (Cmd, Switch, Parameter, Separator,
2130                   Section, Add_Before, Success);
2131    end Add_Switch;
2132
2133    ----------------
2134    -- Add_Switch --
2135    ----------------
2136
2137    procedure Add_Switch
2138      (Cmd        : in out Command_Line;
2139       Switch     : String;
2140       Parameter  : String := "";
2141       Separator  : Character := ASCII.NUL;
2142       Section    : String := "";
2143       Add_Before : Boolean := False;
2144       Success    : out Boolean)
2145    is
2146       procedure Add_Simple_Switch
2147         (Simple : String;
2148          Sepa   : String;
2149          Param  : String;
2150          Index  : Integer);
2151       --  Add a new switch that has had all its aliases expanded, and switches
2152       --  ungrouped. We know there are no more aliases in Switches.
2153
2154       -----------------------
2155       -- Add_Simple_Switch --
2156       -----------------------
2157
2158       procedure Add_Simple_Switch
2159         (Simple : String;
2160          Sepa   : String;
2161          Param  : String;
2162          Index  : Integer)
2163       is
2164          Sep : Character;
2165
2166       begin
2167          if Index = -1
2168            and then Cmd.Config /= null
2169            and then not Cmd.Config.Star_Switch
2170          then
2171             raise Invalid_Switch
2172               with "Invalid switch " & Simple;
2173          end if;
2174
2175          if Separator /= ASCII.NUL then
2176             Sep := Separator;
2177
2178          elsif Sepa = "" then
2179             Sep := ASCII.NUL;
2180          else
2181             Sep := Sepa (Sepa'First);
2182          end if;
2183
2184          if Cmd.Expanded = null then
2185             Cmd.Expanded := new Argument_List'(1 .. 1 => new String'(Simple));
2186
2187             if Param /= "" then
2188                Cmd.Params :=
2189                  new Argument_List'(1 .. 1 => new String'(Sep & Param));
2190             else
2191                Cmd.Params := new Argument_List'(1 .. 1 => null);
2192             end if;
2193
2194             if Section = "" then
2195                Cmd.Sections := new Argument_List'(1 .. 1 => null);
2196             else
2197                Cmd.Sections :=
2198                  new Argument_List'(1 .. 1 => new String'(Section));
2199             end if;
2200
2201          else
2202             --  Do we already have this switch?
2203
2204             for C in Cmd.Expanded'Range loop
2205                if Cmd.Expanded (C).all = Simple
2206                  and then
2207                    ((Cmd.Params (C) = null and then Param = "")
2208                      or else
2209                        (Cmd.Params (C) /= null
2210                          and then Cmd.Params (C).all = Sep & Param))
2211                  and then
2212                    ((Cmd.Sections (C) = null and then Section = "")
2213                      or else
2214                        (Cmd.Sections (C) /= null
2215                          and then Cmd.Sections (C).all = Section))
2216                then
2217                   return;
2218                end if;
2219             end loop;
2220
2221             --  Inserting at least one switch
2222
2223             Success := True;
2224             Add (Cmd.Expanded, new String'(Simple), Add_Before);
2225
2226             if Param /= "" then
2227                Add
2228                  (Cmd.Params,
2229                   new String'(Sep & Param),
2230                   Add_Before);
2231             else
2232                Add
2233                  (Cmd.Params,
2234                   null,
2235                   Add_Before);
2236             end if;
2237
2238             if Section = "" then
2239                Add
2240                  (Cmd.Sections,
2241                   null,
2242                   Add_Before);
2243             else
2244                Add
2245                  (Cmd.Sections,
2246                   new String'(Section),
2247                   Add_Before);
2248             end if;
2249          end if;
2250       end Add_Simple_Switch;
2251
2252       procedure Add_Simple_Switches is
2253         new For_Each_Simple_Switch (Add_Simple_Switch);
2254
2255       --  Local Variables
2256
2257       Section_Valid : Boolean := False;
2258
2259    --  Start of processing for Add_Switch
2260
2261    begin
2262       if Section /= "" and then Cmd.Config /= null then
2263          for S in Cmd.Config.Sections'Range loop
2264             if Section = Cmd.Config.Sections (S).all then
2265                Section_Valid := True;
2266                exit;
2267             end if;
2268          end loop;
2269
2270          if not Section_Valid then
2271             raise Invalid_Section;
2272          end if;
2273       end if;
2274
2275       Success := False;
2276       Add_Simple_Switches (Cmd.Config, Section, Switch, Parameter);
2277       Free (Cmd.Coalesce);
2278    end Add_Switch;
2279
2280    ------------
2281    -- Remove --
2282    ------------
2283
2284    procedure Remove (Line : in out Argument_List_Access; Index : Integer) is
2285       Tmp : Argument_List_Access := Line;
2286
2287    begin
2288       Line := new Argument_List (Tmp'First .. Tmp'Last - 1);
2289
2290       if Index /= Tmp'First then
2291          Line (Tmp'First .. Index - 1) := Tmp (Tmp'First .. Index - 1);
2292       end if;
2293
2294       Free (Tmp (Index));
2295
2296       if Index /= Tmp'Last then
2297          Line (Index .. Tmp'Last - 1) := Tmp (Index + 1 .. Tmp'Last);
2298       end if;
2299
2300       Unchecked_Free (Tmp);
2301    end Remove;
2302
2303    ---------
2304    -- Add --
2305    ---------
2306
2307    procedure Add
2308      (Line   : in out Argument_List_Access;
2309       Str    : String_Access;
2310       Before : Boolean := False)
2311    is
2312       Tmp : Argument_List_Access := Line;
2313
2314    begin
2315       if Tmp /= null then
2316          Line := new Argument_List (Tmp'First .. Tmp'Last + 1);
2317
2318          if Before then
2319             Line (Tmp'First)                     := Str;
2320             Line (Tmp'First + 1 .. Tmp'Last + 1) := Tmp.all;
2321          else
2322             Line (Tmp'Range)    := Tmp.all;
2323             Line (Tmp'Last + 1) := Str;
2324          end if;
2325
2326          Unchecked_Free (Tmp);
2327
2328       else
2329          Line := new Argument_List'(1 .. 1 => Str);
2330       end if;
2331    end Add;
2332
2333    -------------------
2334    -- Remove_Switch --
2335    -------------------
2336
2337    procedure Remove_Switch
2338      (Cmd           : in out Command_Line;
2339       Switch        : String;
2340       Remove_All    : Boolean := False;
2341       Has_Parameter : Boolean := False;
2342       Section       : String := "")
2343    is
2344       Success : Boolean;
2345       pragma Unreferenced (Success);
2346    begin
2347       Remove_Switch (Cmd, Switch, Remove_All, Has_Parameter, Section, Success);
2348    end Remove_Switch;
2349
2350    -------------------
2351    -- Remove_Switch --
2352    -------------------
2353
2354    procedure Remove_Switch
2355      (Cmd           : in out Command_Line;
2356       Switch        : String;
2357       Remove_All    : Boolean := False;
2358       Has_Parameter : Boolean := False;
2359       Section       : String  := "";
2360       Success       : out Boolean)
2361    is
2362       procedure Remove_Simple_Switch
2363         (Simple, Separator, Param : String; Index : Integer);
2364       --  Removes a simple switch, with no aliasing or grouping
2365
2366       --------------------------
2367       -- Remove_Simple_Switch --
2368       --------------------------
2369
2370       procedure Remove_Simple_Switch
2371         (Simple, Separator, Param : String; Index : Integer)
2372       is
2373          C : Integer;
2374          pragma Unreferenced (Param, Separator, Index);
2375
2376       begin
2377          if Cmd.Expanded /= null then
2378             C := Cmd.Expanded'First;
2379             while C <= Cmd.Expanded'Last loop
2380                if Cmd.Expanded (C).all = Simple
2381                  and then
2382                    (Remove_All
2383                      or else (Cmd.Sections (C) = null
2384                                and then Section = "")
2385                      or else (Cmd.Sections (C) /= null
2386                                and then Section = Cmd.Sections (C).all))
2387                  and then (not Has_Parameter or else Cmd.Params (C) /= null)
2388                then
2389                   Remove (Cmd.Expanded, C);
2390                   Remove (Cmd.Params, C);
2391                   Remove (Cmd.Sections, C);
2392                   Success := True;
2393
2394                   if not Remove_All then
2395                      return;
2396                   end if;
2397
2398                else
2399                   C := C + 1;
2400                end if;
2401             end loop;
2402          end if;
2403       end Remove_Simple_Switch;
2404
2405       procedure Remove_Simple_Switches is
2406         new For_Each_Simple_Switch (Remove_Simple_Switch);
2407
2408    --  Start of processing for Remove_Switch
2409
2410    begin
2411       Success := False;
2412       Remove_Simple_Switches
2413         (Cmd.Config, Section, Switch, "", Unalias => not Has_Parameter);
2414       Free (Cmd.Coalesce);
2415    end Remove_Switch;
2416
2417    -------------------
2418    -- Remove_Switch --
2419    -------------------
2420
2421    procedure Remove_Switch
2422      (Cmd       : in out Command_Line;
2423       Switch    : String;
2424       Parameter : String;
2425       Section   : String  := "")
2426    is
2427       procedure Remove_Simple_Switch
2428         (Simple, Separator, Param : String; Index : Integer);
2429       --  Removes a simple switch, with no aliasing or grouping
2430
2431       --------------------------
2432       -- Remove_Simple_Switch --
2433       --------------------------
2434
2435       procedure Remove_Simple_Switch
2436         (Simple, Separator, Param : String; Index : Integer)
2437       is
2438          pragma Unreferenced (Separator, Index);
2439          C : Integer;
2440
2441       begin
2442          if Cmd.Expanded /= null then
2443             C := Cmd.Expanded'First;
2444             while C <= Cmd.Expanded'Last loop
2445                if Cmd.Expanded (C).all = Simple
2446                  and then
2447                    ((Cmd.Sections (C) = null
2448                       and then Section = "")
2449                     or else
2450                       (Cmd.Sections (C) /= null
2451                         and then Section = Cmd.Sections (C).all))
2452                  and then
2453                    ((Cmd.Params (C) = null and then Param = "")
2454                       or else
2455                         (Cmd.Params (C) /= null
2456                            and then
2457
2458                            --  Ignore the separator stored in Parameter
2459
2460                              Cmd.Params (C) (Cmd.Params (C)'First + 1
2461                                              .. Cmd.Params (C)'Last) =
2462                            Param))
2463                then
2464                   Remove (Cmd.Expanded, C);
2465                   Remove (Cmd.Params, C);
2466                   Remove (Cmd.Sections, C);
2467
2468                   --  The switch is necessarily unique by construction of
2469                   --  Add_Switch.
2470
2471                   return;
2472
2473                else
2474                   C := C + 1;
2475                end if;
2476             end loop;
2477          end if;
2478       end Remove_Simple_Switch;
2479
2480       procedure Remove_Simple_Switches is
2481         new For_Each_Simple_Switch (Remove_Simple_Switch);
2482
2483    --  Start of processing for Remove_Switch
2484
2485    begin
2486       Remove_Simple_Switches (Cmd.Config, Section, Switch, Parameter);
2487       Free (Cmd.Coalesce);
2488    end Remove_Switch;
2489
2490    --------------------
2491    -- Group_Switches --
2492    --------------------
2493
2494    procedure Group_Switches
2495      (Cmd      : Command_Line;
2496       Result   : Argument_List_Access;
2497       Sections : Argument_List_Access;
2498       Params   : Argument_List_Access)
2499    is
2500       function Compatible_Parameter (Param : String_Access) return Boolean;
2501       --  True when the parameter can be part of a group
2502
2503       --------------------------
2504       -- Compatible_Parameter --
2505       --------------------------
2506
2507       function Compatible_Parameter (Param : String_Access) return Boolean is
2508       begin
2509          --  No parameter OK
2510
2511          if Param = null then
2512             return True;
2513
2514          --  We need parameters without separators
2515
2516          elsif Param (Param'First) /= ASCII.NUL then
2517             return False;
2518
2519          --  Parameters must be all digits
2520
2521          else
2522             for J in Param'First + 1 .. Param'Last loop
2523                if Param (J) not in '0' .. '9' then
2524                   return False;
2525                end if;
2526             end loop;
2527
2528             return True;
2529          end if;
2530       end Compatible_Parameter;
2531
2532       --  Local declarations
2533
2534       Group : Ada.Strings.Unbounded.Unbounded_String;
2535       First : Natural;
2536       use type Ada.Strings.Unbounded.Unbounded_String;
2537
2538    --  Start of processing for Group_Switches
2539
2540    begin
2541       if Cmd.Config = null
2542         or else Cmd.Config.Prefixes = null
2543       then
2544          return;
2545       end if;
2546
2547       for P in Cmd.Config.Prefixes'Range loop
2548          Group   := Ada.Strings.Unbounded.Null_Unbounded_String;
2549          First   := 0;
2550
2551          for C in Result'Range loop
2552             if Result (C) /= null
2553               and then Compatible_Parameter (Params (C))
2554               and then Looking_At
2555                          (Result (C).all,
2556                           Result (C)'First,
2557                           Cmd.Config.Prefixes (P).all)
2558             then
2559                --  If we are still in the same section, group the switches
2560
2561                if First = 0
2562                  or else
2563                    (Sections (C) = null
2564                      and then Sections (First) = null)
2565                  or else
2566                    (Sections (C) /= null
2567                      and then Sections (First) /= null
2568                      and then Sections (C).all = Sections (First).all)
2569                then
2570                   Group :=
2571                     Group &
2572                       Result (C)
2573                         (Result (C)'First + Cmd.Config.Prefixes (P)'Length ..
2574                          Result (C)'Last);
2575
2576                   if Params (C) /= null then
2577                      Group :=
2578                        Group &
2579                          Params (C) (Params (C)'First + 1 .. Params (C)'Last);
2580                      Free (Params (C));
2581                   end if;
2582
2583                   if First = 0 then
2584                      First := C;
2585                   end if;
2586
2587                   Free (Result (C));
2588
2589                --  We changed section: we put the grouped switches to the first
2590                --  place, on continue with the new section.
2591
2592                else
2593                   Result (First) :=
2594                     new String'
2595                       (Cmd.Config.Prefixes (P).all &
2596                        Ada.Strings.Unbounded.To_String (Group));
2597                   Group :=
2598                     Ada.Strings.Unbounded.To_Unbounded_String
2599                       (Result (C)
2600                          (Result (C)'First + Cmd.Config.Prefixes (P)'Length ..
2601                           Result (C)'Last));
2602                   First := C;
2603                end if;
2604             end if;
2605          end loop;
2606
2607          if First > 0 then
2608             Result (First) :=
2609               new String'
2610                 (Cmd.Config.Prefixes (P).all &
2611                  Ada.Strings.Unbounded.To_String (Group));
2612          end if;
2613       end loop;
2614    end Group_Switches;
2615
2616    --------------------
2617    -- Alias_Switches --
2618    --------------------
2619
2620    procedure Alias_Switches
2621      (Cmd    : Command_Line;
2622       Result : Argument_List_Access;
2623       Params : Argument_List_Access)
2624    is
2625       Found : Boolean;
2626       First : Natural;
2627
2628       procedure Check_Cb (Switch, Separator, Param : String; Index : Integer);
2629       --  Checks whether the command line contains [Switch].
2630       --  Sets the global variable [Found] appropriately.
2631       --  This will be called for each simple switch that make up an alias, to
2632       --  know whether the alias should be applied.
2633
2634       procedure Remove_Cb (Switch, Separator, Param : String; Index : Integer);
2635       --  Remove the simple switch [Switch] from the command line, since it is
2636       --  part of a simpler alias
2637
2638       --------------
2639       -- Check_Cb --
2640       --------------
2641
2642       procedure Check_Cb
2643         (Switch, Separator, Param : String; Index : Integer)
2644       is
2645          pragma Unreferenced (Separator, Index);
2646
2647       begin
2648          if Found then
2649             for E in Result'Range loop
2650                if Result (E) /= null
2651                  and then
2652                    (Params (E) = null
2653                      or else Params (E) (Params (E)'First + 1 ..
2654                                          Params (E)'Last) = Param)
2655                  and then Result (E).all = Switch
2656                then
2657                   return;
2658                end if;
2659             end loop;
2660
2661             Found := False;
2662          end if;
2663       end Check_Cb;
2664
2665       ---------------
2666       -- Remove_Cb --
2667       ---------------
2668
2669       procedure Remove_Cb (Switch, Separator, Param : String; Index : Integer)
2670       is
2671          pragma Unreferenced (Separator, Index);
2672
2673       begin
2674          for E in Result'Range loop
2675             if Result (E) /= null
2676                  and then
2677                    (Params (E) = null
2678                      or else Params (E) (Params (E)'First + 1
2679                                              .. Params (E)'Last) = Param)
2680               and then Result (E).all = Switch
2681             then
2682                if First > E then
2683                   First := E;
2684                end if;
2685
2686                Free (Result (E));
2687                Free (Params (E));
2688                return;
2689             end if;
2690          end loop;
2691       end Remove_Cb;
2692
2693       procedure Check_All is new For_Each_Simple_Switch (Check_Cb);
2694       procedure Remove_All is new For_Each_Simple_Switch (Remove_Cb);
2695
2696    --  Start of processing for Alias_Switches
2697
2698    begin
2699       if Cmd.Config = null
2700         or else Cmd.Config.Aliases = null
2701       then
2702          return;
2703       end if;
2704
2705       for A in Cmd.Config.Aliases'Range loop
2706
2707          --  Compute the various simple switches that make up the alias. We
2708          --  split the expansion into as many simple switches as possible, and
2709          --  then check whether the expanded command line has all of them.
2710
2711          Found := True;
2712          Check_All (Cmd.Config,
2713                     Switch  => Cmd.Config.Aliases (A).Expansion.all,
2714                     Section => Cmd.Config.Aliases (A).Section.all);
2715
2716          if Found then
2717             First := Integer'Last;
2718             Remove_All (Cmd.Config,
2719                         Switch  => Cmd.Config.Aliases (A).Expansion.all,
2720                         Section => Cmd.Config.Aliases (A).Section.all);
2721             Result (First) := new String'(Cmd.Config.Aliases (A).Alias.all);
2722          end if;
2723       end loop;
2724    end Alias_Switches;
2725
2726    -------------------
2727    -- Sort_Sections --
2728    -------------------
2729
2730    procedure Sort_Sections
2731      (Line     : GNAT.OS_Lib.Argument_List_Access;
2732       Sections : GNAT.OS_Lib.Argument_List_Access;
2733       Params   : GNAT.OS_Lib.Argument_List_Access)
2734    is
2735       Sections_List : Argument_List_Access :=
2736                         new Argument_List'(1 .. 1 => null);
2737       Found         : Boolean;
2738       Old_Line      : constant Argument_List := Line.all;
2739       Old_Sections  : constant Argument_List := Sections.all;
2740       Old_Params    : constant Argument_List := Params.all;
2741       Index         : Natural;
2742
2743    begin
2744       if Line = null then
2745          return;
2746       end if;
2747
2748       --  First construct a list of all sections
2749
2750       for E in Line'Range loop
2751          if Sections (E) /= null then
2752             Found := False;
2753             for S in Sections_List'Range loop
2754                if (Sections_List (S) = null and then Sections (E) = null)
2755                  or else
2756                    (Sections_List (S) /= null
2757                      and then Sections (E) /= null
2758                      and then Sections_List (S).all = Sections (E).all)
2759                then
2760                   Found := True;
2761                   exit;
2762                end if;
2763             end loop;
2764
2765             if not Found then
2766                Add (Sections_List, Sections (E));
2767             end if;
2768          end if;
2769       end loop;
2770
2771       Index := Line'First;
2772
2773       for S in Sections_List'Range loop
2774          for E in Old_Line'Range loop
2775             if (Sections_List (S) = null and then Old_Sections (E) = null)
2776               or else
2777                 (Sections_List (S) /= null
2778                   and then Old_Sections (E) /= null
2779                   and then Sections_List (S).all = Old_Sections (E).all)
2780             then
2781                Line (Index) := Old_Line (E);
2782                Sections (Index) := Old_Sections (E);
2783                Params (Index) := Old_Params (E);
2784                Index := Index + 1;
2785             end if;
2786          end loop;
2787       end loop;
2788
2789       Unchecked_Free (Sections_List);
2790    end Sort_Sections;
2791
2792    -----------
2793    -- Start --
2794    -----------
2795
2796    procedure Start
2797      (Cmd      : in out Command_Line;
2798       Iter     : in out Command_Line_Iterator;
2799       Expanded : Boolean := False)
2800    is
2801    begin
2802       if Cmd.Expanded = null then
2803          Iter.List := null;
2804          return;
2805       end if;
2806
2807       --  Reorder the expanded line so that sections are grouped
2808
2809       Sort_Sections (Cmd.Expanded, Cmd.Sections, Cmd.Params);
2810
2811       --  Coalesce the switches as much as possible
2812
2813       if not Expanded
2814         and then Cmd.Coalesce = null
2815       then
2816          Cmd.Coalesce := new Argument_List (Cmd.Expanded'Range);
2817          for E in Cmd.Expanded'Range loop
2818             Cmd.Coalesce (E) := new String'(Cmd.Expanded (E).all);
2819          end loop;
2820
2821          Free (Cmd.Coalesce_Sections);
2822          Cmd.Coalesce_Sections := new Argument_List (Cmd.Sections'Range);
2823          for E in Cmd.Sections'Range loop
2824             Cmd.Coalesce_Sections (E) :=
2825               (if Cmd.Sections (E) = null then null
2826                else new String'(Cmd.Sections (E).all));
2827          end loop;
2828
2829          Free (Cmd.Coalesce_Params);
2830          Cmd.Coalesce_Params := new Argument_List (Cmd.Params'Range);
2831          for E in Cmd.Params'Range loop
2832             Cmd.Coalesce_Params (E) :=
2833               (if Cmd.Params (E) = null then null
2834                else new String'(Cmd.Params (E).all));
2835          end loop;
2836
2837          --  Not a clone, since we will not modify the parameters anyway
2838
2839          Alias_Switches (Cmd, Cmd.Coalesce, Cmd.Coalesce_Params);
2840          Group_Switches
2841            (Cmd, Cmd.Coalesce, Cmd.Coalesce_Sections, Cmd.Coalesce_Params);
2842       end if;
2843
2844       if Expanded then
2845          Iter.List     := Cmd.Expanded;
2846          Iter.Params   := Cmd.Params;
2847          Iter.Sections := Cmd.Sections;
2848       else
2849          Iter.List     := Cmd.Coalesce;
2850          Iter.Params   := Cmd.Coalesce_Params;
2851          Iter.Sections := Cmd.Coalesce_Sections;
2852       end if;
2853
2854       if Iter.List = null then
2855          Iter.Current := Integer'Last;
2856       else
2857          Iter.Current := Iter.List'First - 1;
2858          Next (Iter);
2859       end if;
2860    end Start;
2861
2862    --------------------
2863    -- Current_Switch --
2864    --------------------
2865
2866    function Current_Switch (Iter : Command_Line_Iterator) return String is
2867    begin
2868       return Iter.List (Iter.Current).all;
2869    end Current_Switch;
2870
2871    --------------------
2872    -- Is_New_Section --
2873    --------------------
2874
2875    function Is_New_Section    (Iter : Command_Line_Iterator) return Boolean is
2876       Section : constant String := Current_Section (Iter);
2877
2878    begin
2879       if Iter.Sections = null then
2880          return False;
2881
2882       elsif Iter.Current = Iter.Sections'First
2883         or else Iter.Sections (Iter.Current - 1) = null
2884       then
2885          return Section /= "";
2886
2887       else
2888          return Section /= Iter.Sections (Iter.Current - 1).all;
2889       end if;
2890    end Is_New_Section;
2891
2892    ---------------------
2893    -- Current_Section --
2894    ---------------------
2895
2896    function Current_Section (Iter : Command_Line_Iterator) return String is
2897    begin
2898       if Iter.Sections = null
2899         or else Iter.Current > Iter.Sections'Last
2900         or else Iter.Sections (Iter.Current) = null
2901       then
2902          return "";
2903       end if;
2904
2905       return Iter.Sections (Iter.Current).all;
2906    end Current_Section;
2907
2908    -----------------------
2909    -- Current_Separator --
2910    -----------------------
2911
2912    function Current_Separator (Iter : Command_Line_Iterator) return String is
2913    begin
2914       if Iter.Params = null
2915         or else Iter.Current > Iter.Params'Last
2916         or else Iter.Params (Iter.Current) = null
2917       then
2918          return "";
2919
2920       else
2921          declare
2922             Sep : constant Character :=
2923               Iter.Params (Iter.Current) (Iter.Params (Iter.Current)'First);
2924          begin
2925             if Sep = ASCII.NUL then
2926                return "";
2927             else
2928                return "" & Sep;
2929             end if;
2930          end;
2931       end if;
2932    end Current_Separator;
2933
2934    -----------------------
2935    -- Current_Parameter --
2936    -----------------------
2937
2938    function Current_Parameter (Iter : Command_Line_Iterator) return String is
2939    begin
2940       if Iter.Params = null
2941         or else Iter.Current > Iter.Params'Last
2942         or else Iter.Params (Iter.Current) = null
2943       then
2944          return "";
2945
2946       else
2947          --  Return result, skipping separator
2948
2949          declare
2950             P : constant String := Iter.Params (Iter.Current).all;
2951          begin
2952             return P (P'First + 1 .. P'Last);
2953          end;
2954       end if;
2955    end Current_Parameter;
2956
2957    --------------
2958    -- Has_More --
2959    --------------
2960
2961    function Has_More (Iter : Command_Line_Iterator) return Boolean is
2962    begin
2963       return Iter.List /= null and then Iter.Current <= Iter.List'Last;
2964    end Has_More;
2965
2966    ----------
2967    -- Next --
2968    ----------
2969
2970    procedure Next (Iter : in out Command_Line_Iterator) is
2971    begin
2972       Iter.Current := Iter.Current + 1;
2973       while Iter.Current <= Iter.List'Last
2974         and then Iter.List (Iter.Current) = null
2975       loop
2976          Iter.Current := Iter.Current + 1;
2977       end loop;
2978    end Next;
2979
2980    ----------
2981    -- Free --
2982    ----------
2983
2984    procedure Free (Config : in out Command_Line_Configuration) is
2985       procedure Unchecked_Free is new
2986         Ada.Unchecked_Deallocation
2987           (Switch_Definitions, Switch_Definitions_List);
2988
2989       procedure Unchecked_Free is new
2990         Ada.Unchecked_Deallocation
2991           (Alias_Definitions, Alias_Definitions_List);
2992
2993    begin
2994       if Config /= null then
2995          Free (Config.Prefixes);
2996          Free (Config.Sections);
2997          Free (Config.Usage);
2998          Free (Config.Help);
2999          Free (Config.Help_Msg);
3000
3001          if Config.Aliases /= null then
3002             for A in Config.Aliases'Range loop
3003                Free (Config.Aliases (A).Alias);
3004                Free (Config.Aliases (A).Expansion);
3005                Free (Config.Aliases (A).Section);
3006             end loop;
3007
3008             Unchecked_Free (Config.Aliases);
3009          end if;
3010
3011          if Config.Switches /= null then
3012             for S in Config.Switches'Range loop
3013                Free (Config.Switches (S).Switch);
3014                Free (Config.Switches (S).Long_Switch);
3015                Free (Config.Switches (S).Help);
3016                Free (Config.Switches (S).Section);
3017             end loop;
3018
3019             Unchecked_Free (Config.Switches);
3020          end if;
3021
3022          Unchecked_Free (Config);
3023       end if;
3024    end Free;
3025
3026    ----------
3027    -- Free --
3028    ----------
3029
3030    procedure Free (Cmd : in out Command_Line) is
3031    begin
3032       Free (Cmd.Expanded);
3033       Free (Cmd.Coalesce);
3034       Free (Cmd.Coalesce_Sections);
3035       Free (Cmd.Coalesce_Params);
3036       Free (Cmd.Params);
3037       Free (Cmd.Sections);
3038    end Free;
3039
3040    ---------------
3041    -- Set_Usage --
3042    ---------------
3043
3044    procedure Set_Usage
3045      (Config   : in out Command_Line_Configuration;
3046       Usage    : String := "[switches] [arguments]";
3047       Help     : String := "";
3048       Help_Msg : String := "")
3049    is
3050    begin
3051       if Config = null then
3052          Config := new Command_Line_Configuration_Record;
3053       end if;
3054
3055       Free (Config.Usage);
3056       Free (Config.Help);
3057       Free (Config.Help_Msg);
3058
3059       Config.Usage    := new String'(Usage);
3060       Config.Help     := new String'(Help);
3061       Config.Help_Msg := new String'(Help_Msg);
3062    end Set_Usage;
3063
3064    ------------------
3065    -- Display_Help --
3066    ------------------
3067
3068    procedure Display_Help (Config : Command_Line_Configuration) is
3069       function Switch_Name
3070         (Def : Switch_Definition;
3071          Section : String) return String;
3072       --  Return the "-short, --long=ARG" string for Def.
3073       --  Returns "" if the switch is not in the section.
3074
3075       function Param_Name
3076         (P    : Switch_Parameter_Type;
3077          Name : String := "ARG") return String;
3078       --  Return the display for a switch parameter
3079
3080       procedure Display_Section_Help (Section : String);
3081       --  Display the help for a specific section ("" is the default section)
3082
3083       --------------------------
3084       -- Display_Section_Help --
3085       --------------------------
3086
3087       procedure Display_Section_Help (Section : String) is
3088          Max_Len : Natural := 0;
3089
3090       begin
3091          --  ??? Special display for "*"
3092
3093          New_Line;
3094
3095          if Section /= "" then
3096             Put_Line ("Switches after " & Section);
3097          end if;
3098
3099          --  Compute size of the switches column
3100
3101          for S in Config.Switches'Range loop
3102             Max_Len := Natural'Max
3103               (Max_Len, Switch_Name (Config.Switches (S), Section)'Length);
3104          end loop;
3105
3106          if Config.Aliases /= null then
3107             for A in Config.Aliases'Range loop
3108                if Config.Aliases (A).Section.all = Section then
3109                   Max_Len := Natural'Max
3110                     (Max_Len, Config.Aliases (A).Alias'Length);
3111                end if;
3112             end loop;
3113          end if;
3114
3115          --  Display the switches
3116
3117          for S in Config.Switches'Range loop
3118             declare
3119                N : constant String :=
3120                      Switch_Name (Config.Switches (S), Section);
3121
3122             begin
3123                if N /= "" then
3124                   Put (" ");
3125                   Put (N);
3126                   Put ((1 .. Max_Len - N'Length + 1 => ' '));
3127
3128                   if Config.Switches (S).Help /= null then
3129                      Put (Config.Switches (S).Help.all);
3130                   end if;
3131
3132                   New_Line;
3133                end if;
3134             end;
3135          end loop;
3136
3137          --  Display the aliases
3138
3139          if Config.Aliases /= null then
3140             for A in Config.Aliases'Range loop
3141                if Config.Aliases (A).Section.all = Section then
3142                   Put (" ");
3143                   Put (Config.Aliases (A).Alias.all);
3144                   Put ((1 .. Max_Len - Config.Aliases (A).Alias'Length + 1
3145                        => ' '));
3146                   Put ("Equivalent to " & Config.Aliases (A).Expansion.all);
3147                   New_Line;
3148                end if;
3149             end loop;
3150          end if;
3151       end Display_Section_Help;
3152
3153       ----------------
3154       -- Param_Name --
3155       ----------------
3156
3157       function Param_Name
3158         (P    : Switch_Parameter_Type;
3159          Name : String := "ARG") return String
3160       is
3161       begin
3162          case P is
3163             when Parameter_None =>
3164                return "";
3165
3166             when Parameter_With_Optional_Space =>
3167                return " " & To_Upper (Name);
3168
3169             when Parameter_With_Space_Or_Equal =>
3170                return "=" & To_Upper (Name);
3171
3172             when Parameter_No_Space =>
3173                return To_Upper (Name);
3174
3175             when Parameter_Optional =>
3176                return '[' & To_Upper (Name) & ']';
3177          end case;
3178       end Param_Name;
3179
3180       -----------------
3181       -- Switch_Name --
3182       -----------------
3183
3184       function Switch_Name
3185         (Def : Switch_Definition;
3186          Section : String) return String
3187       is
3188          use Ada.Strings.Unbounded;
3189          Result       : Unbounded_String;
3190          P1, P2       : Switch_Parameter_Type;
3191          Last1, Last2 : Integer := 0;
3192
3193       begin
3194          if (Section = "" and then Def.Section = null)
3195            or else (Def.Section /= null and then Def.Section.all = Section)
3196          then
3197             if Def.Switch /= null and then Def.Switch.all = "*" then
3198                return "[any switch]";
3199             end if;
3200
3201             if Def.Switch /= null then
3202                Decompose_Switch (Def.Switch.all, P1, Last1);
3203                Append (Result, Def.Switch (Def.Switch'First .. Last1));
3204
3205                if Def.Long_Switch /= null then
3206                   Decompose_Switch (Def.Long_Switch.all, P2, Last2);
3207                   Append (Result, ", "
3208                           & Def.Long_Switch (Def.Long_Switch'First .. Last2));
3209                   Append (Result, Param_Name (P2, "ARG"));
3210
3211                else
3212                   Append (Result, Param_Name (P1, "ARG"));
3213                end if;
3214
3215             else  --  Long_Switch necessarily not null
3216                Decompose_Switch (Def.Long_Switch.all, P2, Last2);
3217                Append (Result,
3218                        Def.Long_Switch (Def.Long_Switch'First .. Last2));
3219                Append (Result, Param_Name (P2, "ARG"));
3220             end if;
3221          end if;
3222
3223          return To_String (Result);
3224       end Switch_Name;
3225
3226    --  Start of processing for Display_Help
3227
3228    begin
3229       if Config = null then
3230          return;
3231       end if;
3232
3233       if Config.Help /= null and then Config.Help.all /= "" then
3234          Put_Line (Config.Help.all);
3235       end if;
3236
3237       if Config.Usage /= null then
3238          Put_Line ("Usage: "
3239                    & Base_Name
3240                      (Ada.Command_Line.Command_Name) & " " & Config.Usage.all);
3241       else
3242          Put_Line ("Usage: " & Base_Name (Ada.Command_Line.Command_Name)
3243                    & " [switches] [arguments]");
3244       end if;
3245
3246       if Config.Help_Msg /= null and then Config.Help_Msg.all /= "" then
3247          Put_Line (Config.Help_Msg.all);
3248
3249       else
3250          Display_Section_Help ("");
3251
3252          if Config.Sections /= null and then Config.Switches /= null then
3253             for S in Config.Sections'Range loop
3254                Display_Section_Help (Config.Sections (S).all);
3255             end loop;
3256          end if;
3257       end if;
3258    end Display_Help;
3259
3260    ------------
3261    -- Getopt --
3262    ------------
3263
3264    procedure Getopt
3265      (Config      : Command_Line_Configuration;
3266       Callback    : Switch_Handler := null;
3267       Parser      : Opt_Parser := Command_Line_Parser;
3268       Concatenate : Boolean := True)
3269    is
3270       Getopt_Switches : String_Access;
3271       C               : Character := ASCII.NUL;
3272
3273       Empty_Name      : aliased constant String := "";
3274       Current_Section : Integer := -1;
3275       Section_Name    : not null access constant String := Empty_Name'Access;
3276
3277       procedure Simple_Callback
3278         (Simple_Switch : String;
3279          Separator     : String;
3280          Parameter     : String;
3281          Index         : Integer);
3282       --  Needs comments ???
3283
3284       procedure Do_Callback (Switch, Parameter : String; Index : Integer);
3285
3286       -----------------
3287       -- Do_Callback --
3288       -----------------
3289
3290       procedure Do_Callback (Switch, Parameter : String; Index : Integer) is
3291       begin
3292          --  Do automatic handling when possible
3293
3294          if Index /= -1 then
3295             case Config.Switches (Index).Typ is
3296                when Switch_Untyped =>
3297                   null;   --  no automatic handling
3298
3299                when Switch_Boolean =>
3300                   Config.Switches (Index).Boolean_Output.all :=
3301                     Config.Switches (Index).Boolean_Value;
3302                   return;
3303
3304                when Switch_Integer =>
3305                   begin
3306                      if Parameter = "" then
3307                         Config.Switches (Index).Integer_Output.all :=
3308                           Config.Switches (Index).Integer_Default;
3309                      else
3310                         Config.Switches (Index).Integer_Output.all :=
3311                           Integer'Value (Parameter);
3312                      end if;
3313
3314                   exception
3315                      when Constraint_Error =>
3316                         raise Invalid_Parameter
3317                           with "Expected integer parameter for '"
3318                             & Switch & "'";
3319                   end;
3320
3321                   return;
3322
3323                when Switch_String =>
3324                   Free (Config.Switches (Index).String_Output.all);
3325                   Config.Switches (Index).String_Output.all :=
3326                     new String'(Parameter);
3327                   return;
3328
3329             end case;
3330          end if;
3331
3332          --  Otherwise calls the user callback if one was defined
3333
3334          if Callback /= null then
3335             Callback (Switch    => Switch,
3336                       Parameter => Parameter,
3337                       Section   => Section_Name.all);
3338          end if;
3339       end Do_Callback;
3340
3341       procedure For_Each_Simple
3342         is new For_Each_Simple_Switch (Simple_Callback);
3343
3344       ---------------------
3345       -- Simple_Callback --
3346       ---------------------
3347
3348       procedure Simple_Callback
3349         (Simple_Switch : String;
3350          Separator     : String;
3351          Parameter     : String;
3352          Index         : Integer)
3353       is
3354          pragma Unreferenced (Separator);
3355       begin
3356          Do_Callback (Switch    => Simple_Switch,
3357                       Parameter => Parameter,
3358                       Index     => Index);
3359       end Simple_Callback;
3360
3361    --  Start of processing for Getopt
3362
3363    begin
3364       --  Initialize sections
3365
3366       if Config.Sections = null then
3367          Config.Sections := new Argument_List'(1 .. 0 => null);
3368       end if;
3369
3370       Internal_Initialize_Option_Scan
3371         (Parser                   => Parser,
3372          Switch_Char              => Parser.Switch_Character,
3373          Stop_At_First_Non_Switch => Parser.Stop_At_First,
3374          Section_Delimiters       => Section_Delimiters (Config));
3375
3376       Getopt_Switches := new String'
3377         (Get_Switches (Config, Parser.Switch_Character, Section_Name.all)
3378          & " h -help");
3379
3380       --  Initialize output values for automatically handled switches
3381
3382       for S in Config.Switches'Range loop
3383          case Config.Switches (S).Typ is
3384             when Switch_Untyped =>
3385                null;   --  Nothing to do
3386
3387             when Switch_Boolean =>
3388                Config.Switches (S).Boolean_Output.all :=
3389                  not Config.Switches (S).Boolean_Value;
3390
3391             when Switch_Integer =>
3392                Config.Switches (S).Integer_Output.all :=
3393                  Config.Switches (S).Integer_Initial;
3394
3395             when Switch_String =>
3396                Config.Switches (S).String_Output.all := new String'("");
3397          end case;
3398       end loop;
3399
3400       --  For all sections, and all switches within those sections
3401
3402       loop
3403          C := Getopt (Switches    => Getopt_Switches.all,
3404                       Concatenate => Concatenate,
3405                       Parser      => Parser);
3406
3407          if C = '*' then
3408             --  Full_Switch already includes the leading '-'
3409
3410             Do_Callback (Switch    => Full_Switch (Parser),
3411                          Parameter => Parameter (Parser),
3412                          Index     => -1);
3413
3414          elsif C /= ASCII.NUL then
3415             if Full_Switch (Parser) = "h"
3416                  or else
3417                Full_Switch (Parser) = "-help"
3418             then
3419                Display_Help (Config);
3420                raise Exit_From_Command_Line;
3421             end if;
3422
3423             --  Do switch expansion if needed
3424
3425             For_Each_Simple
3426               (Config,
3427                Section   => Section_Name.all,
3428                Switch    => Parser.Switch_Character & Full_Switch (Parser),
3429                Parameter => Parameter (Parser));
3430
3431          else
3432             if Current_Section = -1 then
3433                Current_Section := Config.Sections'First;
3434             else
3435                Current_Section := Current_Section + 1;
3436             end if;
3437
3438             exit when Current_Section > Config.Sections'Last;
3439
3440             Section_Name := Config.Sections (Current_Section);
3441             Goto_Section (Section_Name.all, Parser);
3442
3443             Free (Getopt_Switches);
3444             Getopt_Switches := new String'
3445               (Get_Switches
3446                  (Config, Parser.Switch_Character, Section_Name.all));
3447          end if;
3448       end loop;
3449
3450       Free (Getopt_Switches);
3451
3452    exception
3453       when Invalid_Switch =>
3454          Free (Getopt_Switches);
3455
3456          --  Message inspired by "ls" on Unix
3457
3458          Put_Line (Standard_Error,
3459                    Base_Name (Ada.Command_Line.Command_Name)
3460                    & ": unrecognized option '"
3461                    & Parser.Switch_Character & Full_Switch (Parser)
3462                    & "'");
3463          Put_Line (Standard_Error,
3464                    "Try `"
3465                    & Base_Name (Ada.Command_Line.Command_Name)
3466                    & " --help` for more information.");
3467
3468          raise;
3469
3470       when others =>
3471          Free (Getopt_Switches);
3472          raise;
3473    end Getopt;
3474
3475    -----------
3476    -- Build --
3477    -----------
3478
3479    procedure Build
3480      (Line        : in out Command_Line;
3481       Args        : out GNAT.OS_Lib.Argument_List_Access;
3482       Expanded    : Boolean := False;
3483       Switch_Char : Character := '-')
3484    is
3485       Iter  : Command_Line_Iterator;
3486       Count : Natural := 0;
3487
3488    begin
3489       Start (Line, Iter, Expanded => Expanded);
3490       while Has_More (Iter) loop
3491          if Is_New_Section (Iter) then
3492             Count := Count + 1;
3493          end if;
3494
3495          Count := Count + 1;
3496          Next (Iter);
3497       end loop;
3498
3499       Args := new Argument_List (1 .. Count);
3500       Count := Args'First;
3501
3502       Start (Line, Iter, Expanded => Expanded);
3503       while Has_More (Iter) loop
3504          if Is_New_Section (Iter) then
3505             Args (Count) := new String'(Switch_Char & Current_Section (Iter));
3506             Count := Count + 1;
3507          end if;
3508
3509          Args (Count) := new String'(Current_Switch (Iter)
3510                                      & Current_Separator (Iter)
3511                                      & Current_Parameter (Iter));
3512          Count := Count + 1;
3513          Next (Iter);
3514       end loop;
3515    end Build;
3516
3517 end GNAT.Command_Line;