home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / features.adb < prev    next >
Text File  |  1996-09-28  |  14KB  |  470 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                             F E A T U R E S                              --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.10 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. with Alloc;    use Alloc;
  26. with Csets;    use Csets;
  27. with Gnatsort; use Gnatsort;
  28. with Lib;      use Lib;
  29. with Namet;    use Namet;
  30. with Opt;      use Opt;
  31. with Output;   use Output;
  32. with Sinput;   use Sinput;
  33. with Uname;    use Uname;
  34. with Table;
  35.  
  36. with System.Parameters;
  37.  
  38. package body Features is
  39.  
  40.    --  Data structures used to record feature references. Note that the entry
  41.    --  with index zero is used only as a temporary for the sort routine.
  42.  
  43.    type Feature_Ref is record
  44.       F : Feature_Name;
  45.       L : Source_Ptr;
  46.    end record;
  47.  
  48.    package Feature_List is new Table (
  49.      Table_Component_Type => Feature_Ref,
  50.      Table_Index_Type     => Natural,
  51.      Table_Low_Bound      => 0,
  52.      Table_Initial        => Alloc_Feature_List_Initial,
  53.      Table_Increment      => Alloc_Feature_List_Increment,
  54.      Table_Name           => "Feature_List");
  55.  
  56.    --  Data structures used to record with'ed units. Note that the entry
  57.    --  with index zero is used only as a temporary for the sort routine.
  58.  
  59.    type With_Ref is record
  60.       U : Unit_Name_Type;
  61.       L : Source_Ptr;
  62.    end record;
  63.  
  64.    package With_List is new Table (
  65.      Table_Component_Type => With_Ref,
  66.      Table_Index_Type     => Natural,
  67.      Table_Low_Bound      => 0,
  68.      Table_Initial        => Alloc_With_List_Initial,
  69.      Table_Increment      => Alloc_With_List_Increment,
  70.      Table_Name           => "With_List");
  71.  
  72.    --  Other global data
  73.  
  74.    Multiple_Files : Boolean := False;
  75.    --  Set to True if references for more than one file are
  76.  
  77.    Last_Index : Source_File_Index := No_Source_File;
  78.    --  Set to source table index of last file for which a reference was output.
  79.    --  Used in multiple file case only, not set or read otherwise.
  80.  
  81.    -----------------------
  82.    -- Local Subprograms --
  83.    -----------------------
  84.  
  85.    function Lt_Feature (Op1, Op2 : Natural) return Boolean;
  86.    --  Comparison routine for comparing Feature_List table entries
  87.  
  88.    function Lt_Slocs (Op1, Op2 : Source_Ptr) return Boolean;
  89.    --  Comparison routine used to compare two Sloc values to determine
  90.    --  the order in which the references should be output in the table.
  91.  
  92.    function Lt_Units (Op1, Op2 : Unit_Name_Type) return Boolean;
  93.    --  Comparison routine for comparing two unit numbers, by alphabetical
  94.    --  comparison of the corresponding unit names.
  95.  
  96.    function Lt_With (Op1, Op2 : Natural) return Boolean;
  97.    --  Comparison routine for comparing Feature_List table entries
  98.  
  99.    procedure Move_Feature (From : Natural; To : Natural);
  100.    --  Move routine for sorting the Feature_List table
  101.  
  102.    procedure Move_With (From : Natural; To : Natural);
  103.    --  Move routine for sorting the With_List table
  104.  
  105.    procedure Write_Ref (L : Source_Ptr);
  106.    --  Writes a single reference dealing with lining up columns nicely
  107.  
  108.    --------------
  109.    -- Finalize --
  110.    --------------
  111.  
  112.    procedure Finalize is
  113.       Index : Natural;
  114.  
  115.    begin
  116.       if not Features_On then
  117.          return;
  118.       end if;
  119.  
  120.       Write_Eol;
  121.  
  122.       --  Output features list
  123.  
  124.       if Feature_List.Last = 0 then
  125.          Write_Str ("No use of Ada 95 features recorded");
  126.          Write_Eol;
  127.  
  128.       else
  129.          --  If entries present, first sort them
  130.  
  131.          Sort (Feature_List.Last, Move_Feature'Access, Lt_Feature'Access);
  132.  
  133.          --  Then remove duplicate entries, which can arise from multiple
  134.          --  recording of the same use in different parts of the compiler.
  135.  
  136.          declare
  137.             N : Natural := 1;
  138.  
  139.          begin
  140.             for J in 2 .. Feature_List.Last loop
  141.                if Feature_List.Table (J) /= Feature_List.Table (J - 1) then
  142.                   N := N + 1;
  143.                   Feature_List.Table (N) := Feature_List.Table (J);
  144.                end if;
  145.             end loop;
  146.  
  147.             Feature_List.Set_Last (N);
  148.          end;
  149.  
  150.          --  Now generate output listing
  151.  
  152.          Write_Str ("Use of Ada 95 Features");
  153.  
  154.          --  Loop through features in table
  155.  
  156.          Index := 1;
  157.  
  158.          Features_Loop : loop
  159.             declare
  160.                F : constant Feature_Name := Feature_List.Table (Index).F;
  161.                S : String                := Feature_Name'Image (F);
  162.  
  163.             begin
  164.                Write_Eol;
  165.                Write_Eol;
  166.                Write_Str (Code_Names (F));
  167.                Write_Char (' ');
  168.  
  169.                for J in 2 .. S'Length loop
  170.                   if S (J) = '_' then
  171.                      S (J) := ' ';
  172.                   else
  173.                      S (J) := Fold_Lower (S (J));
  174.                   end if;
  175.                end loop;
  176.  
  177.                Write_Str (S);
  178.                Write_Eol;
  179.  
  180.                if not Multiple_Files then
  181.                   Write_Str ("  ");
  182.                end if;
  183.  
  184.                Last_Index := No_Source_File;
  185.  
  186.                --  Loop through entries for single feature
  187.  
  188.                Ref_Loop : loop
  189.                   exit Features_Loop when Index > Feature_List.Last;
  190.                   exit Ref_Loop when Feature_List.Table (Index).F /= F;
  191.                   Write_Ref (Feature_List.Table (Index).L);
  192.                   Index := Index + 1;
  193.                end loop Ref_Loop;
  194.             end;
  195.          end loop Features_Loop;
  196.       end if;
  197.  
  198.       --  Output with'ed unit table use table
  199.  
  200.       return;
  201.       --  ??? for now, next section not implemented yet
  202.  
  203.       Write_Eol;
  204.       Write_Eol;
  205.  
  206.       if With_List.Last = 0 then
  207.          Write_Str ("No use of Ada 95 Library Units Recorded");
  208.          Write_Eol;
  209.          Write_Eol;
  210.  
  211.       else
  212.          --  If entries present, first sort them
  213.  
  214.          Sort (With_List.Last, Move_With'Access, Lt_With'Access);
  215.  
  216.          --  Then remove duplicate entries, which can arise from multiple
  217.          --  recording of the same use in different parts of the compiler.
  218.  
  219.          declare
  220.             N : Natural := 1;
  221.  
  222.          begin
  223.             for J in 2 .. With_List.Last loop
  224.                if With_List.Table (J) /= With_List.Table (J - 1) then
  225.                   N := N + 1;
  226.                   With_List.Table (N) := With_List.Table (J);
  227.                end if;
  228.             end loop;
  229.  
  230.             With_List.Set_Last (N);
  231.          end;
  232.  
  233.          --  Now generate output listing
  234.  
  235.          Write_Str ("Use of Ada 95 Library Units Recorded");
  236.          Write_Eol;
  237.          Write_Str ("------------------------------------");
  238.          Write_Eol;
  239.  
  240.          --  Loop through with'ed units in table
  241.  
  242.          Index := 1;
  243.  
  244.          With_Loop : loop
  245.             declare
  246.                U : constant Unit_Name_Type := With_List.Table (Index).U;
  247.  
  248.             begin
  249.                Write_Eol;
  250.                Write_Unit_Name (U);
  251.                Write_Char (' ');
  252.                Last_Index := No_Source_File;
  253.  
  254.                --  Loop through entries for single with'ed unit
  255.  
  256.                Ref_Loop : loop
  257.                   exit With_Loop when Index > With_List.Last;
  258.                   exit Ref_Loop when With_List.Table (Index).U /= U;
  259.                   Write_Ref (With_List.Table (Index).L);
  260.                   Index := Index + 1;
  261.                end loop Ref_Loop;
  262.             end;
  263.          end loop With_Loop;
  264.       end if;
  265.  
  266.    end Finalize;
  267.  
  268.    ----------------
  269.    -- Initialize --
  270.    ----------------
  271.  
  272.    procedure Initialize is
  273.    begin
  274.       if Xref_Flag_9 then
  275.          Features_On := True;
  276.          Feature_List.Init;
  277.          With_List.Init;
  278.  
  279.          --  Allocate zero index entries at the start of the tables (used by
  280.          --  sort routine as temporaries, not otherwise used for real entries)
  281.  
  282.          Feature_List.Increment_Last;
  283.          With_List.Increment_Last;
  284.       end if;
  285.    end Initialize;
  286.  
  287.    ----------------
  288.    -- Lt_Feature --
  289.    ----------------
  290.  
  291.    function Lt_Feature (Op1, Op2 : Natural) return Boolean is
  292.    begin
  293.       if Feature_List.Table (Op1).F /= Feature_List.Table (Op2).F then
  294.          return Feature_List.Table (Op1).F < Feature_List.Table (Op2).F;
  295.       else
  296.          return
  297.            Lt_Slocs (Feature_List.Table (Op1).L, Feature_List.Table (Op2).L);
  298.       end if;
  299.    end Lt_Feature;
  300.  
  301.    --------------
  302.    -- Lt_Slocs --
  303.    --------------
  304.  
  305.    function Lt_Slocs (Op1, Op2 : Source_Ptr) return Boolean is
  306.       Op1_Unit : constant Unit_Name_Type :=
  307.                    Unit_Name (Get_Sloc_Unit_Number (Op1));
  308.       Op2_Unit : constant Unit_Name_Type :=
  309.                    Unit_Name (Get_Sloc_Unit_Number (Op2));
  310.  
  311.    begin
  312.       if Op1_Unit = Op2_Unit then
  313.          return Op1 < Op2;
  314.       else
  315.          return Lt_Units (Op1_Unit, Op2_Unit);
  316.       end if;
  317.    end Lt_Slocs;
  318.  
  319.    --------------
  320.    -- Lt_Units --
  321.    --------------
  322.  
  323.    function Lt_Units (Op1, Op2 : Unit_Name_Type) return Boolean is
  324.       Op1_Name     : String (1 .. System.Parameters.Max_Name_Length);
  325.       Op1_Name_Len : Natural;
  326.       Op2_Name     : String renames Name_Buffer;
  327.       Op2_Name_Len : Natural renames Name_Len;
  328.  
  329.    begin
  330.       Get_Name_String (Op1);
  331.       Op1_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
  332.       Op1_Name_Len := Name_Len;
  333.       Get_Name_String (Op2);
  334.  
  335.       for J in 1 .. Name_Len loop
  336.          if Op1_Name (J) /= Op2_Name (J) then
  337.             return Op1_Name (J) < Op2_Name (J);
  338.          end if;
  339.       end loop;
  340.  
  341.       return Op1_Name_Len < Op2_Name_Len;
  342.    end Lt_Units;
  343.  
  344.    -------------
  345.    -- Lt_With --
  346.    -------------
  347.  
  348.    function Lt_With (Op1, Op2 : Natural) return Boolean is
  349.       Op1_Unit : constant Unit_Name_Type := With_List.Table (Op1).U;
  350.       Op2_Unit : constant Unit_Name_Type := With_List.Table (Op2).U;
  351.  
  352.    begin
  353.       if Op1_Unit /= Op2_Unit then
  354.          return Lt_Units (Op1_Unit, Op2_Unit);
  355.       else
  356.          return Lt_Slocs (With_List.Table (Op1).L, With_List.Table (Op2).L);
  357.       end if;
  358.    end Lt_With;
  359.  
  360.    ------------------
  361.    -- Move_Feature --
  362.    ------------------
  363.  
  364.    procedure Move_Feature (From : Natural; To : Natural) is
  365.    begin
  366.       Feature_List.Table (To) := Feature_List.Table (From);
  367.    end Move_Feature;
  368.  
  369.    ---------------
  370.    -- Move_With --
  371.    ---------------
  372.  
  373.    procedure Move_With (From : Natural; To : Natural) is
  374.    begin
  375.       With_List.Table (To) := With_List.Table (From);
  376.    end Move_With;
  377.  
  378.    ------------------
  379.    -- Note_Feature --
  380.    ------------------
  381.  
  382.    procedure Note_Feature (F : Feature_Name; Loc : Source_Ptr) is
  383.    begin
  384.       if Loc in Source_Text (Source_Index (Main_Unit))'Range then
  385.          Feature_List.Increment_Last;
  386.          Feature_List.Table (Feature_List.Last) := (F => F, L => Loc);
  387.       end if;
  388.    end Note_Feature;
  389.  
  390.    ---------------
  391.    -- Note_With --
  392.    ---------------
  393.  
  394.    procedure Note_With (U : Unit_Name_Type; Loc : Source_Ptr) is
  395.    begin
  396.       if Loc in Source_Text (Source_Index (Main_Unit))'Range then
  397.          With_List.Increment_Last;
  398.          With_List.Table (With_List.Last) := (U => U, L => Loc);
  399.       end if;
  400.    end Note_With;
  401.  
  402.    ---------------
  403.    -- Write_Ref --
  404.    ---------------
  405.  
  406.    procedure Write_Ref (L : Source_Ptr) is
  407.       Source_Index : Source_File_Index;
  408.       Lin          : Logical_Line_Number;
  409.       Col          : Column_Number;
  410.  
  411.    begin
  412.       --  For multiple file case, new line if file name changes
  413.  
  414.       if Multiple_Files then
  415.          if Last_Index = No_Source_File
  416.            or else L not in Source_Text (Last_Index)'Range
  417.          then
  418.             Write_Eol;
  419.             Last_Index := Get_Source_File_Index (L);
  420.             Write_Str ("  ");
  421.             Write_Name (File_Name (Last_Index));
  422.             Write_Eol;
  423.             Write_Str ("  ");
  424.          end if;
  425.       end if;
  426.  
  427.       --  Start new line if current line is full
  428.  
  429.       if Column > 72 then
  430.          Write_Eol;
  431.  
  432.          if Multiple_Files then
  433.             Write_Str ("    ");
  434.          else
  435.             Write_Str ("  ");
  436.          end if;
  437.       end if;
  438.  
  439.       --  We do a bit of padding on the line and column number so that in
  440.       --  the most usual cases, the references line up nicely in columns
  441.  
  442.       Lin := Get_Line_Number (L);
  443.  
  444.       if Lin < 1000 then
  445.          Write_Char (' ');
  446.  
  447.          if Lin < 100 then
  448.             Write_Char (' ');
  449.  
  450.             if Lin < 10 then
  451.                Write_Char (' ');
  452.             end if;
  453.          end if;
  454.       end if;
  455.  
  456.       Write_Int (Int (Lin));
  457.       Col := Get_Column_Number (L);
  458.       Write_Char ('(');
  459.  
  460.       if Col < 10 then
  461.          Write_Char ('0');
  462.       end if;
  463.  
  464.       Write_Int (Int (Col));
  465.       Write_Char (')');
  466.       Write_Char (' ');
  467.    end Write_Ref;
  468.  
  469. end Features;
  470.