clean.adb (Usage): Add line for -aP

2007-12-06  Bob Duff  <duff@adacore.com>

	* clean.adb (Usage): Add line for -aP
	(Check_Version_And_Help): Change Check_Version_And_Help to be generic,
	with a parameter "procedure Usage", instead of passing a pointer to a
	procedure. This is to eliminate trampolines (since the Usage procedure
	is often nested in a main procedure, and it would be inconvenient to
	unnest it).

	* g-comlin.adb (For_Each_Simple_Switch): Change For_Each_Simple_Switch
	to be generic, with a parameter "procedure Callback (...)", instead of
	passing a pointer to a procedure. This is to eliminate trampolines
	(since the Callback procedure is usually nested).

	* gnatfind.adb, switch.adb, switch.ads, gnatlink.adb, gnatls.adb, 
	gnatname.adb, gnatxref.adb, gnatchop.adb, gprep.adb, gnatbind.adb
	(Check_Version_And_Help): Change Check_Version_And_Help to be generic.

	* g-pehage.adb (Compute_Edges_And_Vertices, Build_Identical_Key_Sets):
	Use the generic Heap_Sort_G instead of Heap_Sort_A.

From-SVN: r130824

gcc/ada/clean.adb

@@ -1637,10 +1637,12 @@ package body Clean is
       Source_Index : Int := 0;
       Index        : Positive;
 
+      procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
+
    begin
       --  First, check for --version and --help
 
-      Check_Version_And_Help ("GNATCLEAN", "2003", Usage'Access);
+      Check_Version_And_Help ("GNATCLEAN", "2003");
 
       Index := 1;
       while Index <= Last loop
@@ -1970,6 +1972,9 @@ package body Clean is
                    "for GNAT Project Files");
          New_Line;
 
