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