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 / gnatk8.adb < prev    next >
Text File  |  1996-09-28  |  4KB  |  134 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                               G N A T K 8                                --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.11 $                             --
  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 Ada.Characters.Handling; use Ada.Characters.Handling;
  26. with Krunch;
  27. with System.Io; use System.Io;
  28.  
  29. function Gnatk8 return Exit_Status is
  30.    Count        : Natural;
  31.    Maxlen       : Natural;
  32.    Exit_Program : exception;
  33.  
  34. begin
  35.    Count := Argument_Count;
  36.  
  37.    if Count < 1 or else Count > 2 then
  38.       Put_Line ("Usage: gnatk8  filename[.extension]  [krunch-count]");
  39.       raise Exit_Program;
  40.  
  41.    else
  42.       --  If the length (krunch-count) argument is omitted use default of 8.
  43.  
  44.       if Count = 1 then
  45.          Maxlen := 8;
  46.  
  47.       else
  48.          Maxlen := 0;
  49.  
  50.          for J in Argument (2)'Range loop
  51.             if Argument (2) (J) /= ' ' then
  52.                if Argument (2) (J) not in '0' .. '9' then
  53.                   Put_Line ("Illegal argument for krunch-count");
  54.                   raise Exit_Program;
  55.                else
  56.                   Maxlen := Maxlen * 10 +
  57.                     Character'Pos (Argument (2) (J)) - Character'Pos ('0');
  58.                end if;
  59.             end if;
  60.          end loop;
  61.  
  62.          --  Zero means crunch only system files
  63.  
  64.          if Maxlen = 0 then
  65.             Maxlen := Natural'Last;
  66.          end if;
  67.  
  68.       end if;
  69.  
  70.       declare
  71.          Fname : String  := Argument (1);
  72.          Klen  : Natural := Fname'Length;
  73.  
  74.          Extp  : Boolean := False;
  75.          --  True if extension is present
  76.  
  77.          Ext   : Natural;
  78.          --  If extension is present, points to it
  79.  
  80.       begin
  81.          --  Remove .adb or .ads extension if present (recognized only if the
  82.          --  name is all lower case and contains no other instances of dots)
  83.  
  84.          if Klen > 4
  85.            and then Fname (Klen - 3 .. Klen - 1) = ".ad"
  86.            and then (Fname (Klen) = 's' or else Fname (Klen) = 'b')
  87.          then
  88.             Extp := True;
  89.  
  90.             for J in 1 .. Klen - 4 loop
  91.                if Is_Upper (Fname (J)) or else Fname (J) = '.' then
  92.                   Extp := False;
  93.                end if;
  94.             end loop;
  95.  
  96.             if Extp then
  97.                Klen := Klen - 4;
  98.                Ext := Klen + 1;
  99.             end if;
  100.  
  101.          else
  102.             Extp := False;
  103.          end if;
  104.  
  105.          --  Fold to lower case and replace dots by dashes
  106.  
  107.          for J in 1 .. Klen loop
  108.             Fname (J) := To_Lower (Fname (J));
  109.  
  110.             if Fname (J) = '.' then
  111.                Fname (J) := '-';
  112.             end if;
  113.          end loop;
  114.  
  115.          Krunch (Fname, Klen, Maxlen, False);
  116.  
  117.          Put (Fname (1 .. Klen));
  118.  
  119.          if Extp then
  120.             Put (Fname (Ext .. Fname'Length));
  121.          end if;
  122.  
  123.          New_Line;
  124.       end;
  125.    end if;
  126.  
  127.    return Success;
  128.  
  129. exception
  130.    when Exit_Program =>
  131.       return Failure;
  132.  
  133. end Gnatk8;
  134.