+         Put_Line ("  -aPdir   Add directory dir to project search path");
+         New_Line;
+
          Put_Line ("  -aOdir   Specify ALI/object files search path");
          Put_Line ("  -Idir    Like -aOdir");
          Put_Line ("  -I-      Don't look for source/library files " &

gcc/ada/g-comlin.adb

@@ -114,11 +114,11 @@ package body GNAT.Command_Line is
    function Args_From_Expanded (Args : Boolean_Chars) return String;
    --  Return the string made of all characters with True in Args
 
-   type Callback_Procedure is access procedure (Simple_Switch : String);
+   generic
+      with procedure Callback (Simple_Switch : String);
    procedure For_Each_Simple_Switch
-     (Cmd      : Command_Line;
-      Switch   : String;
-      Callback : Callback_Procedure);
+     (Cmd    : Command_Line;
+      Switch : String);
    --  Breaks Switch into as simple switches as possible (expanding aliases and
    --  ungrouping common prefixes when possible), and call Callback for each of
    --  these.
@@ -1185,9 +1185,8 @@ package body GNAT.Command_Line is
    ----------------------------
 
    procedure For_Each_Simple_Switch
-     (Cmd      : Command_Line;
-      Switch   : String;
-      Callback : Callback_Procedure)
+     (Cmd    : Command_Line;
+      Switch : String)
    is
    begin
       --  Are we adding a switch that can in fact be expanded through aliases ?
@@ -1204,7 +1203,7 @@ package body GNAT.Command_Line is
          for A in Cmd.Config.Aliases'Range loop
             if Cmd.Config.Aliases (A).all = Switch then
                For_Each_Simple_Switch
-                 (Cmd, Cmd.Config.Expansions (A).all, Callback);
+                 (Cmd, Cmd.Config.Expansions (A).all);
                return;
             end if;
          end loop;
@@ -1227,7 +1226,7 @@ package body GNAT.Command_Line is
                           .. Switch'Last
                loop
                   For_Each_Simple_Switch
-                    (Cmd, Cmd.Config.Prefixes (P).all & Switch (S), Callback);
+                    (Cmd, Cmd.Config.Prefixes (P).all & Switch (S));
                end loop;
                return;
             end if;
@@ -1291,11 +1290,13 @@ package body GNAT.Command_Line is
          end if;
       end Add_Simple_Switch;
 
+      procedure Add_Simple_Switches is
+         new For_Each_Simple_Switch (Add_Simple_Switch);
+
    --  Start of processing for Add_Switch
 
    begin
-      For_Each_Simple_Switch
-        (Cmd, Switch, Add_Simple_Switch'Unrestricted_Access);
+      Add_Simple_Switches (Cmd, Switch);
       Free (Cmd.Coalesce);
    end Add_Switch;
 
@@ -1381,11 +1382,13 @@ package body GNAT.Command_Line is
          end if;
       end Remove_Simple_Switch;
 
+      procedure Remove_Simple_Switches is
+         new For_Each_Simple_Switch (Remove_Simple_Switch);
+
    --  Start of processing for Remove_Switch
 
    begin
-      For_Each_Simple_Switch
-        (Cmd, Switch, Remove_Simple_Switch'Unrestricted_Access);
+      Remove_Simple_Switches (Cmd, Switch);
       Free (Cmd.Coalesce);
    end Remove_Switch;
 
@@ -1440,11 +1443,13 @@ package body GNAT.Command_Line is
          end if;
       end Remove_Simple_Switch;
 
+      procedure Remove_Simple_Switches is
+         new For_Each_Simple_Switch (Remove_Simple_Switch);
+
    --  Start of processing for Remove_Switch
 
    begin
-      For_Each_Simple_Switch
-        (Cmd, Switch, Remove_Simple_Switch'Unrestricted_Access);
+      Remove_Simple_Switches (Cmd, Switch);
       Free (Cmd.Coalesce);
    end Remove_Switch;
 
@@ -1566,6 +1571,9 @@ package body GNAT.Command_Line is
          end loop;
       end Remove_Cb;
 
+      procedure Check_All is new For_Each_Simple_Switch (Check_Cb);
+      procedure Remove_All is new For_Each_Simple_Switch (Remove_Cb);
+
    --  Start of processing for Alias_Switches
 
    begin
@@ -1582,15 +1590,11 @@ package body GNAT.Command_Line is
          --  then check whether the expanded command line has all of them.
 
          Found := True;
-         For_Each_Simple_Switch
-           (Cmd, Cmd.Config.Expansions (A).all,
-            Check_Cb'Unrestricted_Access);
+         Check_All (Cmd, Cmd.Config.Expansions (A).all);
 
          if Found then
             First := Integer'Last;
-            For_Each_Simple_Switch
-              (Cmd, Cmd.Config.Expansions (A).all,
-               Remove_Cb'Unrestricted_Access);
+            Remove_All (Cmd, Cmd.Config.Expansions (A).all);
             Result (First) := new String'(Cmd.Config.Aliases (A).all);
          end if;
       end loop;

gcc/ada/g-pehage.adb

@@ -34,7 +34,7 @@
 with Ada.Exceptions;    use Ada.Exceptions;
 with Ada.IO_Exceptions; use Ada.IO_Exceptions;
 
-with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
+with GNAT.Heap_Sort_G;
 with GNAT.OS_Lib;      use GNAT.OS_Lib;
 with GNAT.Table;
 
@@ -696,7 +696,7 @@ package body GNAT.Perfect_Hash_Generators is
 
       procedure Move (From : Natural; To : Natural);
       function Lt (L, R : Natural) return Boolean;
-      --  Subprograms needed for GNAT.Heap_Sort_A
+      --  Subprograms needed for GNAT.Heap_Sort_G
 
       --------
       -- Lt --
@@ -718,11 +718,13 @@ package body GNAT.Perfect_Hash_Generators is
          Set_Edges (To, Get_Edges (From));
       end Move;
 
+      package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
+
    --  Start of processing for Compute_Edges_And_Vertices
 
    begin
       --  We store edges from 1 to 2 * NK and leave zero alone in order to use
-      --  GNAT.Heap_Sort_A.
+      --  GNAT.Heap_Sort_G.
 
       Edges_Len := 2 * NK + 1;
 
@@ -780,10 +782,7 @@ package body GNAT.Perfect_Hash_Generators is
          --  is sorted by X and then Y. To compute the neighbor list, sort the
          --  edges.
 
-         Sort
-           (Edges_Len - 1,
-            Move'Unrestricted_Access,
-            Lt'Unrestricted_Access);
+         Sorting.Sort (Edges_Len - 1);
 
          if Verbose then
             Put_Edges      (Output, "Sorted Edge Table");
@@ -1976,7 +1975,7 @@ package body GNAT.Perfect_Hash_Generators is
 
          function Lt (L, R : Natural) return Boolean;
          procedure Move (From : Natural; To : Natural);
-         --  Subprograms needed by GNAT.Heap_Sort_A
+         --  Subprograms needed by GNAT.Heap_Sort_G
 
          --------
          -- Lt --
@@ -2024,6 +2023,8 @@ package body GNAT.Perfect_Hash_Generators is
             WT.Table (Target) := WT.Table (Source);
          end Move;
 
+         package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
+
       --  Start of processing for Build_Identical_Key_Sets
 
       begin
@@ -2041,10 +2042,7 @@ package body GNAT.Perfect_Hash_Generators is
 
             else
                Offset := Reduced (S (J).First) - 1;
-               Sort
-                 (S (J).Last - S (J).First + 1,
-                  Move'Unrestricted_Access,
-                  Lt'Unrestricted_Access);
+               Sorting.Sort (S (J).Last - S (J).First + 1);
 
                F := S (J).First;
                L := F;

gcc/ada/gnatbind.adb

@@ -403,6 +403,9 @@ procedure Gnatbind is
       end if;
    end Scan_Bind_Arg;
 
+   procedure Check_Version_And_Help is
+      new Check_Version_And_Help_G (Bindusg.Display);
+
 --  Start of processing for Gnatbind
 
 begin
@@ -429,7 +432,7 @@ begin
 
    --  First, scan to detect --version and/or --help
 
-   Check_Version_And_Help ("GNATBIND", "1995", Bindusg.Display'Access);
+   Check_Version_And_Help ("GNATBIND", "1995");
 
    --  Use low level argument routines to avoid dragging in the secondary stack
 

gcc/ada/gnatchop.adb

@@ -1724,6 +1724,8 @@ procedure Gnatchop is
       end;
    end Write_Unit;
 
+      procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
+
 --  Start of processing for gnatchop
 
 begin
@@ -1763,7 +1765,7 @@ begin
 
    --  First, scan to detect --version and/or --help
 
-   Check_Version_And_Help ("GNATCHOP", "1998", Usage'Unrestricted_Access);
+   Check_Version_And_Help ("GNATCHOP", "1998");
 
    if not Scan_Arguments then
       Set_Exit_Status (Failure);

gcc/ada/gnatfind.adb

@@ -78,10 +78,15 @@ procedure Gnatfind is
    --------------------
 
    procedure Parse_Cmd_Line is
+
+      procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
+
+      --  Start of processing for Parse_Cmd_Line
+
    begin
       --  First check for --version or --help
 
-      Check_Version_And_Help ("GNATFIND", "1998", Usage'Unrestricted_Access);
+      Check_Version_And_Help ("GNATFIND", "1998");
 
       --  Now scan the other switches
 

gcc/ada/gnatlink.adb

@@ -292,10 +292,14 @@ procedure Gnatlink is
       --  Set to true if the next argument is to be added into the list of
       --  linker's argument without parsing it.
 
+      procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
+
+      --  Start of processing for Process_Args
+
    begin
       --  First, check for --version and --help
 
-      Check_Version_And_Help ("GNATLINK", "1995", Usage'Unrestricted_Access);
+      Check_Version_And_Help ("GNATLINK", "1995");
 
       --  Loop through arguments of gnatlink command
 
@@ -1765,7 +1769,12 @@ begin
               Binder_Options.Table (J);
          end loop;
 
-         Args (Args'Last) := Binder_Body_Src_File;
+         --  Use the full path of the binder generated source, so that it is
+         --  guaranteed that the debugger will find this source, even with
+         --  STABS.
+
+         Args (Args'Last) :=
+           new String'(Normalize_Pathname (Binder_Body_Src_File.all));
 
          if Verbose_Mode then
             Write_Str (Base_Name (Gcc_Path.all));

gcc/ada/gnatls.adb

@@ -1519,6 +1519,8 @@ procedure Gnatls is
       end loop;
    end Usage;
 
+   procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
+
 --  Start of processing for Gnatls
 
 begin
@@ -1530,7 +1532,7 @@ begin
 
    --  First check for --version or --help
 
-   Check_Version_And_Help ("GNATLS", "1997", Usage'Unrestricted_Access);
+   Check_Version_And_Help ("GNATLS", "1997");
 
    --  Loop to scan out arguments
 

gcc/ada/gnatname.adb

@@ -177,10 +177,15 @@ procedure Gnatname is
    ---------------
 
    procedure Scan_Args is
+
+      procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
+
+      --  Start of processing for Scan_Args
+
    begin
       --  First check for --version or --help
 
-      Check_Version_And_Help ("GNATNAME", "2001", Usage'Unrestricted_Access);
+      Check_Version_And_Help ("GNATNAME", "2001");
 
       --  Now scan the other switches
 

gcc/ada/gnatxref.adb

@@ -66,10 +66,15 @@ procedure Gnatxref is
    --------------------
 
    procedure Parse_Cmd_Line is
+
+      procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
+
+      --  Start of processing for Parse_Cmd_Line
+
    begin
       --  First check for --version or --help
 
-      Check_Version_And_Help ("GNATXREF", "1998", Usage'Unrestricted_Access);
+      Check_Version_And_Help ("GNATXREF", "1998");
 
       loop
          case

gcc/ada/gprep.adb

@@ -699,10 +699,14 @@ package body GPrep is
    procedure Scan_Command_Line is
       Switch : Character;
 
+      procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
+
+      --  Start of processing for Scan_Command_Line
+
    begin
       --  First check for --version or --help
 
-      Check_Version_And_Help ("GNATPREP", "1996", Usage'Access);
+      Check_Version_And_Help ("GNATPREP", "1996");
 
       --  Now scan the other switches
 

gcc/ada/switch.adb

@@ -42,14 +42,13 @@ package body Switch is
       Osint.Fail ("invalid switch: ", Switch);
    end Bad_Switch;
 
-   ----------------------------
-   -- Check_Version_And_Help --
-   ----------------------------
+   ------------------------------
+   -- Check_Version_And_Help_G --
+   ------------------------------
 
-   procedure Check_Version_And_Help
+   procedure Check_Version_And_Help_G
      (Tool_Name      : String;
       Initial_Year   : String;
-      Usage          : Procedure_Ptr;
       Version_String : String := Gnatvsn.Gnat_Version_String)
    is
       Version_Switch_Present : Boolean := False;
@@ -92,12 +91,12 @@ package body Switch is
 
       if Help_Switch_Present then
          Set_Standard_Output;
-         Usage.all;
+         Usage;
          Write_Eol;
          Write_Line ("Report bugs to report@adacore.com");
          Exit_Program (E_Success);
       end if;
-   end Check_Version_And_Help;
+   end Check_Version_And_Help_G;
 
    ---------------------
    -- Display_Version --

gcc/ada/switch.ads

@@ -23,16 +23,20 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
---  This package together with a child package appropriate to the client
---  tool scans switches. Note that the body of the appropraite Usage package
---  must be coordinated with the switches that are recognized by this package.
---  These Usage packages also act as the official documentation for the
---  switches that are recognized. In addition, package Debug documents
---  the otherwise undocumented debug switches that are also recognized.
+--  This package together with a child package appropriate to the client tool
+--  scans switches. Note that the body of the appropraite Usage package must be
+--  coordinated with the switches that are recognized by this package. These
+--  Usage packages also act as the official documentation for the switches
+--  that are recognized. In addition, package Debug documents the otherwise
+--  undocumented debug switches that are also recognized.
 
 with Gnatvsn;
 with Types; use Types;
 
+------------
+-- Switch --
+------------
+
 package Switch is
 
    --  Common switches for GNU tools
@@ -44,15 +48,15 @@ package Switch is
    -- Subprograms --
    -----------------
 
-   type Procedure_Ptr is access procedure;
-
-   procedure Check_Version_And_Help
+   generic
+      with procedure Usage;
+      --  Print tool-specific part of --help message
+   procedure Check_Version_And_Help_G
      (Tool_Name      : String;
       Initial_Year   : String;
-      Usage          : Procedure_Ptr;
       Version_String : String := Gnatvsn.Gnat_Version_String);
-   --  Check if switches --version or --help is used. If one of this switch
-   --  is used, issue the proper messages and end the process.
+   --  Check if switches --version or --help is used. If one of this switch is
+   --  used, issue the proper messages and end the process.
 
    procedure Display_Version
      (Tool_Name      : String;
@@ -61,12 +65,12 @@ package Switch is
    --  Display version of a tool when switch --version is used
 
    function Is_Switch (Switch_Chars : String) return Boolean;
-   --  Returns True iff Switch_Chars is at least two characters long,
-   --  and the first character is an hyphen ('-').
+   --  Returns True iff Switch_Chars is at least two characters long, and the
+   --  first character is an hyphen ('-').
 
    function Is_Front_End_Switch (Switch_Chars : String) return Boolean;
-   --  Returns True iff Switch_Chars represents a front-end switch,
-   --  ie. it starts with -I, -gnat or -?RTS.
+   --  Returns True iff Switch_Chars represents a front-end switch, i.e. it
+   --  starts with -I, -gnat or -?RTS.
 
 private
 
@@ -83,9 +87,9 @@ private
       Ptr          : in out Integer;
       Result       : out Nat;
       Switch       : Character);
-   --  Scan natural integer parameter for switch. On entry, Ptr points
-   --  just past the switch character, on exit it points past the last
-   --  digit of the integer value.
+   --  Scan natural integer parameter for switch. On entry, Ptr points just
+   --  past the switch character, on exit it points past the last digit of the
+   --  integer value.
 
    procedure Scan_Pos
      (Switch_Chars : String;
@@ -93,9 +97,9 @@ private
       Ptr          : in out Integer;
       Result       : out Pos;
       Switch       : Character);
-   --  Scan positive integer parameter for switch. On entry, Ptr points
-   --  just past the switch character, on exit it points past the last
-   --  digit of the integer value.
+   --  Scan positive integer parameter for switch. On entry, Ptr points just
+   --  past the switch character, on exit it points past the last digit of the
+   --  integer value.
 
    procedure Bad_Switch (Switch : Character);
    procedure Bad_Switch (Switch : String);