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 / butil.adb < prev    next >
Text File  |  1996-09-28  |  5KB  |  152 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                                B U T I L                                 --
  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 Namet;  use Namet;
  26. with Output; use Output;
  27.  
  28. package body Butil is
  29.  
  30.    ------------------------
  31.    -- Is_Predefined_Unit --
  32.    ------------------------
  33.  
  34.    function Is_Predefined_Unit return Boolean is
  35.    begin
  36.       return    (Name_Len >  3
  37.                   and then Name_Buffer (1 ..  4) = "ada.")
  38.  
  39.         or else (Name_Len >  6
  40.                   and then Name_Buffer (1 ..  7) = "system.")
  41.  
  42.         or else (Name_Len > 10
  43.                    and then Name_Buffer (1 .. 11) = "interfaces.")
  44.  
  45.         or else (Name_Len >  3
  46.                    and then Name_Buffer (1 ..  4) = "ada%")
  47.  
  48.         or else (Name_Len >  8
  49.                    and then Name_Buffer (1 ..  9) = "calendar%")
  50.  
  51.         or else (Name_Len >  9
  52.                    and then Name_Buffer (1 .. 10) = "direct_io%")
  53.  
  54.         or else (Name_Len > 10
  55.                    and then Name_Buffer (1 .. 11) = "interfaces%")
  56.  
  57.         or else (Name_Len > 13
  58.                    and then Name_Buffer (1 .. 14) = "io_exceptions%")
  59.  
  60.         or else (Name_Len > 12
  61.                    and then Name_Buffer (1 .. 13) = "machine_code%")
  62.  
  63.         or else (Name_Len > 13
  64.                    and then Name_Buffer (1 .. 14) = "sequential_io%")
  65.  
  66.         or else (Name_Len >  6
  67.                    and then Name_Buffer (1 ..  7) = "system%")
  68.  
  69.         or else (Name_Len >  7
  70.                    and then Name_Buffer (1 ..  8) = "text_io%")
  71.  
  72.         or else (Name_Len > 20
  73.                    and then Name_Buffer (1 .. 21) = "unchecked_conversion%")
  74.  
  75.         or else (Name_Len > 22
  76.                    and then Name_Buffer (1 .. 23) = "unchecked_deallocation%");
  77.  
  78.    end Is_Predefined_Unit;
  79.  
  80.  
  81.  
  82.    -----------
  83.    -- Later --
  84.    -----------
  85.  
  86.    function Later (T1, T2 : Time_Stamp_Type) return Boolean is
  87.    begin
  88.       for I in T1'Range loop
  89.          if T1 (I) > T2 (I) then
  90.             return True;
  91.          elsif T1 (I) < T2 (I) then
  92.             return False;
  93.          end if;
  94.       end loop;
  95.  
  96.       return False;
  97.    end Later;
  98.  
  99.    ----------------
  100.    -- Uname_Less --
  101.    ----------------
  102.  
  103.    function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is
  104.    begin
  105.       Get_Name_String (U1);
  106.  
  107.       declare
  108.          U1_Name : constant String (1 .. Name_Len) :=
  109.                                            Name_Buffer (1 .. Name_Len);
  110.          Min_Length : Natural;
  111.  
  112.       begin
  113.          Get_Name_String (U2);
  114.  
  115.          if Name_Len < U1_Name'Last then
  116.             Min_Length := Name_Len;
  117.          else
  118.             Min_Length := U1_Name'Last;
  119.          end if;
  120.  
  121.          for I in 1 .. Min_Length loop
  122.             if U1_Name (I) > Name_Buffer (I) then
  123.                return False;
  124.             elsif U1_Name (I) < Name_Buffer (I) then
  125.                return True;
  126.             end if;
  127.          end loop;
  128.  
  129.          return U1_Name'Last < Name_Len;
  130.       end;
  131.    end Uname_Less;
  132.  
  133.    ---------------------
  134.    -- Write_Unit_Name --
  135.    ---------------------
  136.  
  137.    procedure Write_Unit_Name (U : Unit_Name_Type) is
  138.    begin
  139.       Get_Name_String (U);
  140.       Write_Str (Name_Buffer (1 .. Name_Len - 2));
  141.  
  142.       if Name_Buffer (Name_Len) = 's' then
  143.          Write_Str (" (spec)");
  144.       else
  145.          Write_Str (" (body)");
  146.       end if;
  147.  
  148.       Name_Len := Name_Len + 5;
  149.    end Write_Unit_Name;
  150.  
  151. end Butil;
  152.