OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [g-comlin.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.